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 117035d2415ea430696f0bb88c7e38b99015285d..0000000000000000000000000000000000000000 --- a/assembly/assemfile.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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.11 1990/05/24 13:24:06 wlott Exp $ -;;; -;;; This file contains the extra code necessary to feed an entire file of -;;; assembly code to the assembler. -;;; -(in-package "C") - - -(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 "mips-fasl")) - trace-file) - (let* ((*do-assembly* t) - (name (pathname name)) - (*lap-output-file* (open-fasl-file (pathname output-file) name)) - (*assembler-routines* nil) - (won nil)) - (unwind-protect - (let (*code-segment* - *elsewhere* - #-new-compiler (lisp::*in-compilation-unit* nil)) - (init-assembler) - (load (merge-pathnames name (make-pathname :type "lisp"))) - (fasl-dump-cold-load-form `(in-package ,(package-name *package*)) - *lap-output-file*) - (assemble (*code-segment* nil) - (insert-segment *elsewhere*)) - (let ((length (finalize-segment *code-segment*))) - (dump-assembler-routines *code-segment* - length - *assembler-routines* - *lap-output-file*)) - (when trace-file - (with-open-file (file (if (eq trace-file t) - (make-pathname :defaults name - :type "trace") - trace-file) - :direction :output - :if-exists :supersede) - (format file "Assembly listing for ~A:~3%" (namestring name)) - (dump-segment *code-segment* file) - (fresh-line file))) - (setq won t)) - (close-fasl-file *lap-output-file* (not won))) - won)) - - - -(defstruct (reg-spec - (:print-function %print-reg-spec)) - (kind :temp :type (member :arg :temp :result)) - (name nil :type symbol) - (temp nil :type symbol) - (sc nil :type symbol) - (offset 0 :type fixnum)) - -(defun %print-reg-spec (spec stream depth) - (declare (ignore depth)) - (format stream - "#<reg ~S ~S sc=~S offset=~S>" - (reg-spec-kind spec) - (reg-spec-name spec) - (reg-spec-sc spec) - (reg-spec-offset spec))) - - -(defun parse-reg-spec (kind name sc offset) - (let ((reg (make-reg-spec :kind kind :name name :sc sc :offset offset))) - (ecase kind - (:temp) - ((:arg :res) - (setf (reg-spec-temp reg) (make-symbol (symbol-name name))))) - reg)) - - -(defun emit-assemble (name regs code) - (let* ((labels nil) - (insts (mapcar #'(lambda (inst) - (cond ((symbolp inst) - (push inst labels) - `(emit-label ,inst)) - (t - inst))) - code))) - `(let ((,name (gen-label)) - ,@(mapcar #'(lambda (label) - `(,label (gen-label))) - labels)) - (push (cons ',name ,name) *assembler-routines*) - (assemble (*code-segment* ',name) - (emit-label ,name) - (let (,@(mapcar - #'(lambda (reg) - `(,(reg-spec-name reg) - (make-random-tn - :sc (sc-or-lose ',(reg-spec-sc reg)) - :offset ,(reg-spec-offset reg)))) - regs)) - ,@insts - (inst addu lip-tn lra-tn (- vm:word-bytes vm:other-pointer-type)) - (inst j lip-tn) - (inst nop))) - (format t "~S assembled~%" ',name)))) - -(defun arg-or-res-spec (reg) - `(,(reg-spec-name reg) - :scs (,(reg-spec-sc 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-pc-label (make-symbol "RETURN-PC-LABEL")) - (return-pc (make-symbol "RETURN-PC")) - (lip (make-symbol "LIP")) - (ndescr (make-symbol "NDESCR"))) - `(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) - (:temporary (:scs (interior-reg) :type interior - :from (:eval 0) :to (:eval 1)) - ,lip) - (:temporary (:sc any-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,return-pc) - (:temporary (:scs (non-descriptor-reg) :type random - :from (:eval 0) :to (:eval 1)) - ,ndescr) - ,@(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 ,lip ,@(mapcar #'reg-spec-name temps)) - ,@options - (:generator 247 - (let ((,return-pc-label (gen-label))) - ,@(mapcar #'(lambda (arg) - `(move ,(reg-spec-temp arg) - ,(reg-spec-name arg))) - args) - (inst compute-lra-from-code ,return-pc code-tn ,return-pc-label) - (inst li ,ndescr (make-fixup ',name :assembly-routine)) - (inst j ,ndescr) - (inst nop) - (emit-return-pc ,return-pc-label) - - ,@(mapcar #'(lambda (res) - `(move ,(reg-spec-name res) - ,(reg-spec-temp res))) - results)))))) - -(defmacro define-assembly-routine ((name options &rest vars) &rest code) - (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars))) - (if *do-assembly* - (emit-assemble (if (atom name) name (car name)) regs code) - (emit-vop name options regs)))) diff --git a/assembly/mips/array.lisp b/assembly/mips/array.lisp deleted file mode 100644 index cc0dc15f5b57af5a8dbaa5e3273424997b67fc0c..0000000000000000000000000000000000000000 --- a/assembly/mips/array.lisp +++ /dev/null @@ -1,300 +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/assembly/mips/array.lisp,v 1.8 1990/05/23 06:11:51 wlott Exp $ -;;; -;;; This file contains the support routines for arrays and vectors. -;;; -;;; Written by William Lott. -;;; -(in-package "C") - - -(eval-when (eval) - -(defmacro allocate-vector (type length words vector ndescr) - `(pseudo-atomic (,ndescr) - (inst or ,vector alloc-tn vm:other-pointer-type) - (inst addu alloc-tn alloc-tn (+ (1- (ash 1 vm:lowtag-bits)) - (* vm:vector-data-offset vm:word-bytes))) - (inst addu alloc-tn alloc-tn ,words) - (inst li ,ndescr (lognot vm:lowtag-mask)) - (inst and alloc-tn alloc-tn ,ndescr) - ,(if (constantp type) - `(inst li ,ndescr ,type) - `(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))) - -(defmacro maybe-invoke-gc (vector words) - "Assure that VECTOR lies entirely before the guard page. WORDS is the - number of words of data in the vector." - (declare (ignore vector words)) - nil) - -); eval-when (eval) - - -(define-assembly-routine (allocate-vector - () - (: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)) - (allocate-vector type length words vector ndescr) - (maybe-invoke-gc vector words) - (move result vector)) - - -(define-assembly-routine (alloc-g-vector - () - (:arg length any-reg a0-offset) - (:arg fill any-reg a1-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp vector descriptor-reg a3-offset)) - - (allocate-vector vm:simple-vector-type length length vector ndescr) - (inst beq length zero-tn done) - (inst addu lip vector (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - - loop - - (storew fill lip) - (inst addu length length (fixnum -1)) - (inst bne length zero-tn loop) - (inst addu lip lip vm:word-bytes) - - done - - (move result vector)) - - -(define-assembly-routine (alloc-string - () - (:arg length any-reg a0-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp words any-reg nl1-offset) - (:temp vector descriptor-reg a3-offset)) - ;; Note: When we calculate the number of words needed, we assure that there - ;; will be at least one extra byte available. This allows us to pass strings - ;; to C land without having to tack an extra null on the end ourselves. - ;; - ;; To do this quickly, we divide the length by the number of bytes and strip - ;; off the two fixnum lowtag bits, add 1 (binary 1, not fixnum 1), and - ;; shift back to a fixnum: - ;; - ;; length len>>4 1+ <<2 - ;; 0 0 1 4 - ;; 1 0 1 4 - ;; 3 0 1 4 - ;; 4 1 2 8 - ;; 7 1 2 8 - ;; 8 2 3 12 - ;; - (inst sra words length (+ vm:word-shift 2)) - (inst addu words words 1) - (inst sll words words 2) - (allocate-vector vm:simple-string-type length words vector ndescr) - (maybe-invoke-gc vector words) - (move result vector)) - - - - -;;;; Hash primitives - -(define-assembly-routine (sxhash-simple-string - () - (: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)) - (loadw length string vm:vector-length-slot vm:other-pointer-type) - (inst addu lip string - (- (* vm:vector-data-offset vm:word-bytes) vm: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)) - - -(define-assembly-routine (sxhash-simple-substring - () - (: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)) - (inst addu lip string - (- (* vm:vector-data-offset vm:word-bytes) vm: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)) - diff --git a/assembly/mips/assem-rtns.lisp b/assembly/mips/assem-rtns.lisp deleted file mode 100644 index aa8522d2a612ef3d208e6c3e80ce83bb0940628f..0000000000000000000000000000000000000000 --- a/assembly/mips/assem-rtns.lisp +++ /dev/null @@ -1,123 +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/assembly/mips/assem-rtns.lisp,v 1.11 1990/05/24 13:34:07 wlott Exp $ -;;; -;;; -(in-package "C") - - - -;;;; The undefined-function. - -;;; Just signal an undefined-symbol error. Note: this must look like a -;;; function, because it magically gets called in place of a function when -;;; there is no real function to call. - -(eval-when (eval) - -(define-assembly-routine (undefined-function - () - (:temp cname any-reg cname-offset) - (:temp lexenv any-reg lexenv-offset) - (:temp function any-reg code-offset) - (:temp nargs any-reg nargs-offset) - (:temp lip interior-reg lip-offset) - (:temp temp non-descriptor-reg nl0-offset)) - ;; Allocate function header. - (align vm:lowtag-bits) - (inst word vm:function-header-type) - (dotimes (i (1- vm:function-header-code-offset)) - (inst word 0)) - ;; Cause the error. - (cerror-call continue di:undefined-symbol-error cname) - - continue - - (let ((not-sym (generate-cerror-code di:object-not-symbol-error cname))) - (test-simple-type cname temp not-sym t vm:symbol-header-type)) - - (loadw lexenv cname vm:symbol-function-slot vm:other-pointer-type) - (loadw function lexenv vm:closure-function-slot vm:function-pointer-type) - (lisp-jump function lip)) - -); eval-when (eval) - - -;;;; Non-local exit noise. - - -(define-assembly-routine (unwind - () - (:arg block any-reg a0-offset) - (:arg start any-reg old-fp-offset) - (:arg count any-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 di: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 fp-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) - - 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 any-reg a0-offset) - (:arg start any-reg old-fp-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)) - - (load-symbol-value catch lisp::*current-catch-block*) - - loop - - (let ((error (generate-error-code di: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) - (inst b loop) - (loadw catch catch vm:catch-block-previous-catch-slot) - - exit - - (move target catch) - (inst li ndescr (make-fixup 'unwind :assembly-routine)) - (inst j ndescr) - (inst nop)) - - diff --git a/assembly/mips/bit-bash.lisp b/assembly/mips/bit-bash.lisp deleted file mode 100644 index 5bf9ca90bd23ff947baed3f3e2e210764e28fc3b..0000000000000000000000000000000000000000 --- a/assembly/mips/bit-bash.lisp +++ /dev/null @@ -1,326 +0,0 @@ -;;; -*- Log: code.log; Package: C -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Stuff to implement bit bashing. -;;; -;;; Written by William Lott. -;;; - -(in-package "C") - - -;;;; Blitting macros. Used only at assemble time. - -(eval-when (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))) - (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 nop) - - (narrow-copy) - - (emit-label wide-copy) - (wide-copy))) - -(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 () - '(let ((aligned (gen-label))) - (inst beq src-bit-offset dst-bit-offset aligned) - (inst nop) - - (macrolet - ((get-src () - '(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) - (inst or ntemp1 ntemp2)))) - ;; Possibly fix src if we need to get bits from the previous word. - (inst sltu ntemp1 src-bit-offset dst-bit-offset) - (inst sll ntemp1 2) - (inst subu src ntemp1) - - ;; Calc src-shift - (inst subu src-shift dst-offset src-offset) - (inst and src-shift (fixnum 31)) - - (wide-copy-aux) - (inst b done) - (inst nop)) - - (macrolet - ((get-src () - '(progn - (inst lw ntemp1 src) - (inst addu src 4)))) - (emit-label aligned) - (wide-copy-aux)))) - -(defmacro wide-copy-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) - (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 sll interior ntemp1 2) - - (inst beq interior check-right) - (inst nop) - - (emit-label loop) - (get-src) - (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) - (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 sw ntemp1 dst))) - -(defmacro check-for-interrupts () - nil) - -) ; eval-when (eval) - - - -;;;; The actual routines. - -(define-assembly-routine (copy-to-system-area - ((:policy :fast-safe) - (:translate copy-to-system-area)) - (: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 args-offset) - (:temp ntemp1 non-descriptor-reg nl1-offset) - (:temp ntemp2 non-descriptor-reg nl2-offset) - (:temp ntemp3 non-descriptor-reg nl3-offset)) - - (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) - -(define-assembly-routine (copy-from-system-area - ((:policy :fast-safe) - (:translate copy-from-system-area)) - (: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 args-offset) - (:temp ntemp1 non-descriptor-reg nl1-offset) - (:temp ntemp2 non-descriptor-reg nl2-offset) - (:temp ntemp3 non-descriptor-reg nl3-offset)) - (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) - -(define-assembly-routine (system-area-copy - ((:policy :fast-safe) - (:translate system-area-copy)) - (: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 args-offset) - (:temp ntemp1 non-descriptor-reg nl2-offset) - (:temp ntemp2 non-descriptor-reg nl3-offset) - (:temp ntemp3 non-descriptor-reg nl4-offset)) - (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 src-arg any-reg a0-offset) - (:arg src-offset any-reg a1-offset) - (:arg dst-arg any-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 args-offset) - (:temp ntemp1 non-descriptor-reg nl2-offset) - (:temp ntemp2 non-descriptor-reg nl3-offset) - (:temp ntemp3 non-descriptor-reg nl4-offset)) - (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-interrupt () - '(let ((label ((gen-label)))) - (inst and ntemp1 flags-tn (ash 1 interrupted-flag)) - (inst bne 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/clx/CHANGES b/clx/CHANGES deleted file mode 100644 index def19367324e301ea0b84dd9badb4a08bccf04a4..0000000000000000000000000000000000000000 --- a/clx/CHANGES +++ /dev/null @@ -1,51 +0,0 @@ -R4 changes: - -o Numerous bug fixes - -o Multiprocess locking and error reporting made more robust - -o Event queue consing reduced - -o ICCCM support - -R4.1 changes: - -o Fix reported bugs and to include the vendor-specific - bug-fixing and performance-improving patches that I recently received. - -o Code compiled with the R4 CLX will work with the R4.1X CLX, but code - compiled with the R4.1X CLX will NOT work with the R4 CLX. I made an effort - to ensure backward binary compatibility with R4 CLX so that old code doesn't - have to be recompiled to still work. It does have to be recompiled to fix - an event-queue bug, since the fix involved a change to the event-loop macro. - -R4.2 changes: - -o Atoms and visuals are now correctly maintained in a separate namespace from - windows, pixmaps, cursors, fonts, gcontexts, and colormaps. - -o I have made an attempt to make socket code work for kcl and ibcl. I have - akcl here, but not kcl and ibcl, so it's only guesswork that kcl and ibcl - works. - -o compile-clx and load-clx do more pathname merging to work around problems - in some lisp implementations. *default-pathname-defaults* is never bound - anymore. - -o Some ansi common lisp stuff. If you have :ansi-common-lisp on *features*, - CLX will: - - - Use the common-lisp package instead of the lisp package. - - - Use the common lisp condition system, being careful not to stomp on - define-condition and type-error. - - - Use declaim instead of proclaim. - - - Use the dynamic-extent declaration for rest args and closures. - - - Use print-unreadable-object. - -o Code compiled with the R4 and R4.1 CLX will work with the R4.2 CLX, provided - you don't have :ansi-common-lisp on your features list. Code compiled with - the R4.2 CLX will NOT work with the R4 CLX. diff --git a/clx/README b/clx/README deleted file mode 100644 index 61696276cfffe81b38f11fbbbaae63f084bf03fd..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 (xlib:compile-clx) function and loaded with the -(xlib: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 (xlib:compile-clx) function and loaded with the (xlib: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 59be1388c078e8fcf18d6b00316824128eb6d228..0000000000000000000000000000000000000000 --- a/clx/attributes.lisp +++ /dev/null @@ -1,671 +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) - -(export '( - with-state - window-visual-info - window-visual - window-class - window-background ;; setf only - window-border - 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-cursor - window-colormap-installed-p - window-all-event-masks - window-map-state - - drawable-root - drawable-x - drawable-y - drawable-width - drawable-height - drawable-depth - drawable-border-width - - window-priority - )) - -(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 (values resource-id)) - (with-attributes (window :sizes 32) - (resource-id-get 8))) - -(defun window-visual-info (window) - (declare (type window window)) - (declare (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (values boolean)) - (with-attributes (window :sizes 8) - (boolean-get 25))) - -(defun window-all-event-masks (window) - (declare (type window window)) - (declare (values mask32)) - (with-attributes (window :sizes 32) - (card32-get 32))) - -(defun window-map-state (window) - (declare (type window window)) - (declare (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 (values window)) - (with-geometry (drawable :sizes 32) - (window-get 8 (drawable-display drawable)))) - -(defun drawable-x (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (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 (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 (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 (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 (values card8)) - (with-geometry (drawable :sizes 8) - (card8-get 1))) - -(defun drawable-border-width (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (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 f77b310ad8bd865a5deb134849eccd0a4bfe8663..0000000000000000000000000000000000000000 --- a/clx/buffer.lisp +++ /dev/null @@ -1,1535 +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)) - #+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) - (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) - (array-register buffer-bbuf)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf) - (array-register buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf) - (array-register buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf) - (array-register 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))) - (macrolet ((%buffer-sizes () ',sizes)) - ,@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) - (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) - (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) - (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 (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 (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 (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) - (downward-funarg transform)) - (if transform - (flet ((card8->char->transform (v) - (declare (type card8 v)) - (funcall transform (card8->char v)))) - #+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) - (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) - (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 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)) - (buffer-replace data buffer-bbuf start (index+ start nitems) 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) - (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 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) - (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) - (downward-funarg transform)) - (if transform - (flet ((card8->int8->transform (v) - (declare (type card8 v)) - (funcall transform (card8->int8 v)))) - #+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) - (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 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) - (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 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 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) - (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 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) - (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) - (downward-funarg transform)) - (if transform - (flet ((card16->int16->transform (v) - (declare (type card16 v)) - (funcall transform (card16->int16 v)))) - #+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) - (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 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) - (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 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 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) - (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 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) - (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) - (downward-funarg transform)) - (if transform - (flet ((card32->int32->transform (v) - (declare (type card32 v)) - (funcall transform (card32->int32 v)))) - #+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) - (downward-funarg transform)) - (if transform - (flet ((transform->char->card8 (x) - (char->card8 (the character (funcall transform x))))) - #+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) - (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) - (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 (index+ index chunk))) - ((type array-index index)) - (buffer-replace buffer-bbuf data - buffer-boffset - (index+ buffer-boffset chunk) - index))) - 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) - (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) - (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) - (downward-funarg transform)) - (if transform - (flet ((transform->int8->card8 (x) - (int8->card8 (the int8 (funcall transform x))))) - #+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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (downward-funarg transform)) - (if transform - (flet ((transform->int32->card32 (x) - (int32->card32 (the int32 (funcall transform x))))) - #+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) - (array-register 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))) - ((= k 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)))))))) diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp deleted file mode 100644 index bb811edf72adc656e6929e66eded31a685099503..0000000000000000000000000000000000000000 --- a/clx/bufmac.lisp +++ /dev/null @@ -1,174 +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))) - -(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) - (array-register buffer-bbuf)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf) - (array-register buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf) - (array-register buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf) - (array-register 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))) - (macrolet ((%buffer-sizes () ',sizes)) - ,@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 4e7b7258a60daf57b826ec148a46e8a8f1211f96..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. - -(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 "clx:defsystem.fasl") -(xlib:compile-clx (pathname "clx:")) diff --git a/clx/clx.lisp b/clx/clx.lisp deleted file mode 100644 index c560354eaed20447f17c2847cf7393cdfbfdb82a..0000000000000000000000000000000000000000 --- a/clx/clx.lisp +++ /dev/null @@ -1,1104 +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) - -(export '( - *version* - card32 - card29 - int32 - card16 - int16 - card8 - int8 - rgb-val - angle - mask32 - mask16 - array-index - pixel - image-depth - display - display-p - display-host - display-display - display-after-function - display-protocol-major-version - display-protocol-minor-version - display-vendor-name - display-resource-id-base - display-resource-id-mask - display-xid - display-byte-order - display-release-number - display-max-request-length - display-default-screen - display-nscreens - display-roots - display-motion-buffer-size - display-xdefaults - display-image-lsb-first-p - display-bitmap-format - display-pixmap-formats - display-min-keycode - display-max-keycode - display-error-handler - display-authorization-name - display-authorization-data - display-plist - display-report-asynchronous-errors - color - color-p - color-red - color-green - color-blue - make-color - color-rgb - resource-id - drawable - drawable-p - drawable-equal - drawable-id - drawable-display - drawable-plist - window - window-p - window-equal - window-id - window-display - window-plist - pixmap - pixmap-p - pixmap-equal - pixmap-id - pixmap-display - pixmap-plist - colormap - colormap-p - colormap-equal - colormap-id - colormap-display - colormap-visual-info - cursor - cursor-p - cursor-equal - cursor-id - cursor-display - xatom - stringable - fontable - timestamp - bit-gravity - win-gravity - grab-status - boolean - alist - repeat-seq - point-seq - seg-seq - rect-seq - arc-seq - gcontext - gcontext-p - gcontext-equal - gcontext-id - gcontext-display - gcontext-plist - event-mask-class - event-mask - pointer-event-mask-class - pointer-event-mask - device-event-mask-class - device-event-mask - modifier-key - modifier-mask - state-mask-key - gcontext-key - event-key - error-key - draw-direction - boole-constant - bitmap-format - bitmap-format-p - bitmap-format-unit - bitmap-format-pad - bitmap-format-lsb-first-p - pixmap-format - pixmap-format-p - pixmap-format-depth - pixmap-format-bits-per-pixel - pixmap-format-scanline-pad - visual-info - visual-info-p - visual-info-id - visual-info-display - visual-info-class - visual-info-red-mask - visual-info-green-mask - visual-info-blue-mask - visual-info-bits-per-rgb - visual-info-colormap-entries - visual-info-plist - screen - screen-p - screen-root - screen-width - screen-height - screen-width-in-millimeters - screen-height-in-millimeters - screen-depths - screen-root-depth - screen-root-visual-info - screen-root-visual - screen-default-colormap - screen-white-pixel - screen-black-pixel - screen-min-installed-maps - screen-max-installed-maps - screen-backing-stores - screen-save-unders-p - screen-event-mask-at-open - screen-plist - font - font-p - font-equal - font-id - font-display - 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 - font-plist - char-left-bearing - max-char-left-bearing - min-char-left-bearing - char-right-bearing - max-char-right-bearing - min-char-right-bearing - char-width - max-char-width - min-char-width - char-ascent - max-char-ascent - min-char-ascent - char-descent - max-char-descent - min-char-descent - char-attributes - max-char-attributes - min-char-attributes - make-event-mask - make-event-keys - make-state-mask - make-state-keys - )) - -(pushnew :clx *features*) -(pushnew :xlib *features*) - -(defparameter *version* "MIT R4.2") -(pushnew :clx-mit-r4 *features*) - -(defparameter *protocol-major-version* 11.) -(defparameter *protocol-minor-version* 0) - -(defparameter *x-tcp-port* 6000) ;; add display number - -; Note: various perversions of the CL type system are used below. -; Examples: (list elt-type) (sequence elt-type) - -;; 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) -; (values <mumble>))) - -;(defun <mumble>-display (<mumble>) -; (declare (type <mumble> <mumble>) -; (values display))) - -;(defun <mumble>-id (<mumble>) -; (declare (type <mumble> <mumble>) -; (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) -; (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)) - -(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))))) - -; 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) - (princ " " stream) - (prin1 (color-green color) stream) - (princ " " 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 (values color)) - (make-color-internal red green blue)) - -(defun color-rgb (color) - (declare (type color color)) - (declare (values red green blue)) - (values (color-red color) (color-green color) (color-blue color))) - -(def-clx-class (bitmap-format (:copier nil)) - (unit 8 :type (member 8 16 32)) - (pad 8 :type (member 8 16 32)) - (lsb-first-p nil :type boolean)) - -(def-clx-class (pixmap-format (:copier nil)) - (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))) - -(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 #'eq :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) ; 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 (display stream depth) - (declare (type display display) - (ignore depth)) - (print-unreadable-object (display stream :type t) - (princ (display-host display) stream) - (princ ":" stream) - (princ (display-display display) stream) - (princ " (" stream) - (princ (display-vendor-name display) stream) - (princ " R" stream) - (prin1 (display-release-number display) stream) - (princ ")" 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) - (princ (display-host (drawable-display drawable)) stream) - (princ ":" stream) - (princ (display-display (drawable-display drawable)) stream) - (princ " " 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) - (princ "-bit " stream) - (princ (visual-info-class visual-info) stream) - (princ " " stream) - (princ (display-host (visual-info-display visual-info)) stream) - (princ ":" stream) - (princ (display-display (visual-info-display visual-info)) stream) - (princ " " 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) - (princ " " stream)) - (princ (display-host (colormap-display colormap)) stream) - (princ ":" stream) - (princ (display-display (colormap-display colormap)) stream) - (princ " " 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) - (princ (display-host (cursor-display cursor)) stream) - (princ ":" stream) - (princ (display-display (cursor-display cursor)) stream) - (princ " " 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) - -; 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) - (princ (display-host (gcontext-display gcontext)) stream) - (princ ":" stream) - (princ (display-display (gcontext-display gcontext)) stream) - (princ " " 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 list)) ;; (OR integer (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 list)) ;; '(or integer (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 list)) ;; '(or integer (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 list)) ;; '(or (member :any) integer (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) ((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)))) - (princ (display-host display) stream) - (princ ":" stream) - (princ (display-display display) stream) - (princ "." stream) - (princ (position screen (display-roots display)) stream)) - (princ " " stream) - (prin1 (screen-width screen) stream) - (princ "x" stream) - (prin1 (screen-height screen) stream) - (princ "x" stream) - (prin1 (screen-root-depth screen) stream) - (when (screen-root-visual-info screen) - (princ " " stream) - (princ (visual-info-class (screen-root-visual-info screen)) stream)))) - -(defun screen-root-visual (screen) - (declare (type screen screen) - (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) - (princ "(gcontext)" stream)) - (princ " " stream) - (princ (display-host (font-display font)) stream) - (princ ":" stream) - (princ (display-display (font-display font)) stream) - (when (font-id-internal font) - (princ " " 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) -; (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 (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 (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 (values (or mask32 nil))) - (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 (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 (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 list keys)) ;; (list event-mask-class) - (declare (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 (values (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 (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)) ;; (list state-mask-key) - (declare (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 list) state-mask)) ;; (list state-mask-key) - (declare (values mask16)) - (or (encode-mask *state-mask-vector* state-mask 'state-mask-key) - (x-type-error state-mask '(or mask16 (list state-mask-key))))) - -(defun make-state-mask (&rest keys) - ;; Useful for constructing modifier-mask, state-mask. - (declare (type list keys)) ;; (list state-mask-key) - (declare (values mask16)) - (encode-mask *state-mask-vector* keys 'state-mask-key)) - -(defun make-state-keys (state-mask) - (declare (type mask16 state-mask)) - (declare (values (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 (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/defsystem.lisp b/clx/defsystem.lisp deleted file mode 100644 index 8c90d7be654d3cb9de9fa04bea2b7933faaad38e..0000000000000000000000000000000000000000 --- a/clx/defsystem.lisp +++ /dev/null @@ -1,623 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;;; -;;; 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. -;;; - -;;; #+ features used in this file -;;; ansi-common-lisp -;;; lispm -;;; genera -;;; lucid -;;; lcl3.0 -;;; apollo -;;; kcl -;;; ibcl -;;; excl -;;; CMU -;;; - -#-ansi-common-lisp -(lisp:in-package :xlib :use '(:lisp)) - -#+ansi-common-lisp -(common-lisp:in-package :common-lisp-user) - -#+ansi-common-lisp -(common-lisp:defpackage xlib - (:use common-lisp) - (:size 3000) - #+Genera - (:import-from - (system - arglist downward-funarg array-register) - (zwei - indentation)) - (: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-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 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-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)) - -#+ansi-common-lisp -(common-lisp:in-package :xlib) - -#-lispm -(export '( - compile-clx - load-clx)) - -#+excl (error "Use excldefsys") - - -;;;; Lisp Machines - -;;; Lisp machines have their own defsystems, so we use them to define -;;; the CLX load. - -#+(and lispm (not genera)) -(global:defsystem CLX - (:pathname-default "clx:clx;") - (:patchable "clx:patch;" clx-ti) - (:initial-status :experimental) - - (: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 depdefs) - (:compile-load clx - (:fasload depdefs)) - (:compile-load dependent - (:fasload depdefs clx)) - ;; Macros only needed for compilation - (:skip :compile-load macros - (:fasload depdefs clx dependent)) - ;; Bufmac only needed for compilation - (:skip :compile-load bufmac - (:fasload depdefs clx dependent macros)) - (:compile-load buffer - (:fasload depdefs clx dependent macros bufmac)) - (:compile-load display - (:fasload depdefs clx dependent macros bufmac buffer)) - (:compile-load gcontext - (:fasload depdefs clx dependent macros bufmac buffer display)) - (:compile-load input - (:fasload depdefs clx dependent macros bufmac buffer display)) - (:compile-load requests - (:fasload depdefs clx dependent macros bufmac buffer display input)) - (:compile-load fonts - (:fasload depdefs clx dependent macros bufmac buffer display)) - (:compile-load graphics - (:fasload depdefs clx dependent macros fonts bufmac buffer display fonts)) - (:compile-load text - (:fasload depdefs clx dependent macros fonts bufmac buffer display gcontext fonts)) - (:compile-load-init attributes - (dependent) ;<- There may be other modules needed here. - (:fasload depdefs clx dependent macros bufmac buffer display)) - (:compile-load translate - (:fasload depdefs clx dependent macros bufmac buffer display)) - (:compile-load keysyms - (:fasload depdefs clx dependent macros bufmac buffer display translate)) - (:compile-load manager - (:fasload depdefs clx dependent macros bufmac buffer display)) - (:compile-load image - (:fasload depdefs clx dependent macros bufmac buffer display)) - (:compile-load resource) - (:auxiliary doc) - ) - - -#+Genera -(scl:defsystem CLX - (:default-pathname "SYS:X11;CLX;" - :default-package "XLIB" - :pretty-name "CLX" - :maintaining-sites (:scrc) - :distribute-sources t - :distribute-binaries t - :source-category :basic) - (:module doc ("doc") - (:type :lisp-example)) - (:module depdefs ("depdefs" "generalock")) - (:module clx ("clx") - (:uses-definitions-from depdefs)) - (:module dependent ("dependent") - (:uses-definitions-from clx)) - (:module macros ("macros") - (:uses-definitions-from dependent)) - (:module bufmac ("bufmac") - (:uses-definitions-from dependent macros)) - (:module buffer ("buffer") - (:uses-definitions-from dependent macros bufmac)) - (:module display ("display") - (:uses-definitions-from dependent macros bufmac buffer)) - (:module gcontext ("gcontext") - (:uses-definitions-from dependent macros bufmac display)) - (:module input ("input") - (:uses-definitions-from dependent macros bufmac display)) - (:module requests ("requests") - (:uses-definitions-from dependent macros bufmac display input)) - (:module fonts ("fonts") - (:uses-definitions-from dependent macros bufmac display)) - (:module graphics ("graphics") - (:uses-definitions-from dependent macros bufmac fonts)) - (:module text ("text") - (:uses-definitions-from dependent macros bufmac gcontext fonts)) - (:module attributes ("attributes") - (:uses-definitions-from dependent macros bufmac display)) - (:module translate ("translate") - (:uses-definitions-from dependent macros bufmac display)) - (:module keysyms ("keysyms") - (:uses-definitions-from translate)) - (:module manager ("manager") - (:uses-definitions-from dependent macros bufmac display)) - (:module image ("image") - (:uses-definitions-from dependent macros bufmac display)) - (:module resource ("resource")) - ) - - -;;;; Non Lisp Machines - -#+lucid -(defvar *foreign-libraries* '("-lc")) ; '("-lresolv" "-lc") for some sites - -#+lucid -(defun clx-foreign-files (binary-path) - - ;; apply a patch to 2.0 systems - #+(and (not lcl3.0) (or mc68000 mc68020)) - (load (merge-pathnames "make-sequence-patch" binary-path)) - - ;; Link lisp to the C function connect_to_server - #+(and apollo (not lcl3.0)) - (lucid::define-foreign-function '(xlib::connect-to-server "connect_to_server") - '((:val host :string) - (:val display :integer32)) - :integer32) - #+(and (not apollo) (not lcl3.0)) - (lucid::define-c-function xlib::connect-to-server - (host display) - :result-type :integer) - #+lcl3.0 - (lucid::def-foreign-function (xlib::connect-to-server - (:language :c) - (:return-type :signed-32bit)) - (host :simple-string) (display :signed-32bit)) - (unintern 'display) - - ;; Load the definition of connect_to_server - #+apollo - (lucid::load-foreign-file (merge-pathnames "socket" binary-path) - :preserve-pathname t) - #-apollo - (lucid::load-foreign-files (list (merge-pathnames "socket.o" binary-path)) - *foreign-libraries*)) - - -;;; 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 -(defun clx-foreign-files () - (ext:def-c-type c-string (ext::null-terminated-string 256)) - (ext:def-c-pointer *c-string c-string) - (ext:def-c-routine ("connect_to_server" xlib::connect-to-server) (ext:int) - (host *c-string) - (port ext:int))) - - -;; socket interface for kcl and ibcl -;; defines the function (open-socket-stream host display) -;; -;; You must first compile file socket.c -#+(or kcl ibcl) -(defun kcl-socket-init (binary-path) - (let ((sockcl (namestring (merge-pathnames "sockcl.o" binary-path))) - (socket (namestring (merge-pathnames "socket.o" binary-path)))) - (si:faslink sockcl (format nil "~a -lc" socket)) - )) - - -;;;; 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/hp9000 -;;; must uudecode the file make-sequence-patch.uu - -#-lispm -(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))) - - ;; 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 - #-pqc - (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)))) - - (flet ((compile-and-load (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 #+CMU :error-file #+CMU nil) - (compile-file source :output-file binary - #+CMU :error-file #+CMU nil)) - (load binary)))) - - ;; Now compile and load all the files. - ;; Defer compiler warnings until everything's compiled, if possible. - (#.(if (fboundp 'with-compilation-unit) - 'with-compilation-unit - #+lcl3.0 'lucid::with-deferred-warnings - #-lcl3.0 'progn) - () - - #+lucid - (progn - (when compile-c ; compile the C files - #+(and (not lcl3.0) (or mc68000 mc68020)) - (progn ; sequence patch - (format t "You may need to uudecode ms-patch.uu and copy~%") - (format t "the result to the binary directory.~%") - (format t "You also must rename the file to have the canonical~%") - (format t "binary file type in order for lisp to realize it's a~%") - (format t "binary file.~%")) - ;; compile socket.c - (let* ((src (merge-pathnames "socket.c" source-path)) - (obj (merge-pathnames "socket.o" binary-path)) - (args (list "-c" (namestring src) - "-o" (namestring obj) - "-DUNIXCONN"))) - (format t ";;; cc~{ ~a~}~%" args) - (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)) - (if (/= 0 exitstatus) - (error "Exit status of socket.c compile is ~d" exitstatus))))) - (format t ";;; Loading foreign files~%") - (clx-foreign-files binary-path)) - - #+(or kcl ibcl) - (progn - (when compile-c ; compile the C files - (let* ((src (merge-pathnames "socket.c" source-path)) - (obj (merge-pathnames "socket.o" binary-path)) - (arg (format nil "cc -c ~a -o ~a -DUNIXCONN" - (namestring src) - (namestring obj)))) - (format t ";;; ~a~%" arg) - (if (/= 0 (system arg)) - (error "bad exit status for ~s" src)))) - ;; compile the lisp interface to the c code - (let ((src (merge-pathnames "sockcl" source-path)) - (obj (merge-pathnames "sockcl.o" binary-path))) - (compile-file src :output-file obj)) - (kcl-socket-init binary-path)) - - (compile-and-load "depdefs") - (compile-and-load "clx") - (compile-and-load "dependent") - (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>) - -#-lispm -(defun load-clx (&optional (binary-pathname-defaults "") - &key (macros-p 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))) - - (flet ((load-binary (filename) - (let ((binary (merge-pathnames filename binary-path))) - (load binary)))) - - #+lucid - (clx-foreign-files binary-path) - - #+CMU - (clx-foreign-files) - - #+(or kcl ibcl) - (kcl-socket-init binary-path) - - (load-binary "depdefs") - (load-binary "clx") - (load-binary "dependent") - (when macros-p - (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 3e85d08c5dcc3389ebc1cbe1405f21b8ec01810f..0000000000000000000000000000000000000000 --- a/clx/depdefs.lisp +++ /dev/null @@ -1,663 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; 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) -(shadow 'rational) - -#+(or kcl ibcl) -(progn - (defun rational (x) - (if (rationalp x) - x - (lisp:rational x))) - (deftype rational () 'lisp:rational)) - -;;; DECLAIM - -#-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)))) - -;;; VALUES value1 value2 ... -- Documents the values returned by the function. - -#-lispm -(declaim (declaration values)) - -;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides -;;; the documentation that might get generated by the real arglist of the -;;; function. - -#+lispm -(import '(sys:arglist)) - -#+lcl3.0 -(import '(lcl:arglist)) - -#-(or lispm lcl3.0) -(declaim (declaration arglist)) - -;;; DOWNWARD-FUNARG name1 name2 ... -- Tells callers of this function that -;;; closures passed in as the argument named by name can be consed on the -;;; stack, as they have dynamic extent. In Genera keyword args can't be named -;;; this way. Instead use * to specify all functional args have dynamic -;;; extent. - -#+lispm -(import '(sys:downward-funarg)) - -#-lispm -(declaim (declaration downward-funarg)) - -;;; 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. - -#+lcl3.0 -(import '(lcl:dynamic-extent)) - -#-(or ansi-common-lisp lcl3.0) -(declaim (declaration dynamic-extent)) - -;;; ARRAY-REGISTER var1 var2 ... -- The variables mentioned are locals (not -;;; args) that hold vectors. - -#+Genera -(import '(sys:array-register)) - -#-Genera -(declaim (declaration array-register)) - -;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to -;;; indent calls to the function or macro containing the declaration. - -#+genera -(import '(zwei:indentation)) - -#-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) - (array-register ,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 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) -(eval-when (eval compile load) - (pushnew :clx-little-endian *features*)) - -#+lcl3.0 -(eval-when (compile eval load) - (ecase lucid::machine-endian - (:big) - (:little (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) - (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. - -(defmacro def-clx-class ((name &rest options) &body slots) - (let ((clos-package (or (find-package 'clos) - (find-package 'pcl) - (let ((lisp-pkg (find-package 'lisp))) - (and (find-symbol (string 'defclass) lisp-pkg) - lisp-pkg))))) - (if clos-package - (let ((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: - - ,(cond (clos-package - `(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 - `(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))))) - - #+Genera - (t - `(within-definition (,name def-clx-class) - (flavor:defflavor ,name - (,@(map 'list - #'(lambda (slot-name slot-initform) - `(,slot-name ,slot-initform)) - slot-names slot-initforms)) - ,(and include `(,include)) - :initable-instance-variables - :locatable-instance-variables - :readable-instance-variables - :writable-instance-variables - ,(if constructor - `(:constructor ,constructor - ,(if (eq constructor-args t) - `(&key ,@slot-names) - constructor-args)) - :abstract-flavor)) - ,(when predicate - `(defun ,predicate (object) - (typep object ',name))) - ,(when copier - (error ":COPIER not supported.")) - ,(when print-function - `(flavor:defmethod (sys:print-self ,name) - (stream depth *print-escape*) - (,print-function sys:self stream depth))) - (flavor:compile-flavor-methods ,name)))))))) - `(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) - ;; - ;; This is an alien array. We use it for, somewhat unnecessarily, to have - ;; interior pointers into it when calling UNIX-READ. - #+:CMU - (internal-buffer nil) - ;; - ;; How much of the internal-buffer have we filled so far. - #+:CMU - (internal-buffer-length 0) - - #+Genera (debug-io nil :type (or null stream)) - ) - -;;----------------------------------------------------------------------------- -;; Printing routines. -;;----------------------------------------------------------------------------- - -#+(and (not ansi-common-lisp) Genera) -(import 'future-common-lisp:print-unreadable-object) - -#-(or ansi-common-lisp Genera) -(defun print-unreadable-object-function (object stream type identity 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 ansi-common-lisp Genera) -(defmacro print-unreadable-object - ((object stream &key type identity) &body body) - `(print-unreadable-object-function - ,object ,stream ,type ,identity - ,(and body `#'(lambda () ,@body)))) - - -;;----------------------------------------------------------------------------- -;; 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) diff --git a/clx/dependent.lisp b/clx/dependent.lisp deleted file mode 100644 index fd61272a9517cdcc53db9891ce416f146848aed5..0000000000000000000000000000000000000000 --- a/clx/dependent.lisp +++ /dev/null @@ -1,3307 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;; 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) - -#+lcl3.0 -(import '( - lcl:define-condition - lcl:type-error - lucid::type-error-datum - lucid::type-error-expected-type - sys:underlying-simple-vector)) - -(export '( - char->card8 - card8->char - default-error-handler - #-(ansi-common-lisp CMU) define-condition)) - -#+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* 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 (values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - -(defun int8->card8 (x) - (declare (type int8 x)) - (declare (values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - -(defun card16->int16 (x) - (declare (type card16 x)) - (declare (values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - -(defun int16->card16 (x) - (declare (type int16 x)) - (declare (values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - -(defun card32->int32 (x) - (declare (type card32 x)) - (declare (values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - -(defun int32->card32 (x) - (declare (type int32 x)) - (declare (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) -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (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 (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)) - -) - -#+lcl3.0 ;in lcl2.1 these symbols are in different packages and making too - ;many conditionalizations makes my brain hurt. -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (values card8)) - #.(declare-buffun) - (the card8 (sys: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 (sys:svref-8bit a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (values int8)) - #.(declare-buffun) - (the int8 (sys: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 (sys:svref-signed-8bit a i) v)) - -) - -#+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-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (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 (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 (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 (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) - ;; Do I need to mask off a few bits here? XXX - (declare (type buffer-bytes a) - (type array-index i)) - (declare (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 ;; all these lucid optimizations need to be compiled to work. - -(defun aref-card16 (a i) - #.(declare-buffun) - (the card16 (sys:svref-16bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -1)))) - -(defun aset-card16 (v a i) - #.(declare-buffun) - (setf (sys:svref-16bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -1)) - (the card16 v))) - -(defun aref-int16 (a i) - #.(declare-buffun) - (the int16 - (sys:svref-signed-16bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -1)))) - -(defun aset-int16 (v a i) - #.(declare-buffun) - (setf (sys:svref-signed-16bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -1)) - (the int16 v))) - -(defun aref-card32 (a i) - #.(declare-buffun) - (the card32 - (sys:svref-32bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -2)))) - -(defun aset-card32 (v a i) - #.(declare-buffun) - (setf (sys:svref-32bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -2)) - (the card32 v))) - -(defun aref-int32 (a i) - #.(declare-buffun) - (the int32 - (sys:svref-signed-32bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -2)))) - -(defun aset-int32 (v a i) - #.(declare-buffun) - (setf (sys:svref-signed-32bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -2)) - (the int32 v))) - -(defun aref-card29 (a i) - ;; Don't need to mask bits here since X protocol guarantees top bits zero - #.(declare-buffun) - (the card29 - (sys:svref-32bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -2)))) - -(defun aset-card29 (v a i) - ;; I also assume here Lisp is passing a number that fits in 29 bits. - #.(declare-buffun) - (setf (sys:svref-32bit (the buffer-bytes a) - (lucid:ash& (the array-index i) -2)) - (the card29 v))) -) - - - -#-(or excl lcl3.0 clx-overlapping-arrays) -(progn - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (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 (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 (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 (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 (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 (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 (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 (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 (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-string 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 string-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 string-char - (aref (the simple-string *card8-to-char-translation-table*) - 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)) - ) - (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))) - (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 string-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the string-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) -(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)) - -;;; 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 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*))))) - ,@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)))) - (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.))))) - - -;;; 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) -(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) - (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) - (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)) - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -#-(or excl Genera) -(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)) - -;;; 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) -(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*) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. - -#-(or lispm excl lcl3.0) -(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)) - -;;; 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 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)) - -;;; 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)) - server-fd)) - - -;;; 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 number) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (or (cond ((null stream)) - ((funcall stream :listen) nil) - ((eql 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 number) 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) - ((eql timeout 0) :timeout) - ((buffer-input-wait-default display timeout))) - (fd-read-bytes fd vector start howmany)))) - - -#+lcl3.0 -(defmacro extract-underlying-stream (stream display direction) - ;;;Our job is to quickly get at the underlying stream for this display's - ;;;input stream structure. - `(or (getf (display-plist ,display) ,direction) - (setf (getf (display-plist ,display) ,direction) - (lucid::underlying-stream - ,stream (if (eq ,direction 'input) :input :output))))) - -#+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 do*. - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null number) timeout) - (optimize (speed 3) - (safety 0))) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - ((buffer-input-wait-default display timeout))) - (let ((stream (extract-underlying-stream stream display 'input))) - (do* ((index start (index1+ index))) - ((index>= index end) nil) - (declare (type array-index index)) - (let ((c (lcl:fast-read-byte stream (unsigned-byte 8) nil nil))) - (declare (type (or null card8) c)) - (if (null c) - (return t) - (setf (aref vector index) (the card8 c))))))))) - -;;; -;;; BUFFER-READ-DEFAULT for CMU Common Lisp. -;;; - -;;; Jim Healy comments: -;;; -;;; I don't know if all this buffering is necessary, but I think that other CLX -;;; code and buffer-read-default should be redefined so that it can return the -;;; actual number read. Then we could read into the passed array directly -;;; without fear (assuming the higher-level routines are used appropriately). -;;; Although I guess there wouldn't be a problem if BSD 4.3 let you see how -;;; many characters were on a socket without reading. -;;; -;;; I believe that the vector we write into expects numbers for the bytes. -;;; -;;; The BUFFER defstruct in depdefs.lisp was changed to include an internal -;;; buffer. (used here only). It's not circular; byte 0 is in byte 0. -;;; -;;; Timeout, when non-nil, is in seconds. (can it be a float?) Null timeout -;;; means don't come back until you're done. Returns non-nil if EOF -;;; encountered Returns :TIMEOUT when timeout exceeeded. - -;;; Bill Chiles comments: -;;; -;;; I think we can do away with the alien stuff and read into an array of -;;; unsigned-byte eight. We might even be able to read directly into the -;;; CLX buffer. I don't know why Healy is going to all this trouble, but -;;; I'll save worrying about this until we get this stuff up under the new -;;; compiler. -;;; - -#+CMU -(extensions::def-c-array clx-buff (unsigned-byte 8)) - -#+CMU -(defun buffer-to-byte-array (display array start length) - (system::alien-bind ((buffer (display-internal-buffer display) clx-buff t)) - (let ((ilength (display-internal-buffer-length display))) - (dotimes (i length) - (setf (aref (the buffer-bytes array) (+ i start)) - (system::alien-access (clx-buff-ref (system::alien-value buffer) - i)))) - (setf (display-internal-buffer-length display) - (- ilength length)) - (dotimes (i (- ilength length)) - (setf (system::alien-access (clx-buff-ref (system::alien-value buffer) - (+ i length))) - (system::alien-access (clx-buff-ref (system::alien-value buffer) - i))))))) -#+CMU -(defun verify-internal-buffer-size (display size) - (let ((length (display-internal-buffer-length display)) - (buffer (display-internal-buffer display))) - (cond ((null buffer) - (setf (display-internal-buffer display) - (setq buffer (make-clx-buff (max size 4096))))) - ((< (system::alien-size buffer) size) - (system::alien-bind ((new (make-clx-buff size) clx-buff t) - (buffer buffer clx-buff)) - (dotimes (i length) - (setf (system::alien-access - (clx-buff-ref (system::alien-value new) i)) - (system::alien-access - (clx-buff-ref (system::alien-value buffer) i)))) - (system:dispose-alien buffer) - (setf (display-internal-buffer display) - (system::alien-value new))))))) - -#+CMU -(defun read-into-ibuff (display number) - (lisp::alien-bind ((ibuff (display-internal-buffer display) clx-buff t)) - (let ((ilength (display-internal-buffer-length display))) - (multiple-value-bind (length err) - (mach:unix-read (display-input-stream display) - (system::alien-sap - (clx-buff-ref (system::alien-value ibuff) ilength)) - number) - (when length - (setf (display-internal-buffer-length display) - (setq ilength (+ ilength length)))) - (values length err))))) - -#+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 number) timeout)) - #.(declare-buffun) - (let* ((fd (display-input-stream display)) - (wanted (- end start))) - (verify-internal-buffer-size display wanted) - (let ((saved (display-internal-buffer-length display))) - (when (>= saved wanted) - (buffer-to-byte-array display vector start wanted) - (return-from buffer-read-default nil)) - (let ((endtime (when (and timeout (not (zerop timeout))) - (+ (get-internal-real-time) - (truncate (* timeout - internal-time-units-per-second))))) - (needed (- wanted saved))) - (loop - (let ((available-p - (cond ((and timeout (zerop timeout)) - (mach::unix-select (1+ fd) (ash 1 fd) 0 0 0)) - (timeout - (let ((remaining (- endtime (get-internal-real-time)))) - (when (minusp remaining) (return :TIMEOUT)) - (multiple-value-bind (secs rem) - (truncate remaining - internal-time-units-per-second) - (let ((msecs (truncate (* 1000000 rem)))) - (mach::unix-select (1+ fd) (ash 1 fd) 0 0 - secs msecs))))) - (t (mach::unix-select (1+ fd) (ash 1 fd) 0 0 nil))))) - - (when (not (zerop available-p)) - (multiple-value-bind (length err) (read-into-ibuff display needed) - (cond ((null length) - (error "CLX read err: ~A" (mach:get-unix-error-msg err))) - ((zerop length) - (return :EOF)) - (t (cond ((= length needed) - (buffer-to-byte-array display vector - start wanted) - (return nil)) - (t (setq needed (- needed length)))))))) - (when (and timeout (zerop timeout)) - (return :timeout)))))))) - - - -;;; 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 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 (rational 0 *) (float 0.0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((eql 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 inhibit scheduling here because there seem to be races in Lucid's - ;;multitasking implementation. Anyway, when we take it out we get bugs! - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (optimize (:tail-merge nil) - (speed 3) - (safety 0))) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (let ((stream (extract-underlying-stream stream display 'output))) - (lcl:with-scheduling-inhibited - (lcl:write-array stream vector start end)))))) - -;;; 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 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)))))) - -#+CMU -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (multiple-value-bind (length error-number) - (mach:unix-write (display-output-stream display) - vector start end) - (cond ((null length) - ;; This error possibly should go through the CLX error system. - (error "Can't write to server: ~A" - (mach:get-unix-error-msg error-number))) - (t nil)))) - - -;;; 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))) - -#+CMU -(defun buffer-force-output-default (display) - (declare (type display display)) - (mach:unix-ioctl (display-output-stream display) mach:tiocflush 0)) - -#-(or excl CMU) -(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))) - -#+CMU -(defun buffer-close-default (display &key abort) - (declare (type display display) (ignore abort)) - #.(declare-buffun) - (mach:unix-ioctl (display-output-stream display) mach:tiocflush 0) - (mach:unix-close (display-output-stream display))) - -#-(or excl CMU) -(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 number) timeout)) - (declare (values timeout)) - - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((eql 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 number) timeout)) - (declare (values timeout)) - (let ((fd (display-input-stream display))) - (cond ((null fd)) - ((or (null timeout) (= timeout 0)) - (if (zerop (mach::unix-select (1+ fd) (ash 1 fd) 0 0 timeout)) - :timeout - nil)) - (t - (multiple-value-bind (secs rem) (truncate timeout) - (let ((usecs (truncate (* 1000000 rem)))) - (if (zerop (mach::unix-select (1+ fd) (ash 1 fd) 0 0 secs usecs)) - :timeout - nil))))))) - -#+Genera -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null number) timeout)) - (declare (values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((scl:send stream :listen) nil) - ((eql 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 number) timeout)) - (declare (values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((zl:send stream :listen) nil) - ((eql 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* "blocked on read 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 number) timeout)) - (declare (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 (zerop timeout)) - ;; 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 number) timeout) - (optimize (speed 3) (safety 0))) - (declare (values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - ((let ((stream (extract-underlying-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. -#-(or excl CMU) -(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)))) - -#+CMU -(defun buffer-listen-default (display) - (declare (type display display)) - (not (buffer-input-wait-default display 0))) - -#+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) - `(sys:with-stack-list (,var ,@elements) ,@body)) - -#+lispm -(defmacro with-stack-list* ((var &rest elements) &body body) - `(sys:with-stack-list* (,var ,@elements) ,@body)) - -#-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))) ,@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))) ,@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)) - - (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)))))) - -#+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 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?* #+Genera nil #-Genera 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. - -(defmacro type? (object type) - (if (not (constantp type)) - `(typep ,object ,type) - (progn - (setq type (eval type)) - #+(or Genera explorer) - (if *type-check?* - `(locally (declare (optimize safety)) (typep ,object ',type)) - `(typep ,object ',type)) - #-(or Genera explorer) - (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 - :error-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 ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (apply #'sys:signal condition keyargs)) - -#+(and lispm (not Genera) (not 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 ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition keyargs)) - -#+(and Genera (not 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 ansi-common-lisp excl lcl3.0) -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -#+(or ansi-common-lisp excl lcl3.0) -(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))) - #|This condition no longer exists. - (when (eq condition 'server-disconnect) - (let ((disp (server-disconnect-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp)))|# - (when (eq condition 'closed-display) - (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) - (error condx))) - -#+CMU -(defun x-cerror (proceed-format-string condition &rest keyargs) - (apply #'cerror proceed-format-string condition keyargs)) - - -#-(or lispm 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 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) - -#+(and lispm (not ansi-common-lisp)) -(defmacro define-condition (name parents &body options) - (let ((slots (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 ,slots ,parents - :initable-instance-variables - #-Genera - (:accessor-prefix ,conc-name) - #+Genera - (:conc-name ,conc-name) - #-Genera - (:outside-accessible-instance-variables ,@slots) - #+Genera - (:readable-instance-variables ,@slots)) - ,(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 ansi-common-lisp)) -(zl:defflavor x-error () (global:error)) - -#+(and Genera (not 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 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 ansi-common-lisp)) -(scl:defmethod (dbg:proceed x-error :continue) () - :continue) - -#+(and Genera (not ansi-common-lisp)) -(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) - (format stream continue-format-string)) - -#+(or ansi-common-lisp excl lcl3.0 CMU) -(define-condition x-error (error)) - -#-(or lispm ansi-common-lisp excl lcl3.0 CMU) -(defstruct x-error - report-function) - -#-(or lispm ansi-common-lisp excl lcl3.0 CMU) -(defun reporter-for-condition (name) - (xintern "." name '-reporter.)) - -#-(or lispm ansi-common-lisp excl lcl3.0 CMU) -(defmacro define-condition (name parents &body options) - ;; Define a structure that when printed displays an error message - (let ((slots (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 (car parents)))) - `(within-definition (,name define-condition) - (defstruct (,name (:conc-name ,(intern conc-name)) - (:print-function condition-print) - (:include ,(car parents) (report-function ',report-function))) - ,@slots) - ,(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 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 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 ansi-common-lisp excl lcl3.0) -(define-condition type-error (x-error) - (datum - 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) -(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 (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (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 (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (values list)) - (ecase family - (:internet - (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 - (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 (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (values list)) - (let ((net-type (if (eq family :DECnet) - :DNA - family))) - (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 - (multiple-value-bind (a b c d) (tcp:explode-internet-address address) - (list :internet a b c d))) - ((:chaos :DECnet) - (list family (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) - -#+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 (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 (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))) - - -;;----------------------------------------------------------------------------- -;; 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 () - #+lispm t #-lispm nil) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (when #+(or unix mach) t - #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) - (merge-pathnames (user-homedir-pathname) (pathname ".Xdefaults")))) - - - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (when #+(or unix mach) t - #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) - (or #+(or excl lcl3.0 CMU) - (let ((string #-CMU (#+excl sys:getenv - #+lcl3.0 lcl:environment-variable - "XENVIRONMENT") - #+CMU (cdr (assoc :xenvironment ext:*environment-list*)))) - (when string - (pathname string))) - (merge-pathnames - (user-homedir-pathname) - (pathname - (concatenate 'simple-string ".Xdefaults-" - #+excl (short-site-name) - #-excl (machine-instance))))))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -#+Genera -(si:define-gc-cleanup clx-cleanup ("CLX 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) - (fill *reply-buffer-free-lists* nil) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil)) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - 'card4) - -(deftype pixarray-8-element-type () - 'card8) - -(deftype pixarray-16-element-type () - 'card16) - -(deftype pixarray-24-element-type () - #-Genera 'card24 #+Genera 'int32) - -(deftype pixarray-32-element-type () - #-Genera 'card32 #+Genera 'int32) - -(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) - - -;;; 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) - `(the (unsigned-byte ,size) - (#-Genera ldb #+Genera sys:%logldb - (byte ,size ,(if *image-bit-lsb-first-p* position (- 7 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) - (let* ((bytes (if *image-byte-lsb-first-p* bytes (reverse bytes))) - (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 - `(the card8 - (#-Genera ldb #+Genera sys:%logldb - (byte 8 ,(if *image-byte-lsb-first-p* - position - (- integer-size 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) - (let* ((bytes (if *image-bit-lsb-first-p* bytes (reverse bytes))) - (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))) - -;;; 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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (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 (simple-array pixarray-1-element-type (*)) vector) - (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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (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 (simple-array pixarray-4-element-type (*)) vector) - (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 lcl3.0 excl) -(defun fast-read-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (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 (simple-array pixarray-8-element-type (*)) vector) - (type array-index start y)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (the card8 (aref buffer-bbuf i)))))) - t) - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type card16 width height) - (type array-index index padded-bytes-per-line)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (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 (simple-array pixarray-16-element-type (*)) vector) - (type array-index start y)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (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))))))) - t) - -#+Genera -(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((array array) - (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 (sys:array-register-1d array) - (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 (sys:%1d-aref array x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2))))))) - t) - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (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 (simple-array pixarray-24-element-type (*)) vector) - (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) - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type card16 width height) - (type array-index index padded-bytes-per-line)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (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 (simple-array pixarray-32-element-type (*)) vector) - (type array-index start y)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (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)) - (aref buffer-bbuf (index+ i 3))))))) - t) - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel) - (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)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (or - #+lispm - (let* ((padded-bits-per-line (* padded-bytes-per-line 8)) - (padded-pixels-per-line - (floor padded-bits-per-line bits-per-pixel)) - (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))) - (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bits-per-line 32)) - (zerop (index-mod pixarray-padded-bits-per-line 32))) - (#+Genera sys:stack-let* #-Genera let* - ((dimensions (list height padded-pixels-per-line)) - (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)) - #+Genera - (when (= bits-per-pixel 24) - (fast-read-pixarray-24 - bbuf boffset pixarray x y width height padded-bytes-per-line)) - #+(or lcl3.0 excl) - (funcall - (ecase bits-per-pixel - (1 #'fast-read-pixarray-1) (4 #'fast-read-pixarray-4) - (8 #'fast-read-pixarray-8) (16 #'fast-read-pixarray-16) - (24 #'fast-read-pixarray-24) (32 #'fast-read-pixarray-32)) - bbuf boffset pixarray x y width height padded-bytes-per-line) - )) - -;;; 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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (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 (simple-array pixarray-1-element-type (*)) vector) - (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) - (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)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (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 (simple-array pixarray-4-element-type (*)) vector) - (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 lcl3.0 excl) -(defun fast-write-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (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)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type (simple-array pixarray-8-element-type (*)) vector) - (type array-index h y start)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref buffer-bbuf i) (the card8 (aref vector x)))))) - t) - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (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)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type (simple-array pixarray-16-element-type (*)) vector) - (type array-index h y start)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (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-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)))))) - t) - -#+Genera -(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (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)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((array array) - (h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (sys:array-register-1d array) - (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 (sys:%1d-aref array 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) - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (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)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type (simple-array pixarray-24-element-type (*)) vector) - (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) - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (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)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((vector (underlying-simple-vector array)) - (h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type (simple-array pixarray-32-element-type (*)) vector) - (type array-index h y start)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (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-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 2)) - (write-image-load-byte 24 pixel 32)))))) - t) - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel) - (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)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (or - #+lispm - (let* ((padded-bits-per-line (* padded-bytes-per-line 8)) - (padded-pixels-per-line - (floor padded-bits-per-line bits-per-pixel)) - (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))) - (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bits-per-line 32)) - (zerop (index-mod pixarray-padded-bits-per-line 32))) - (#+Genera sys:stack-let* #-Genera let* - ((dimensions (list height padded-pixels-per-line)) - (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)) - #+Genera - (when (= bits-per-pixel 24) - (fast-write-pixarray-24 - bbuf boffset pixarray x y width height padded-bytes-per-line)) - #+(or lcl3.0 excl) - (funcall - (ecase bits-per-pixel - (1 #'fast-write-pixarray-1) (4 #'fast-write-pixarray-4) - (8 #'fast-write-pixarray-8) (16 #'fast-write-pixarray-16) - (24 #'fast-write-pixarray-24) (32 #'fast-write-pixarray-32)) - bbuf boffset pixarray x y width height padded-bytes-per-line) - )) - -;;; 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) - (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)) - #+Genera - (let ((src pixarray) - (dest copy)) - (declare (sys:array-register-1d src dest)) - (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 (sys:%1d-aref dest dst-idx) - (sys:%1d-aref src src-idx)))) - t) - #+(or lcl3.0 excl) - (macrolet - ((copy (type element-type) - `(let* ((pixarray pixarray) - (copy copy) - (src (underlying-simple-vector pixarray)) - (dst (underlying-simple-vector copy))) - (declare (type ,type pixarray copy) - (type (simple-array ,element-type (*)) src dst)) - #.(declare-buffun) - (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 05cbcc283f587fb293f0f9bb463f3b0b5e014b71..0000000000000000000000000000000000000000 --- a/clx/display.lisp +++ /dev/null @@ -1,533 +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) - -(export '( - with-display - with-event-queue - open-display - display-force-output - close-display - display-protocol-version - display-vendor - display-roots - display-motion-buffer-size - display-max-request-length - display-error-handler - display-after-function - display-invoke-after-function - display-finish-output)) - -;; -;; 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 (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 - (declare (type display display) - (type t object)) - (declare (values resource-id)) - (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 (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 (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 (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 (values (or null resource-id))) - (gethash (if (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 (values resource-id)) - (let ((atom (if (keywordp atom) atom (kintern atom)))) - (declare (type keyword 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) - (do ((i 1 (1+ i)) - (end (length *predefined-atoms*))) - ((>= i end)) - (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) - (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)) - #+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) - (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 &rest options &key (display 0) protocol - authorization-name authorization-data &allow-other-keys) - ;; 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) - (dynamic-extent options)) - (declare (values display)) - ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. - (let* ((stream (open-x-stream host display protocol)) - (disp (apply #'make-buffer - #x2000 'make-display-internal - :host host - :display display - :output-stream stream - :input-stream stream - :allow-other-keys t - options)) - (ok-p nil)) - (unwind-protect - (progn - (display-connect disp - :authorization-name authorization-name - :authorization-data 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) - (unless authorization-name (setq authorization-name "")) - (unless authorization-data (setq 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) - (write-sequence-char 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 - (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) - (buffer-input display buffer-bbuf 0 40) - (let* ((root (make-window :id (card32-get 0) :display display)) - (root-visual (card32-get 32)) - (default-colormap - (make-colormap :id (card32-get 4) - :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 (window-id root) root) - ;; Create the depth AList for a screen, (depth . visual-infos) - (dotimes (j num-depths) - (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) - (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 (values major minor)) - (values (display-protocol-major-version display) - (display-protocol-minor-version display))) - -(defun display-vendor (display) - (declare (type display display)) - (declare (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 eb38a9363c194b888edc59dd910cfe29c1b9b326..0000000000000000000000000000000000000000 --- a/clx/doc.lisp +++ /dev/null @@ -1,3807 +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. - -;; Note: various perversions of the CL type system are used below. -;; Examples: (list elt-type) (sequence elt-type) - -(proclaim '(declaration arglist 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>) - (values display))) - -(defun <mumble>-id (<mumble>) - (declare (type <mumble> <mumble>) - (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>) - (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) - (values color))) - -(defun color-rgb (color) - (declare (type color color) - (values red green blue))) - -(defun color-red (color) - ;; setf'able - (declare (type color color) - (values rgb-val))) - -(defun color-green (color) - ;; setf'able - (declare (type color color) - (values rgb-val))) - -(defun color-blue (color) - ;; setf'able - (declare (type color color) - (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)) - -(deftype real (&optional (min '*) (max '*)) - `(or (real ,min ,max) (rational ,min ,max))) - -;; An association list. - -(deftype alist (key-type-and-name datum-type-and-name) 'list) - -;; 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 (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 (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 (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 (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) ((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) - (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) - (values display))) - -(defun display-protocol-major-version (display) - (declare (type display display) - (values card16))) - -(defun display-protocol-minor-version (display) - (declare (type display display) - (values card16))) - -(defun display-vendor-name (display) - (declare (type display display) - (values string))) - -(defun display-release-number (display) - (declare (type display display) - (values card32))) - -(defun display-image-lsb-first-p (display) - (declare (type display display) - (values boolean))) - -(defun display-bitmap-formap (display) - (declare (type display display) - (values bitmap-format))) - -(defun display-pixmap-formats (display) - (declare (type display display) - (values (list pixmap-formats)))) - -(defun display-roots (display) - (declare (type display display) - (values (list screen)))) - -(defun display-motion-buffer-size (display) - (declare (type display display) - (values card32))) - -(defun display-max-request-length (display) - (declare (type display display) - (values card16))) - -(defun display-min-keycode (display) - (declare (type display display) - (values card8))) - -(defun display-max-keycode (display) - (declare (type display display) - (values card8))) - -(defun close-display (display) - (declare (type display display))) - -(defun display-error-handler (display) - (declare (type display display) - (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 (sequence (function (display symbol &rest key-vals))) - (function (display symbol &rest key-vals))) - 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 &rest key-vals) - ;; 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) - (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) - (values window))) - -(defun window-class (window) - (declare (type window window) - (values (member :input-output :input-only)))) - -(defun window-visual-info (window) - (declare (type window window) - (values visual-info))) - -(defun window-visual (window) - (declare (type window window) - (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) - (values win-gravity))) - -(defun window-bit-gravity (window) - ;; setf'able - (declare (type window window) - (values bit-gravity))) - -(defun window-backing-store (window) - ;; setf'able - (declare (type window window) - (values (member :not-useful :when-mapped :always)))) - -(defun window-backing-planes (window) - ;; setf'able - (declare (type window window) - (values pixel))) - -(defun window-backing-pixel (window) - ;; setf'able - (declare (type window window) - (values pixel))) - -(defun window-save-under (window) - ;; setf'able - (declare (type window window) - (values (member :on :off)))) - -(defun window-event-mask (window) - ;; setf'able - (declare (type window window) - (values mask32))) - -(defun window-do-not-propagate-mask (window) - ;; setf'able - (declare (type window window) - (values mask32))) - -(defun window-override-redirect (window) - ;; setf'able - (declare (type window window) - (values (member :on :off)))) - -(defun window-colormap (window) - (declare (type window window) - (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) - (values boolean))) - -(defun window-all-event-masks (window) - (declare (type window window) - (values mask32))) - -(defun window-map-state (window) - (declare (type window window) - (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) - (values window))) - -(defun drawable-depth (drawable) - (declare (type drawable drawable) - (values card8))) - -(defun drawable-x (drawable) - (declare (type drawable drawable) - (values int16))) - -(defun drawable-y (drawable) - (declare (type drawable drawable) - (values int16))) - -(defun drawable-width (drawable) - ;; For windows, inside width, excluding border. - (declare (type drawable drawable) - (values card16))) - -(defun drawable-height (drawable) - ;; For windows, inside height, excluding border. - (declare (type drawable drawable) - (values card16))) - -(defun drawable-border-width (drawable) - (declare (type drawable drawable) - (values card16))) - -(defun query-tree (window &key (result-type 'list)) - (declare (type window window) - (type type result-type) - (values (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) - (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 (sequence xatom) properties) - (type int16 delta))) - -(defun list-properties (window &key (result-type 'list)) - (declare (type window window) - (type type result-type) - (values (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) - (values resource-id))) - -(defun find-atom (display name) - (declare (type display display) - (type xatom name) - (values (or null resource-id)))) - -(defun atom-name (display atom-id) - (declare (type display display) - (type resource-id atom-id) - (values keyword))) - -(defun selection-owner (display selection) - (declare (type display display) - (type xatom selection) - (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) - (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) - (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) - (values x y same-screen-p child mask root-x root-y root))) - -(defun pointer-position (window) - (declare (type window window) - (values x y same-screen-p))) - -(defun global-pointer-position (display) - (declare (type display display) - (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) - (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) - (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) - (values focus revert-to))) - -(defun query-keymap (display) - (declare (type display display) - (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) - (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) - (values (or null string)))) - -(defun font-direction (font) - (declare (type font font) - (values draw-direction))) - -(defun font-min-char (font) - (declare (type font font) - (values card16))) - -(defun font-max-char (font) - (declare (type font font) - (values card16))) - -(defun font-min-byte1 (font) - (declare (type font font) - (values card8))) - -(defun font-max-byte1 (font) - (declare (type font font) - (values card8))) - -(defun font-min-byte2 (font) - (declare (type font font) - (values card8))) - -(defun font-max-byte2 (font) - (declare (type font font) - (values card8))) - -(defun font-all-chars-exist-p (font) - (declare (type font font) - (values boolean))) - -(defun font-default-char (font) - (declare (type font font) - (values card16))) - -(defun font-ascent (font) - (declare (type font font) - (values int16))) - -(defun font-descent (font) - (declare (type font font) - (values int16))) - -;; The list contains alternating keywords and int32s. - -(deftype font-props () 'list) - -(defun font-properties (font) - (declare (type font font) - (values font-props))) - -(defun font-property (font name) - (declare (type font font) - (type keyword name) - (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) - (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) - (values int16))) - -(defun min-char-<metric> (font) - (declare (type font font) - (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) - (values (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) - (values (sequence font)))) - -(defun font-path (display &key (result-type 'list)) - (declare (type display display) - (type type result-type) - (values (sequence (or string pathname))))) - -(defsetf font-path (display) (paths) - (declare (type display display) - (type (sequence (or string pathname)) paths))) - -(defun create-pixmap (&key width height depth drawable) - (declare (type card16 width height) - (type card8 depth) - (type drawable drawable) - (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 (sequence card8))) dashes) - (type boolean cache) - (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) - (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) - (values (or null font)))) - -(defun gcontext-clip-mask (gcontext) - (declare (type gcontext gcontext) - (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 (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 (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 (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) - (values (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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (values colormap))) - -(defun free-colormap (colormap) - (declare (type colormap colormap))) - -(defun copy-colormap-and-free (colormap) - (declare (type colormap colormap) - (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) - (values (sequence colormap)))) - -(defun alloc-color (colormap color) - (declare (type colormap colormap) - (type (or stringable color) color) - (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) - (values (sequence pixel) (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) - (values (sequence pixel) red-mask green-mask blue-mask))) - -(defun free-colors (colormap pixels &optional (plane-mask 0)) - (declare (type colormap colormap) - (type (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 (sequence pixel) pixels) - (type type result-type) - (values (sequence color)))) - -(defun lookup-color (colormap name) - (declare (type colormap colormap) - (type stringable name) - (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) - (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) - (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) - (values width height))) - -(defun query-best-tile (width height drawable) - (declare (type card16 width height) - (type drawable drawable) - (values width height))) - -(defun query-best-stipple (width height drawable) - (declare (type card16 width height) - (type drawable drawable) - (values width height))) - -(defun query-extension (display name) - (declare (type display display) - (type stringable name) - (values major-opcode first-event first-error))) - -(defun list-extensions (display &key (result-type 'list)) - (declare (type display display) - (type type result-type) - (values (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 (sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5) - (values (member :success :busy :failed)))) - -(defun modifier-mapping (display) - ;; each value is a list of card8s - (declare (type display display) - (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) - (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) - (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) - (values (sequence card8)))) - -(defsetf pointer-mapping (display) (map) - ;; Can signal device-busy. - (declare (type display display) - (type (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) - (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) - (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) - (values (sequence host) enabled-p))) - -(defun access-control (display) - ;; setf'able - (declare (type display display) - (values boolean))) - -(defun close-down-mode (display) - ;; setf'able - ;; Cached locally in display object. - (declare (type display display) - (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 (list event-mask-class) keys) - (values mask32))) - -(defun make-event-keys (event-mask) - ;; This is only defined for core events. - (declare (type mask32 event-mask) - (values (list event-mask-class)))) - -(defun make-state-mask (&rest keys) - ;; Useful for constructing modifier-mask, state-mask. - (declare (type (list state-mask-key) keys) - (values mask16))) - -(defun make-state-keys (state-mask) - (declare (type mask16 mask) - (values (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) - (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 (sequence (function (&rest key-vals) t)) - (function (&rest key-vals) 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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (card32 time)) - -(declare-event :selection-clear - (card16 sequence) - (window (window event-window)) - (keyword selection) - (card32 time)) - -(declare-event :selection-request - (card16 sequence) - (window (window event-window) requestor) - (keyword selection target) - ((or null keyword) property) - (card32 time)) - -(declare-event :selection-notify - (card16 sequence) - (window (window event-window)) - (keyword selection target) - ((or null keyword) property) - (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 integer) 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) - (values string))) - -(defsetf wm-name (window) (name)) - -(defun wm-icon-name (window) - (declare (type window window) - (values string))) - -(defsetf wm-icon-name (window) (name)) - -(defun get-wm-class (window) - (declare (type window window) - (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) - (values (list string)))) - -(defsetf wm-command (window) (command) - ;; Uses PRIN1 to a string-stream with the following bindings: - ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil) - ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp)) - ;; each element of command is seperated with NULL characters. - ;; This enables (mapcar #'read-from-string (wm-command window)) - ;; to recover a lisp command. - (declare (type window window) - (type (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) - (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) - (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) - (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) - (values wm-size-hints))) - -(defsetf icon-sizes (window) (wm-size-hints)) - -(defun wm-protocols (window) - (declare (type window window) - (values protocols))) - -(defsetf wm-protocols (window) (protocols) - (declare (type window window) - (type (list keyword) protocols))) - -(defun wm-colormap-windows (window) - (declare (type window window) - (values windows))) - -(defsetf wm-colormap-windows (window) (windows) - (declare (type window window) - (type (list window) windows))) - -(defun transient-for (window) - (declare (type window window) - (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 - 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 (or null boolean) user-specified-position-p user-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) - (values (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 (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) - (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) - (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 string-char t) object) - (type keysym keysym) - (type (or null mask16 list) ;; (list (or keysym state-mask-key)) - modifiers) - (type (or null (member :modifiers) mask16 list) ;; (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 list) ; (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 string-char t) object) - (type keysym keysym) - (type (or null mask16 list) ;; (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: - ;; (string-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) - (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 (list card8) bytes) - (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) - (values (list keysym)))) - -(defun keycode->keysym (display keycode keysym-index) - (declare (type display display) - (type card8 code) - (type card16 state) - (type card8 keysym-index) - (values keysym))) - -(defun keysym->keycodes (display keysym) - ;; Return keycodes for keysym, as multiple values - (declare (type display display) - (type keysym keysym) - (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) - (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) - (values (or null character)))) - -(defun default-keysym-index (display keycode state) - ;; Returns a keysym-index for use with keycode->character - (declare (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) - (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 (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) - (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) - (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 (list keywords)) event-codes) - (type (alist (field-type symbol) (field-names (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 (function (gcontext t) t) set-function) ;; required - (type (or null (function (gcontext gcontext t) t)) - 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) - (values region))) - -(defun region-p (thing)) - -(defun copy-region (region)) - -(defun region-empty-p (region) - (declare (type region region) - (values boolean))) - -(defun region-clip-box (region) - ;; Returns a region which is the smallest enclosing rectangle - ;; enclosing REGION - (declare (type region region) - (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 (list region) regions) - (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 (list region) regions) - (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) - (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) - (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) - (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) - (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) - (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) -;; (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) - (values region))) - -(defun region->image (region) - ;; Returns a depth-1 image containg 1 bits for every pixel in REGION. - (declare (type region region) - (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) - (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 (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 - (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) - (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) - (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) - (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) - (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 (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 (list stringable) full-name full-class) - (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 (list stringable) name-list) - (type t value))) - -(defun delete-resource (database name-list) - (declare (type resource-database database) - (type (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 ((list stringable) t &rest t) t) function) - (values nil))) - -(defun merge-resources (database with-database) - (declare (type resource-database database with-database) - (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 ((list string) t) boolean)) - test test-not) - (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 ((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 t) boolean)) test test-not) - (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 t) boolean)) test test-not) - (type (or null (function (string stream) t)) write) - (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 (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 567023432ab44f3565d9d55ab2a0d25721f6a4a0..0000000000000000000000000000000000000000 --- a/clx/exclMakefile +++ /dev/null @@ -1,133 +0,0 @@ -# -# Makefile for CLX -# (X11 R4 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 = excldep.fasl defsystem.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 = 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 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 - - -all: $(C_OBJS) compile-CLX cat - -clos: $(C_OBJS) compile-closified-CLX cat - -CLX: $(C_OBJS) compile-CLX load-CLX - - -c: $(C_OBJS) - - -lisp: compile-CLX - - -compile-CLX: $(C_OBJS) - $(ECHO) " \ - (set-case-mode :case-sensitive-lower) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - (compile-file-if-needed \"excldep\") \ - (compile-file-if-needed \"defsystem\") \ - (load \"defsystem\") \ - #+allegro (compile-system :clx) \ - #-allegro (xlib::compile-clx) \ - #+allegro (compile-system :clx-debug)" \ - | $(CL) $(CLOPTS) -batch - - -compile-closified-CLX: $(C_OBJS) - $(ECHO) " \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - (setq excl::*print-nickname* t) \ - (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))) \ - (compile-file-if-needed \"excldep\") \ - (compile-file-if-needed \"defsystem\") \ - (load \"defsystem\") \ - #+allegro (compile-system :clx) \ - #-allegro (xlib::compile-clx) \ - #+allegro (compile-system :clx-debug)" \ - | $(CL) $(CLOPTS) -batch - - -cat: - -cat $(L_NOMACROS_OBJS) > CLX.fasl - - -load-CLX: - $(ECHO) '(load "defsystem")' \ - "(let (#+allegro (spread (sys:gsgc-parameter :generation-spread)))" \ - " #+allegro (setf (sys:gsgc-parameter :generation-spread) 1)" \ - " #+allegro (load-system :clx)" \ - " #-allegro (xlib::load-clx)" \ - " #+allegro (gc :tenure)" \ - " #+allegro (setf (sys:gsgc-parameter :generation-spread) spread)" \ - ")" \ - '#+allegro (gc t)' \ - '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ - '(exit)' | $(CL) $(CLOPTS) - - -clean: - $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) - - -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 02ed020a85636042627de1e8dcb00327450bdf7f..0000000000000000000000000000000000000000 --- a/clx/exclREADME +++ /dev/null @@ -1,59 +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 -and 3.1. - - 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 -% mkdir MIT -% mv defsystem.cl MIT -% mv excldefsys.cl defsystem.cl -% 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 9759e4d006026f7a2a48351feacf322d1b032b6c..0000000000000000000000000000000000000000 --- a/clx/exclcmac.lisp +++ /dev/null @@ -1,313 +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 :use '(:foreign-functions :lisp :excl)) - -(import '(excl::defcmacro)) - -;; -;; Type predicates -;; -(defcmacro card8p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) - -(defcmacro card16p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) - -(defcmacro int8p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) - -(defcmacro int16p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) - -;; Card29p, card32p, int32p are too large to expand inline - - -;; -;; Type transformers -;; -(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))))) -(defcmacro int8->card8 (x) - `(locally ,(declare-bufmac) - (the card8 (ldb (byte 8 0) (the int8 ,x))))) - -(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))))) - -(defcmacro int16->card16 (x) - `(locally ,(declare-bufmac) - (the card16 (ldb (byte 16 0) (the int16 ,x))))) - -(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))))) - -(defcmacro int32->card32 (x) - `(locally ,(declare-bufmac) - (the card32 (ldb (byte 32 0) (the int32 ,x))))) - -(defcmacro char->card8 (char) - `(locally ,(declare-bufmac) - (the card8 (char-code (the string-char ,char))))) - -(defcmacro card8->char (card8) - `(locally ,(declare-bufmac) - (the string-char (code-char (the card8 ,card8))))) - - -;; -;; Array accessors and setters -;; -(defcmacro aref-card8 (a i) - `(locally ,(declare-bufmac) - (the card8 (aref (the buffer-bytes ,a) (the array-index ,i))))) - -(defcmacro aset-card8 (v a i) - `(locally ,(declare-bufmac) - (setf (aref (the buffer-bytes ,a) (the array-index ,i)) - (the card8 ,v)))) - -(defcmacro aref-int8 (a i) - `(locally ,(declare-bufmac) - (card8->int8 (aref (the buffer-bytes ,a) (the array-index ,i))))) - -(defcmacro aset-int8 (v a i) - `(locally ,(declare-bufmac) - (setf (aref (the buffer-bytes ,a) (the array-index ,i)) - (int8->card8 ,v)))) - -(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)))) - -(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)))) - -(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)))) - -(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)))) - -(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)))) - -(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)))) - -(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)))) - -(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)))) - -(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)))) - -(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 -;; -(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))))) - -(defcmacro font-font-info (font) - (let ((f (gensym))) - `(let ((,f ,font)) - (or (font-font-info-internal ,f) - (query-font ,f))))) - -(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 -;; -(defcmacro current-process () - `(the (or mp::process null) (and mp::*scheduler-stack-group* - mp::*current-process*))) - -(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)))))) - -#+notyet -(defcmacro buffer-replace (target-sequence source-sequence target-start - target-end &optional (source-start 0)) - (let ((tv (gensym)) (sv (gensym)) (ts (gensym)) (te (gensym)) (ss (gensym))) - `(let ((,tv ,target-sequence) (,sv ,source-sequence) - (,ts ,target-start) (,te ,target-end) (,ss ,source-start)) - (declare (type buffer-bytes ,tv ,sv) - (type array-index ,ts ,te ,ss) - (optimize (speed 3) (safety 0))) - - (let ((source-end (length ,sv))) - (declare (type array-index source-end)) - - (if* (and (eq ,tv ,sv) - (> ,ts ,ss)) - then (let ((nelts (min (- ,te ,ts) - (- source-end ,ss)))) - (do ((target-index (+ ,ts nelts -1) (1- target-index)) - (source-index (+ ,ss nelts -1) (1- source-index))) - ((= target-index (1- ,ts)) ,tv) - (declare (type array-index target-index source-index)) - - (setf (aref ,tv target-index) - (aref ,sv source-index)))) - else (do ((target-index ,ts (1+ target-index)) - (source-index ,ss (1+ source-index))) - ((or (= target-index ,te) (= source-index source-end)) - ,tv) - (declare (type array-index target-index source-index)) - - (setf (aref ,tv target-index) - (aref ,sv source-index)))))))) - -(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))))))) - -(defcmacro byte-reverse (byte) - `(aref ,'#.(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)) - ,byte)) - -#| -#+(or allegro-v3.0 allegro-v3.1) -(defcmacro graphic-char-p (char) - `(let* ((cint (char-int ,char))) - (if (and (<= #.(char-code #\space) cint) - (<= cint #.(char-code #\~))) - t - nil))) -|# - 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 62c4574ddb7b7c1a167df3dada14f0644297f96f..0000000000000000000000000000000000000000 --- a/clx/excldep.lisp +++ /dev/null @@ -1,514 +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 :use '(:foreign-functions :lisp :excl)) - -(eval-when (load) - (provide :clxexcldep) - (provide :clx)) - -(require :foreign) -(require :process) ; Needed even if scheduler is not - ; running. (Must be able to make - ; a process-lock.) - -(import '(excl::if* - excl::type-error - excl::type-error-datum - excl::type-error-expected-type)) -#+allegro -(import '(excl::without-interrupts)) - -#-(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 define-condition (name (parent-type) &optional slots &rest args) - `(excl::define-condition ,name (,parent-type) ,slots ,@args)) - - -(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))))) - - -(defun underlying-simple-vector (array) - (cond ((excl::svectorp array) - array) - ((arrayp array) - (cdr (excl::ah_data array))) - (t - (error "~s is not an array" array)))) - - -(defconstant type-pred-alist - '( - (card8 . card8p) - (card16 . card16p) - (card29 . card29p) - (card32 . card32p) - (int8 . int8p) - (int16 . int16p) - (int32 . int32p) - (mask16 . card16p) - (mask32 . card32p) - (pixel . card32p) - (resource-id . card29p) - (keysym . card32p) - )) - -;; This (if (and ...) t nil) stuff has a purpose -- it lets the old -;; sun4 compiler opencode the `and'. - -(defun card8p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (fixnump x) (> #.(expt 2 8) x) (>= x 0)) - t - nil)) - -(defun card16p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (fixnump x) (> #.(expt 2 16) x) (>= x 0)) - t - nil)) - -(defun card29p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (and (fixnump x) (>= (the fixnum x) 0)) - (and (bignump x) (> #.(expt 2 29) (the bignum x)) - (>= (the bignum x) 0))) - t - nil)) - -(defun card32p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (and (fixnump x) (>= (the fixnum x) 0)) - (and (bignump x) (> #.(expt 2 32) (the bignum x)) - (>= (the bignum x) 0))) - t - nil)) - -(defun int8p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) - t - nil)) - -(defun int16p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) - t - nil)) - -(defun int32p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (fixnump x) - (and (bignump x) (> #.(expt 2 31) (the bignum x)) - (>= (the bignum x) #.(expt -2 31)))) - t - nil)) - -(comp::def-tr comp::new-tr-typep typep (form type) - (let (ent) - (if* (and (consp type) - (eq 'quote (car type)) - (consp (cdr type))) - then (setq ent (franz:assq (cadr type) type-pred-alist))) - (if* ent - then `(,(cdr ent) ,form) - else (if* (and (consp type) - (eq 'quote (car type)) - (consp (cdr type))) - then (setq ent (franz:assq (cadr type) - excl::type-pred-alist))) - (if* ent - then `(,(cdr ent) ,form) - else (comp::no-transform))))) - - -;; 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) - (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)) - (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)))) - - -#-allegro -(defmacro without-interrupts (&body body) - `(let ((excl::*without-interrupts* t)) ,@body)) - - -(in-package :excl) - -#-allegro -(defun type-array-element-type-to-array (type &aux temp) - ;; type is a type descriptor, return a descriptor which tells - ;; the array code what kind of array to make - - ; convert the given element type to one of the symbols which - ; is in the car of the array-descriptors list - ;(msg "beginning type is " type 'N) - (if* (symbolp type) - then (if* (franz:memq type '(t bit string-char fixnum)) - thenret ; it is ok as it is - else (let ((temp (get type 'deftype-expander))) - (if* temp - then - (return-from type-array-element-type-to-array - (type-array-element-type-to-array - (funcall temp (list type)))) - else - (setq type (case type - (standard-char 'string-char) - ((single-float short-float) 'single-float) - ((double-float long-float) 'double-float) - (t t)))))) - elseif (consp type) - then (setq type - (case (car type) - (mod (if* (integerp (setq temp (cadr type))) - then (cond ((< temp 1) t) - ((<= temp 2) 'bit) - ((<= temp 256) 'ubyte) - ((<= temp 65536) 'uword) - ((<= temp 4294967296) 'ulong) - (t t)) - else t)) - (signed-byte - (if* (integerp (setq temp (cadr type))) - then (cond ((<= temp 0) t) - ((<= temp 8) 'byte) - ((<= temp 16) 'word) - ((<= temp 29) 'fixnum) - ((<= temp 32) 'long) - (t t)) - else t)) - (unsigned-byte - (if* (integerp (setq temp (cadr type))) - then (cond ((<= temp 0) t) - ((<= temp 8) 'ubyte) - ((<= temp 16) 'uword) - ((<= temp 32) 'ulong) - (t t)) - else t)) - (t t))) - else (setq type t)) - ; type is now one of the valid types. We return a descriptor - ; based on that name - ;(msg "resulting type is " type 'N) - (let ((res (franz:assq type array-descriptors))) - ;(msg " resulting decriptor " res 'N) - res)) - -#-allegro -(defun make-sequence (type length &rest rest &key initial-element) - "Returns a sequence of the given Type and Length, with elements initialized - to :Initial-Element." - (declare (fixnum length) - (ignore initial-element)) - (case (type-specifier type) - (list (apply #'make-list length rest)) - ((simple-string string) - (apply #'make-string length rest)) - ((array simple-array vector simple-vector) - (if* (listp type) - then (apply #'make-array length :element-type (cadr type) rest) - else (apply #'make-array length rest))) - ((bit-vector simple-bit-vector) - (apply #'make-array length :element-type 'bit rest)) - (t - ;; Now, we can either have a user-defined type symbol, or an error. - (if* (symbolp type) - then (let ((temp (get type 'excl::deftype-expander))) - (if* temp - then (cond (rest (return-from make-sequence - (make-sequence (funcall temp (list type)) length - :initial-element (cadr rest)))) - (t (return-from make-sequence (make-sequence - (funcall temp (list type)) length))))))) - (error "~s is a bad type specifier for sequences." type )))) - -;; special patch for CLX (various process fixes) -;; patch1000.2 - -(in-package 'patch :use '(lisp excl)) - -(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 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 (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))))) - (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 - (if* (null (process-lock-locker lock)) - then (setf (process-lock-locker lock) lock-value) - else (if* timeout - then (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. - (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 (if* (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) - (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)) - (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 b40f9867900dad03e9f14476760dcc5f1dd1daf7..0000000000000000000000000000000000000000 --- a/clx/fonts.lisp +++ /dev/null @@ -1,373 +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) - -(export '( - open-font - discard-font-info - close-font - list-font-names - list-fonts - font-path)) - -;; 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) -; (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) -; (values integer))) - -;(defun min-char-<metric> (font) -; (declare (type font font) -; (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 (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 (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 (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) - (array-register 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 (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 (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 (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 (values (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 (values (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 (values (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 sequence paths)) ;; (sequence (or string pathname)) - (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)))))) - -(defsetf font-path set-font-path) diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp deleted file mode 100644 index ad718d121741ec191849da810793edfae0c5ee6b..0000000000000000000000000000000000000000 --- a/clx/gcontext.lisp +++ /dev/null @@ -1,1037 +0,0 @@ -;;; -*- Package: XLIB; Log: clx.log -*- - -;;; 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) - -(export '(force-gcontext-changes - with-gcontext - create-gcontext - copy-gcontext-components - copy-gcontext - free-gcontext - - gcontext-function - gcontext-plane-mask - gcontext-foreground - gcontext-background - gcontext-line-width - gcontext-line-style - gcontext-cap-style - gcontext-join-style - gcontext-fill-style - gcontext-fill-rule - gcontext-tile - gcontext-stipple - gcontext-ts-x - gcontext-ts-y - gcontext-font - gcontext-subwindow-mode - gcontext-exposures - gcontext-clip-x - gcontext-clip-y - gcontext-clip-mask - gcontext-dashes - gcontext-arc-mode - gcontext-dash-offset - gcontext-clip-ordering - - define-gcontext-accessor - )) - -;; 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*)) - -;;; CMU Common Lisp's old compiler has a bug in compiling DEFCONSTANT's within -;;; MACROLET's. -#-CMU -(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))) - -#+CMU -(defmacro 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)))))) - -#+CMU -(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 #'identity :type (function (gcontext t) t) :read-only t) - (copy-function #'identity :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) -; (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 (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 (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 (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 (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) - (array-register 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 #-CMU `(setf ,accessor ,temp-var) - #+CMU `(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 (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) 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 (function (gcontext t) t) set-function) ;; required - (type (or null (function (gcontext gcontext t) t)) - 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 0319ab599c953e53767165c563c80f90f3ee6f13..0000000000000000000000000000000000000000 --- a/clx/generalock.lisp +++ /dev/null @@ -1,62 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- - -(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 2f560888b5540f2ac300d89418e76f82700526c5..0000000000000000000000000000000000000000 --- a/clx/graphics.lisp +++ /dev/null @@ -1,460 +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) - -(export '( - draw-point - draw-points - draw-line - draw-lines - draw-segments - draw-rectangle - draw-rectangles - draw-arc - draw-arcs - put-raw-image - get-raw-image)) - -(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 (values (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 152af53f8a65114e315359545afe0d0c99836fc9..0000000000000000000000000000000000000000 --- a/clx/image.lisp +++ /dev/null @@ -1,2697 +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) - -(export '(bitmap - pixarray - image - image-width - image-height - image-depth - image-plist - image-name - image-x-hot - image-y-hot - image-red-mask - image-blue-mask - image-green-mask - image-x - image-xy - image-z - image-x-p - image-xy-p - image-z-p - image-xy-bitmap-list - image-z-bits-per-pixel - image-z-pixarray - create-image - get-image - put-image - copy-image - read-bitmap-file - write-bitmap-file - bitmap-image - image-pixmap)) - -(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) - (princ (image-name image) stream) - (princ " " stream)) - (prin1 (image-width image) stream) - (princ "x" stream) - (prin1 (image-height image) stream) - (princ "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 *image-byte-lsb-first-p*) - (bit-lsb-first-p *image-bit-lsb-first-p*) - 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 (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) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height)) - #.(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) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height)) - #.(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 ((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 - (from-bitmap-unit from-bitmap-byte-lsb-first-p - from-bitmap-bit-lsb-first-p to-bitmap-unit - to-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p) - (declare (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type boolean from-bitmap-bit-lsb-first-p - from-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p - to-bitmap-byte-lsb-first-p) - (values function lsb-first-p)) - (let ((from-index - (index+ - (ecase from-bitmap-unit (32 2) (16 1) (8 0)) - (if from-bitmap-bit-lsb-first-p 3 0) - (if from-bitmap-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-bitmap-bit-lsb-first-p 3 0) - (if to-bitmap-byte-lsb-first-p 6 0))) - (aref *image-swap-lsb-first-p* from-index)))) - -(defun image-swap-xy - (src dest srcoff destoff srclen srcinc destinc height - 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 src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 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)) - (multiple-value-bind (function lsb-first-p) - (image-swap-function - 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 function) - (type boolean lsb-first-p)) - (funcall function src dest srcoff destoff srclen srcinc destinc height - lsb-first-p))) - -(defun image-swap-z - (src dest srcoff destoff srclen srcinc destinc height - bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type card16 height) - (type boolean from-byte-lsb-first-p to-byte-lsb-first-p)) - (cond ((or (eq from-byte-lsb-first-p to-byte-lsb-first-p) - (= bits-per-pixel 8)) - (image-noswap - src dest srcoff destoff srclen srcinc destinc height - from-byte-lsb-first-p)) - ((= bits-per-pixel 32) - (image-swap-four-bytes - src dest srcoff destoff srclen srcinc destinc height - from-byte-lsb-first-p)) - ((= bits-per-pixel 24) - (image-swap-three-bytes - src dest srcoff destoff srclen srcinc destinc height - from-byte-lsb-first-p)) - ((= bits-per-pixel 16) - (image-swap-two-bytes - src dest srcoff destoff srclen srcinc destinc height - from-byte-lsb-first-p)) - (t - (image-swap-nibbles - src dest srcoff destoff srclen srcinc destinc height)))) - - -;;;----------------------------------------------------------------------------- -;;; GET-IMAGE - -(defun read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line)) - #.(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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line)) - #.(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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line)) - #.(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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type card16 width height) - (type array-index index padded-bytes-per-line)) - #.(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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line)) - #.(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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type card16 width height) - (type array-index index padded-bytes-per-line)) - #.(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-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) - (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 :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad))) - -(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) - (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 :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad))) - -(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.)))) - -(defun read-image-xy-data (bbuf index pixarray x y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index index padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (let* ((x1 (index* (index-floor x unit) unit)) - (x (index- x x1)) - (width1 (index+ width x)) - (padded-bits-per-line1 - (index* (index-ceiling width1 *image-pad*) *image-pad*)) - (padded-bytes-per-line1 (index-ceiling padded-bits-per-line1 8))) - (declare (type card16 x1 x width1) - (type array-index padded-bits-per-line1 padded-bytes-per-line1)) - (with-image-data-buffer (buf (index* height padded-bytes-per-line1)) - (image-swap-xy - bbuf buf - (index+ index - (index* y padded-bytes-per-line) - (index-floor x1 8)) - 0 - (index-ceiling width1 8) - padded-bytes-per-line padded-bytes-per-line1 - height - unit byte-lsb-first-p bit-lsb-first-p - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*) - (unless (fast-read-pixarray - buf 0 pixarray x 0 width height padded-bytes-per-line1 1) - (read-pixarray-1 - buf 0 pixarray x 0 width height padded-bytes-per-line1))))) - -(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) - (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-image-xy-data - bbuf index array x y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth depth :data data))) - -(defun read-image-z-data (bbuf index 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 index 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)) - (if (index= bits-per-pixel 1) - (read-image-xy-data - bbuf index pixarray x y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (let* ((xbits (index* x bits-per-pixel)) - (xbits1 (index* (index-floor xbits unit) unit)) - (x1 (index-floor xbits1 bits-per-pixel)) - (x (index- x x1)) - (width1 (index+ width x)) - (bits-per-line1 (index* width1 bits-per-pixel)) - (bytes-per-line1 (index-ceiling bits-per-line1 8)) - (padded-bits-per-line1 - (index* (index-ceiling bits-per-line1 *image-pad*) *image-pad*)) - (padded-bytes-per-line1 - (index-ceiling padded-bits-per-line1 8))) - (declare (type array-index xbits xbits1 x1 x - bits-per-line1 bytes-per-line1 - padded-bits-per-line1 padded-bytes-per-line1)) - (with-image-data-buffer (buf (index* height padded-bytes-per-line1)) - (image-swap-z - bbuf buf - (index+ index - (index* y padded-bytes-per-line) - (index-floor xbits1 8)) - 0 - bytes-per-line1 - padded-bytes-per-line padded-bytes-per-line1 - height - bits-per-pixel byte-lsb-first-p *image-byte-lsb-first-p*) - (unless (fast-read-pixarray - buf 0 pixarray x 0 width height padded-bytes-per-line1 - bits-per-pixel) - (funcall - (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)) - buf 0 pixarray x 0 width height padded-bytes-per-line1)))))) - -(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) - (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-image-z-data - 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) - (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) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line)) - #.(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) - (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)) - #.(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) - (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)) - #.(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) - (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)) - #.(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) - (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)) - #.(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) - (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)) - #.(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 2)) - (write-image-load-byte 24 pixel 32))))))) - -(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))) - (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)) - (image-swap-xy - 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 - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - from-bitmap-unit to-byte-lsb-first-p to-byte-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))) - (image-swap-xy - 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 - 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)))) - -(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) - (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)) - (image-swap-z - data obuf srcoff obuf-start srclen - from-padded-bytes-per-line to-padded-bytes-per-line height - bits-per-pixel from-byte-lsb-first-p to-byte-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-data (obuf boffset pixarray x y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes obuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray-1 pixarray) - (type card16 x y width height) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (unless (fast-write-pixarray - buf 0 pixarray x y width height padded-bytes-per-line 1) - (write-pixarray-1 - buf 0 pixarray x y width height padded-bytes-per-line)) - (image-swap-xy - buf obuf 0 boffset (index-ceiling width 8) - padded-bytes-per-line padded-bytes-per-line height - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p))) - -(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-image-xy-data - (buffer-obuf8 display) (buffer-boffset display) - bitmap src-x src-y width nlines - padded-bytes-per-line - 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-data (obuf 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 obuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray-1 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)) - (if (index= bits-per-pixel 1) - (write-image-xy-data - obuf boffset pixarray x y width height padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (unless (fast-write-pixarray - buf 0 pixarray x y width height - padded-bytes-per-line bits-per-pixel) - (funcall - (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)) - buf 0 pixarray x y width height padded-bytes-per-line)) - (image-swap-z - buf obuf 0 boffset - (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line - height bits-per-pixel - *image-byte-lsb-first-p* byte-lsb-first-p)))) - -(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-image-z-data - (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 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* ((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) - (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 :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad))) - -(defun z-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (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 :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad))) - -(defun image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (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) - (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) - (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) - (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)) - (unless (fast-write-pixarray - data index bitmap x y width height - padded-bytes-per-line 1) - (write-pixarray-1 - data index bitmap x y width height - padded-bytes-per-line)) - (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* :byte-lsb-first-p *image-byte-lsb-first-p* - :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*))) - -(defun image-xy->image-xy (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (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) - (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))) - (declare (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line bytes-total) - (type buffer-bytes data)) - (unless (fast-write-pixarray - data 0 (image-z-pixarray image) x y width height - padded-bytes-per-line - (image-z-bits-per-pixel image)) - (funcall - (ecase (image-z-bits-per-pixel image) - (1 #'write-pixarray-1) (4 #'write-pixarray-4) - (8 #'write-pixarray-8) (16 #'write-pixarray-16) - (24 #'write-pixarray-24) (32 #'write-pixarray-32)) - data 0 (image-z-pixarray image) x y width height - padded-bytes-per-line)) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :z-pixmap - :bits-per-pixel (image-z-bits-per-pixel image) - :bytes-per-line padded-bytes-per-line - :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p* - :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*))) - -(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) - (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 (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 (values image)) - (with-open-file (fstream pathname :direction :input) - (let ((line "") - (properties nil) - (name nil) - (name-end nil) - (*package* (find-package 'keyword)) - (*read-base* 10)) - (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 6) (#\a 10) (#\b 11) - (#\c 12) (#\d 13) (#\e 14) (#\f 15)) - :test #'char-equal)))) - ;; 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 :byte-lsb-first-p t :bit-lsb-first-p t - :pad 32 :left-pad left-pad)))))) - -(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) - (if (index> bits-per-pixel 1) - (image-swap-z - (image-x-data image) data 0 0 bytes-per-line - (image-x-bytes-per-line image) bytes-per-line - height bits-per-pixel - (image-x-byte-lsb-first-p image) t) - (image-swap-xy - (image-x-data image) data 0 0 bytes-per-line - (image-x-bytes-per-line image) bytes-per-line - height - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - 32 t t)) - (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 (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 (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 c21df68fdde12f1bcd9cfa3f79484a3a81947302..0000000000000000000000000000000000000000 --- a/clx/input.lisp +++ /dev/null @@ -1,1927 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;;; 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) - -(export '( - event-listen - queue-event - process-event - make-event-handlers - event-handler - event-case - event-cond - discard-current-event - request-error - value-error - window-error - pixmap-error - atom-error - cursor-error - font-error - match-error - drawable-error - access-error - alloc-error - colormap-error - gcontext-error - id-choice-error - name-error - length-error - implementation-error - request-error - resource-error - unknown-error - access-error - alloc-error - atom-error - colormap-error - cursor-error - drawable-error - font-error - gcontext-error - id-choice-error - illegal-request-error - length-error - match-error - name-error - pixmap-error - value-error - window-error - implementation-error - #-(or ansi-common-lisp CMU) type-error - closed-display - lookup-error - connection-failure - reply-length-error - reply-timeout - sequence-error - unexpected-reply - missing-parameter - invalid-font - device-busy - get-external-event-code - define-extension - extension-opcode - define-error - decode-core-error - declare-event - )) - -;; 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 (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 (values (or nil 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 (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. - (declare (type display display) - (type stringable name)) - (declare (values card8)) - (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))))) - ;; 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) - (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) - (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) - (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 (or 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 (or current-event (display-event-queue-head display)) - 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-event-queue-head 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) - ;; 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. - (subst display '%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 #'macroexpand get-code)) - variable))) - - (defun ,get-function (display event handler) - (declare (type display display) - (type reply-buffer event)) - (declare (type function handler) - (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) - (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) - (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) - (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 - (card32 time) - ((member16 :new-value :deleted) state)) - -(declare-event :selection-clear - (card16 sequence) - (card32 time) - (window (window event-window)) - (keyword selection) ;; keyword - ) - -(declare-event :selection-request - (card16 sequence) - (card32 time) - (window (window event-window) requestor) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :selection-notify - (card16 sequence) - (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) - (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) - (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))) - -(defvar *event-loop-version* 0) - -(defun dequeue-event (display event) - (declare (type display display) - (type reply-buffer event) - (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) - (ecase *event-loop-version* - ;; in version 0 discard-current-event dequeues the event. - (0 ) - ;; in version 1 event-loop-step-after dequeues the event. - (1 (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 ((*event-loop-version* 1) - (.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) - (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) - (ecase *event-loop-version* - ;; in version 0 discard-current-event dequeues the event. - (0 (setf (reply-next (the reply-buffer event)) - (dequeue-event display event))) - ;; in version 1 event-loop-step-after dequeues the event. - (1 )) - ;; 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) - (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) - (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) - (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) - (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 (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 #'(lambda (var) (list var)) 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 ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - (display - error-key - major - minor - sequence - current-sequence - 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 ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - (display - error-key - major - minor - sequence - current-sequence - asynchronous) - (:report report-request-error)) - -(define-condition resource-error (request-error) - (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) - (: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) - (: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) - (: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) - (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) - (:report (lambda (condition stream) - (format stream "Attempt to use closed display ~s" - (closed-display-display condition))))) - -(define-condition lookup-error (x-error) - (id display type 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 - minor-version - host - display - 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 - expected-length - 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 - 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 - req-sequence - 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 - msg-sequence - req-sequence - 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) - (: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) - (:report (lambda (condition stream) - (format stream "Can't access font ~s" (invalid-font-font condition))))) - -(define-condition device-busy (x-error) - (display) - (:report (lambda (condition stream) - (format stream "Device busy for display ~s" - (device-busy-display condition))))) - -(define-condition unimplemented-event (x-error) - (display - 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 - 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 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) - (: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 (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 fa829cdb2f35d927d08f117087d8c17606d88889..0000000000000000000000000000000000000000 --- a/clx/macros.lisp +++ /dev/null @@ -1,1078 +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) (find-package 'xlib))) - (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))) - (and (< ,value ,(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))) - (and (< ,value ,(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))) - (and (< ,value ,(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))) - (and (< ,value ,(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) - (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)))) - (do ((i 12) - (j 0 (1+ j))) - ((>= i 32)) - (case format - (8 (setf (aref sequence j) (read-card8 i)) - (incf i)) - (16 (setf (aref sequence j) (read-card16 i)) - (incf i 2)) - (32 (setf (aref sequence j) (read-card32 i)) - (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) - (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)) - ,(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) - (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) - (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) - (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) - (declare (values request-number)) - (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) - (declare (values request-number)) - (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))) - #+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)) - #+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 96832df3b2116c8af8c4b51758ceb2ee24a8889e..0000000000000000000000000000000000000000 --- a/clx/manager.lisp +++ /dev/null @@ -1,851 +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) - -(export '(wm-name ;These are all setf'able accessor functions - wm-icon-name - wm-client-machine - wm-command - wm-hints - wm-normal-hints - icon-sizes - wm-protocols - wm-colormap-windows - - wm-size-hints - wm-size-hints-p - make-wm-size-hints - wm-size-hints-user-specified-position-p - wm-size-hints-user-specified-size-p - wm-size-hints-min-width - wm-size-hints-min-height - wm-size-hints-max-width - wm-size-hints-max-height - wm-size-hints-width-inc - wm-size-hints-height-inc - wm-size-hints-min-aspect - wm-size-hints-max-aspect - wm-size-hints-base-width - wm-size-hints-base-height - wm-size-hints-win-gravity - - wm-hints - wm-hints-p - make-wm-hints - wm-hints-input - wm-hints-initial-state - wm-hints-icon-pixmap - wm-hints-icon-window - wm-hints-icon-x - wm-hints-icon-y - wm-hints-icon-mask - wm-hints-window-group - wm-hints-flags - - transient-for - - set-wm-properties - iconify-window - withdraw-window - - get-wm-class - set-wm-class - rgb-colormaps - - cut-buffer ;; Setf'able - rotate-cut-buffers - - ;; Obsolete - wm-zoom-hints - wm-size-hints-x - wm-size-hints-y - wm-size-hints-width - wm-size-hints-height - set-standard-properties - get-standard-colormap - set-standard-colormap - )) - -(defun wm-name (window) - (declare (type window window)) - (declare (values string)) - (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) - -(defsetf wm-name (window) (name) - (declare (type window window)) - (declare (values string)) - `(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 (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 (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 (values (or null name-string) (or null class-string))) - (let ((value (get-property window :WM_CLASS :type :STRING - :result-type 'string :transform #'card8->char))) - (declare (type (or null string) value)) - (when value - (let* ((name-len (position #.(card8->char 0) (the string value))) - (name (subseq (the string value) 0 name-len)) - (class (subseq (the string value) (1+ name-len) (1- (length value))))) - (values (and (plusp (length name)) name) - (and (plusp (length class)) class)))))) - -(defun set-wm-class (window resource-name resource-class) - (declare (type window window) - (type (or null stringable) resource-name resource-class)) - (set-string-property window :WM_CLASS - (concatenate 'string - (string (or resource-name "")) - #.(make-string 1 :initial-element (card8->char 0)) - (string (or resource-class "")) - #.(make-string 1 :initial-element (card8->char 0)))) - (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 (values list)) - (do* ((command-string (get-property window :WM_COMMAND :type :STRING - :result-type 'string :transform #'card8->char)) - (command nil) - (start 0 (1+ end)) - (end 0) - (len (length command-string))) - ((>= start len) (nreverse command)) - (setq end (position #.(card8->char 0) command-string :start start)) - (push (subseq command-string start end) command))) - -(defsetf wm-command set-wm-command) -(defun set-wm-command (window command) - ;; Uses PRIN1 to a string-stream with the following bindings: - ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil) - ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp)) - ;; each element of command is seperated with NULL characters. - ;; This enables (mapcar #'read-from-string (wm-command window)) - ;; to recover a lisp command. - (declare (type window window) - (type list command)) - (set-string-property window :WM_COMMAND - (with-output-to-string (stream) - (let ((*print-length* nil) - (*print-level* nil) - (*print-radix* nil) - (*print-base* 10.) - (*print-array* t) - (*package* (find-package 'lisp)) - #+ti (ticl:*print-structure* t)) - (dolist (c command) - (prin1 c stream) - (write-char #.(card8->char 0) stream))))) - 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 (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 (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 (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 (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) - ;; Defaulted T to put the burden of remembering these on widget programmers. - (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))) - - -(defun wm-normal-hints (window) - (declare (type window window)) - (declare (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 (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 (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 (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 (values (or null wm-size-hints))) - (when vector - (let ((usposition 0) ;User Specified position - (ussize 1) ;User Specified size - (pposition 2) ;Program specified position - (psize 3) ;Program specified size - (pminsize 4) ;Program specified minimum size - (pmaxsize 5) ;Program specified maximum size - (presizeinc 6) ;Program specified resize increments - (paspect 7) ;Program specfied min and max aspect ratios - (pbasesize 8) ;Program specified base size - (pwingravity 9) ;Program specified window gravity - ) - (let ((flags (aref vector 0)) - (hints (make-wm-size-hints))) - (declare (type card16 flags) - (type wm-size-hints hints)) - (when (or (logbitp usposition flags) - (logbitp pposition flags)) - (setf (wm-size-hints-user-specified-position-p hints) (logbitp usposition flags) - (wm-size-hints-x hints) (aref vector 1) - (wm-size-hints-y hints) (aref vector 2))) - (when (or (logbitp ussize flags) - (logbitp psize flags)) - (setf (wm-size-hints-user-specified-size-p hints) (logbitp usposition flags) - (wm-size-hints-width hints) (aref vector 3) - (wm-size-hints-height hints) (aref vector 4))) - (when (logbitp pminsize flags) - (setf (wm-size-hints-min-width hints) (aref vector 5) - (wm-size-hints-min-height hints) (aref vector 6))) - (when (logbitp pmaxsize flags) - (setf (wm-size-hints-max-width hints) (aref vector 7) - (wm-size-hints-max-height hints) (aref vector 8))) - (when (logbitp presizeinc flags) - (setf (wm-size-hints-width-inc hints) (aref vector 9) - (wm-size-hints-height-inc hints) (aref vector 10))) - (when (logbitp paspect 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 pbasesize flags) - (setf (wm-size-hints-base-width hints) (aref vector 15) - (wm-size-hints-base-height hints) (aref vector 16))) - (when (logbitp pwingravity flags) - (setf (wm-size-hints-win-gravity hints) - (decode-type (member-vector *win-gravity-vector*) (aref vector 17))))) - hints)))) - -(defun encode-wm-size-hints (hints) - (declare (type wm-size-hints hints)) - (declare (values simple-vector)) - (let ((usposition #b1) ;User Specified position - (ussize #b10) ;User Specified size - (pposition #b100) ;Program specified position - (psize #b1000) ;Program specified size - (pminsize #b10000) ;Program specified minimum size - (pmaxsize #b100000) ;Program specified maximum size - (presizeinc #b1000000) ;Program specified resize increments - (paspect #b10000000) ;Program specfied min and max aspect ratios - (pbasesize #b100000000) ;Program specfied base size - (pwingravity #b1000000000) ;Program specfied window gravity - ) - (let ((vector (make-array 18 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 18) vector) - (type card16 flags)) - (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) - (setq flags (if (wm-size-hints-user-specified-position-p hints) usposition pposition)) - (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)) - (setf flags (logior flags (if (wm-size-hints-user-specified-position-p hints) ussize psize)) - (aref vector 3) (wm-size-hints-width hints) - (aref vector 4) (wm-size-hints-height hints))) - - (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) - (setf flags (logior flags pminsize) - (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 flags (logior flags pmaxsize) - (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 flags (logior flags presizeinc) - (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 flags (logior flags paspect) - 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 flags (logior flags pbasesize) - (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 flags (logior flags pwingravity) - (aref vector 17) (encode-type - (member-vector *win-gravity-vector*) - (wm-size-hints-win-gravity 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 (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 - user-specified-size-p - 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 - 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 (or null boolean) user-specified-position-p user-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-input 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 - :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 user-specified-position-p (setf (wm-size-hints-user-specified-position-p size) - user-specified-position-p)) - (when user-specified-size-p (setf (wm-size-hints-user-specified-size-p size) - user-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 (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 (apply #'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 (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... -(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 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/provide.lisp b/clx/provide.lisp deleted file mode 100644 index d6c9066c7d9258ba9772fb694be21a7bd15e805d..0000000000000000000000000000000000000000 --- a/clx/provide.lisp +++ /dev/null @@ -1,41 +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>) -;;; - -(in-package :user) - -(provide :clx) - -;;; Load the defsystem file from the source directory. You may -;;; want to include an explicit extension (such as ".l" or ".lisp"). -;;; -(load "/src/local/clx/defsystem.l") - -;;; The binary files for a particular lisp implementation and architecture. -;;; -(let ((lisp - (or #+lucid "lucid" - #+excl "franz" - #+akcl "akcl" - #+kcl "kcl" - #+ibcl "ibcl" - (error "Can't figure out what lisp vendor this lisp is from."))) - (computer - (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" - #+(or sun4 sparc) "sparc" - #+(and hp (or mc68000 mc68020)) "hp9000-300" - #+vax "vax" - (error "Can't figure out what computer vendor this computer is from.")))) - (xlib:load-clx (format nil "/src/local/clx/~A.~A/" lisp computer))) diff --git a/clx/requests.lisp b/clx/requests.lisp deleted file mode 100644 index 5f6ce462db3f9783232d0ce1ab57d5af983db389..0000000000000000000000000000000000000000 --- a/clx/requests.lisp +++ /dev/null @@ -1,1590 +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) - -(export '(create-window - destroy-window - destroy-subwindows - add-to-save-set - remove-from-save-set - reparent-window - map-window - map-subwindows - unmap-window - unmap-subwindows - circulate-window-up - circulate-window-down - query-tree - intern-atom - find-atom - atom-name - change-property - delete-property - get-property - rotate-properties - list-properties - set-selection-owner - selection-owner - selection-owner - convert-selection - send-event - grab-pointer - ungrab-pointer - grab-button - ungrab-button - change-active-pointer-grab - grab-keyboard - ungrab-keyboard - grab-key - ungrab-key - allow-events - grab-server - ungrab-server - with-server-grabbed - query-pointer - pointer-position - global-pointer-position - motion-events - translate-coordinates - warp-pointer - warp-pointer-relative - warp-pointer-if-inside - warp-pointer-relative-if-inside - set-input-focus - input-focus - query-keymap - create-pixmap - free-pixmap - clear-area - copy-area - copy-plane - create-colormap - free-colormap - copy-colormap-and-free - install-colormap - uninstall-colormap - installed-colormaps - alloc-color - alloc-color-cells - alloc-color-planes - free-colors - store-color - store-colors - query-colors - lookup-color - create-cursor - create-glyph-cursor - free-cursor - recolor-cursor - query-best-cursor - query-best-tile - query-best-stipple - query-extension - list-extensions - change-keyboard-control - keyboard-control - bell - pointer-mapping - set-pointer-mapping - pointer-mapping - change-pointer-control - pointer-control - set-screen-saver - screen-saver - activate-screen-saver - reset-screen-saver - add-access-host - remove-access-host - access-hosts - access-control - set-access-control - access-control - close-down-mode - set-close-down-mode - kill-client - kill-temporary-clients - no-operation - )) - -(defun create-window (&key - (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 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 (values window)) - (let* ((display (window-display parent)) - (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 (values (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 (values resource-id)) - (let ((keyword (if (keywordp name) name (kintern (string name))))) - (declare (type keyword keyword)) - (or (atom-id keyword display) - (let ((string (symbol-name keyword))) - (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 keyword 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 (values (or null resource-id))) - (let ((keyword (if (keywordp name) name (kintern (string name))))) - (declare (type keyword keyword)) - (or (atom-id keyword display) - (let ((string (symbol-name keyword))) - (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 keyword display) id)) - id))))) - -(defun atom-name (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (declare (values keyword)) - (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 t transform)) ;(or null (function (t) integer)) - (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 t transform)) ;(or null (function (integer) t)) - (declare (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 (values (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 (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 (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 (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 (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 (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 (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 (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 (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 :parent :pointer-root) revert-to) - (type timestamp time)) - (with-buffer-request (display *x-setinputfocus*) - ((data (member :none :parent :pointer-root)) revert-to) - ((or window (member :none :pointer-root)) focus) - ((or null card32) time))) - -(defun input-focus (display) - (declare (type display display)) - (declare (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 (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 - (width (required-arg width)) - (height (required-arg height)) - (depth (required-arg depth)) - (drawable (required-arg drawable))) - (declare (type card8 depth) ;; required - (type card16 width height) ;; required - (type drawable drawable)) ;; required - (declare (values pixmap)) - (let* ((display (drawable-display drawable)) - (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 (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 (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 (values (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 (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 12) - :green (rgb-val-get 14) - :blue (rgb-val-get 16)) - (make-color :red (rgb-val-get 18) - :green (rgb-val-get 20) - :blue (rgb-val-get 22))))))))) - -(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 (values (sequence pixel) (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 (values (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)) - (pixel (car spec) (car spec)) - (color (cadr spec) (cadr spec))) - ((endp spec)) - (store-color colormap pixel color :red-p red-p :green-p green-p :blue-p blue-p))) - (vector - (do* ((i 0 (+ i 2)) - (len (length specs)) - (pixel (aref specs i) (aref specs i)) - (color (aref specs (1+ i)) (aref specs (1+ i)))) - ((>= i len)) - (store-color colormap pixel color :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 (values (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 (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 (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 (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 (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 (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 (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 (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 (values (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 (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 (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) - (inline rationalize16)) - (flet ((rationalize16 (number) - ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers - (declare (type number number) - (inline rationalize16)) - (declare (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)))))) - - (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 (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 (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 (values (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 (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 (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 743c14f46aa5c20c059b2a1495da6d7e0d9398a9..0000000000000000000000000000000000000000 --- a/clx/resource.lisp +++ /dev/null @@ -1,713 +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) - -(export '(resource-database - resource-database-timestamp - make-resource-database - resource-key - get-resource - get-search-table - get-search-resource - add-resource - delete-resource - map-resource - merge-resources - read-resources - write-resources - wm-resources - set-wm-resources - root-resources)) - -#+clue ;; for CLUE only -(defparameter *resource-subclassp* nil - "When non-nil and no match found, search superclasses.") - -;; 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) - (princ (resource-database-name database) stream) - (when (resource-database-value database) - (princ " " 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)))) - ))) - -(defun resource-key (stringable) - ;; Ensure STRINGABLE is a keyword. - (declare (type stringable stringable)) - (if (symbolp stringable) - (if (keywordp (the symbol stringable)) - stringable - (kintern (symbol-name (the symbol stringable)))) - (kintern (#-excl string-upcase - #+excl correct-case - (the string stringable))))) - -(defun stringable-equal (a b) - ;; Compare two stringables. - ;; Ignore case when comparing to a symbol. - (declare (type stringable a b)) - (declare (values boolean)) - (if (symbolp a) - (if (symbolp b) - (string= (the string (symbol-name (the symbol a))) - (the string (symbol-name (the symbol b)))) - (string-equal (the string (symbol-name (the symbol a))) - (the string b))) - (if (symbolp b) - (string-equal (the string a) - (the string (symbol-name (the symbol b)))) - (string= (the string a) - (the string 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 list name-list) ;; (list stringable) - (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 list name-list)) ;; (list stringable) - (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 list full-name full-class)) ;; (list stringable) - (declare (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))) - #+clue ;; for CLUE only - ((and *resource-subclassp* - (or loose tight) - (dolist (class (cluei::class-all-superclasses class)) - (when tight - (when (setq result - (get-entry-lookup tight class names classes)) - (return result))) - (when loose - (when (setq result - (get-entry-lookup loose class names classes)) - (return result)))))) - (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)) - #+clue ;; for CLUE only - (when *resource-subclassp* - (dolist (class (cluei::class-all-superclasses class)) - (when (setq result - (get-entry-lookup loose class names classes)) - (return-from get-entry 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 list full-name full-class)) ;; (list stringable) - (declare (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)) - #+clue ;; for CLUE only - (when *resource-subclassp* - (dolist (class (cluei::class-all-superclasses class)) - (declare (type symbol class)) - (setq class class) - (when tight - (get-tables-lookup tight class names classes)) - (when loose - (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)) - #+clue ;; for CLUE only - (when *resource-subclassp* - (dolist (class (cluei::class-all-superclasses 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) - (downward-funarg function) - (dynamic-extent args)) - (declare (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) - (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 (values resource-database)) - (map-resource #'add-resource database with-database) - with-database) - -(defun char-memq (key char) - ;; Used as a test function for POSITION - (declare (type string-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 - (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 (values resource-database)) - (resource-with-open-file (stream pathname) - (loop - (let ((string (read-line stream nil :eof))) - (declare (type string 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)) - (if (not (string-equal string "#INCLUDE" :start1 i :end1 term)) - (format t "~%Resource File error. Ignoring: ~a" string) - (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 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 (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))))))) - (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 (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) - (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) - (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 f8c843ebcf384bed2dec992ce8744ec8261a2c07..0000000000000000000000000000000000000000 --- a/clx/socket.c +++ /dev/null @@ -1,144 +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 */ -void bcopy(); - -/* - * 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); - 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 */ - 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; - bcopy((char *)host_ptr->h_addr, - (char *)&inaddr.sin_addr, - sizeof(inaddr.sin_addr)); - } - 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 59415101c25ec69c862d076d8662653e2aec0417..0000000000000000000000000000000000000000 --- a/clx/text.lisp +++ /dev/null @@ -1,1083 +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) - -(export '( - translation-function - translate-default - text-extents - text-width - draw-glyph - draw-glyphs - draw-image-glyph - draw-image-glyphs - display-keycode-range - set-modifier-mapping - modifier-mapping - keysym - change-keyboard-mapping - keyboard-mapping - keyboard-mapping - )) - -;; 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 (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) - (downward-funarg #+Genera * #-Genera translate)) - (declare (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 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))) - ((type? new-font 'font) (setq font 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))))))) - - (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) - (downward-funarg #+Genera * #-Genera translate)) - (declare (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 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))) - ((type? new-font 'font) (setq font 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))))) - (values width next-start))) - -#+clx-little-endian -(defun byte-swap-card16 (card16) - (declare (type card16 card16)) - (declare (values card16)) - (dpb card16 (byte 8 8) (ash card16 -8))) - -(defun text-extents-server (font string start end) - (declare (type font font) - (type string string) - (type array-index start end)) - (declare (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 card16 :start start :end end :appending t - #+clx-little-endian :transform - #+clx-little-endian ;; Byte swap for little-endian - #'byte-swap-card16) - 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 (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 card16 :start start :end end :appending t - #+clx-little-endian :transform - #+clx-little-endian ;; Byte swap for little-endian - #'byte-swap-card16) - 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 (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) - (array-register 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 0) - (descent 0) - (left #x7fff) - (right 0)) - ((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 0) - (descent 0) - (left #x7fff) - (right 0)) - ((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) - (downward-funarg #+Genera * #-Genera translate)) - (declare (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) - (downward-funarg #+Genera * #-Genera translate)) - (declare (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 int32 x y width) - (type array-index start end) - (type sequence sequence)) - (declare (values (or null array-index) (or null int32))) - (declare (type translation-function translate) - (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 end) - (type int32 width) - (type sequence sequence)) - (declare (values (or null array-index) (or null int32))) - (declare (type translation-function translate) - (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-card16 display (index+ boffset 2) buffer 0 dst-chunk - #+clx-little-endian ;; Byte swap for little-endian - #'byte-swap-card16) - (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) - (downward-funarg #+Genera * #-Genera translate)) - (declare (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 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 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) - (downward-funarg #+Genera * #-Genera translate)) - (declare (values (or null array-index) (or null int32))) - (unless end (setq end (length sequence))) - (ecase size - ((:default 8) - (draw-image-glyphs8 drawable gcontext x y sequence start end width translate)) - (16 - (draw-image-glyphs16 drawable gcontext x y sequence start end width translate)))) - -(defun draw-image-glyphs8 (drawable gcontext x y sequence start end width translate) - ;; 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) - (downward-funarg translate)) - (declare (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 width translate) - ;; 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) - (downward-funarg translate)) - (declare (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-card16 display (index+ buffer-boffset 16) buffer 0 chunk - #+clx-little-endian ;; Byte swap for little-endian - #'byte-swap-card16) - ;; 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 (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 (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 (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 (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 18434e4ba55512f02e99bdeb91a7008988bcd3c9..0000000000000000000000000000000000000000 --- a/clx/translate.lisp +++ /dev/null @@ -1,619 +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) - -(export '(define-keysym-set - keysym-set - define-keysym - undefine-keysym - default-keysym-translate - keysym - character->keysyms - keycode->keysym - keysym->character - default-keysym-index - keycode->character - state-keysym-p - mapping-notify - keysym-in-map-p - character-in-map-p - keysym->keycodes - )) - -(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) - (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) - (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 list) ; (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 string-char t) object) - (type keysym keysym) - (type (or null mask16 list) ;; (list (or keysym state-mask-key)) - modifiers) - (type (or null (member :modifiers) mask16 list) ;; (list (or keysym state-mask-key)) - mask) - (type (or null display) display) - (type (or null keysym) lowercase) - (type (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 (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 string-char t) object) - (type keysym keysym) - (type (or null mask16 list) ;; (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 (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 (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) - (values (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 (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) - (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 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 card16 state)) - (declare (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 (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 (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-translate (display state object) - ;; 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: - ;; (string-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)) - (declare (values t)) ;; Object returned by keycode->character - (macrolet ((keystate-p (state keyword) - `(the boolean - (logbitp ,(position keyword *state-mask-vector*) - ,state)))) - (when (characterp object) - (when (keystate-p state :control) - (setf (char-bit object :control) 1)) - (when (state-keysymp display state left-meta-keysym) - (setf (char-bit object :meta) 1)) - (when (state-keysymp display state left-super-keysym) - (setf (char-bit object :super) 1)) - (when (state-keysymp display state left-hyper-keysym) - (setf (char-bit object :hyper) 1)))) - object) - -(defun default-keysym-index (display keycode state) - ;; Returns a keysym-index for use with keycode->character - (declare (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 (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 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 (string-char card16 boolean card8) card8)) - keysym-index-function)) - (declare (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 (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 (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 (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 (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 e4837681e78f41ccd6ab26a6e97a2c7999166481..0000000000000000000000000000000000000000 --- a/code/alieneval.lisp +++ /dev/null @@ -1,1278 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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 any the part of the Alien implementation that -;;; is not part of the compiler. -;;; -(in-package 'lisp) -(in-package 'system) -(export '(*alien-eval-when* make-alien alien-type alien-size alien-address - copy-alien dispose-alien defalien alien-value - alien-bind defoperator alien-index alien-indirect - bits bytes words long-words port perq-string - boolean defenumeration enumeration - system-area-pointer pointer alien alien-access - alien-assign alien-sap define-alien-stack - with-stack-alien null-terminated-string c-procedure - unstructured)) -(in-package 'lisp) - -(defun concat-pnames* (name1 name2) - (if name1 - (make-symbol (concatenate 'simple-string (symbol-name name1) - (symbol-name name2))) - name2)) - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* :both)) - -;;; The number of bits corresponding to a change of 1 in the value of a SAP. -;;; -(defconstant alien-address-unit 8) - -;;; The address pointed to by the SAP in an alien is always a multiple of this -;;; number of bits. -;;; -(defconstant alien-alignment 16) - -(defvar *alien-eval-when* '(compile load eval) - "This is a list of the times to eval Alien compiler info.") - -(defun %print-alien-value (s stream d) - (declare (ignore d)) - (let ((offset (alien-value-offset s))) - (format stream - "#<Alien value, Address = #x~X~:[+~D/8~;~*~], Size = ~D, Type = ~S>" - (%primitive sap-int (alien-value-sap s)) (zerop offset) offset - (alien-value-size s) (alien-value-type s)))) - -(defun %print-alien-info (s stream d) - (declare (ignore s d)) - (write-string "#<Alien-Info>" stream)) - - -;;;; Interpreter stubs for SAP functions: - -#+new-compiler (progn -(defun sap-int (sap) - "Converts a System Area Pointer into an integer." - (sap-int sap)) - -(defun int-sap (int) - "Converts an integer into a System Area Pointer." - (int-sap int)) - -(defun sap-ref-8 (sap offset) - "Returns the 8-bit byte at Offset bytes from SAP." - (sap-ref-8 sap offset)) - -(defun sap-ref-16 (sap offset) - "Returns the 16-bit word at Offset words from SAP." - (sap-ref-16 sap offset)) - -(defun sap-ref-32 (sap offset) - "Returns the 32-bit dualword at Offset words from SAP." - (sap-ref-32 sap offset)) - -(defun (setf sap-ref-8) (sap offset new-value) - (setf (sap-ref-8 sap offset) new-value)) - -(defun (setf sap-ref-16) (sap offset new-value) - (setf (sap-ref-16 sap offset) new-value)) - -(defun (setf sap-ref-32) (sap offset new-value) - (setf (sap-ref-32 sap offset) new-value)) - -); #+New-Compiler - - -;;;; Miscellaneous primitives: - -;;; Alien-Assign -- Public -;;; -;;; Just blt the bytes from one to the other... -;;; -(defun alien-assign (to-alien from-alien) - "Copy the data in From-Alien into To-Alien. The two alien values - must be of the same size and type." - (declare (type alien-value to-alien from-alien)) - (unless (equal (alien-value-type to-alien) (alien-value-type from-alien)) - (error "Arguments to Alien-Assign are of different types:~%~S~%~S" - to-alien from-alien)) - (let ((size (alien-value-size to-alien)) - (src-off (alien-value-offset from-alien)) - (dst-off (alien-value-offset to-alien))) - (unless (= size (alien-value-size from-alien)) - (error "Arguments to Alien-Assign are of different sizes:~%~S~%~S" - to-alien from-alien)) - (unless (zerop (logand size 7)) - (error "Size of assigned Alien is not a byte multiple:~%~S" - from-alien)) - (unless (zerop (logand src-off 7)) - (error "Alien is not byte aligned:~%~S" from-alien)) - (unless (zerop (logand dst-off 7)) - (error "Alien is not byte aligned:~%~S" to-alien)) - (let ((dst-start (ash dst-off -3))) - (%primitive byte-blt (alien-value-sap from-alien) (ash src-off -3) - (alien-value-sap to-alien) dst-start - (+ dst-start (ash size -3)))) - to-alien)) - - -;;; Alien-Type, Alien-Size, Alien-Address, Alien-SAP -- Public -;;; -;;; Return the corresponding fields out of the Alien-Value structure. -;;; Convert the address back into rational form. -;;; -(defun alien-type (alien) - "Return the type of the Alien Value." - (check-type alien alien-value) - (alien-value-type alien)) - -(defun alien-size (alien) - "Return the size in bits of the Alien." - (check-type alien alien-value) - (alien-value-size alien)) - -(defun alien-address (alien) - "Return the address of the data for Alien." - (check-type alien alien-value) - (+ (%primitive sap-int (alien-value-sap alien)) - (/ (alien-value-offset alien) alien-address-unit))) - -(defun alien-sap (alien) - "Return the system-area-pointer which corresponds to Alien. Signal an - error if the alien's address is not word-aligned." - (check-type alien alien-value) - (unless (zerop (alien-value-offset alien)) - (error "Argument to Alien-SAP is not word-aligned:~%~S" alien)) - (alien-value-sap alien)) - - -;;;; Interface macros: - -;;; Defalien -- Public -;;; -;;; Dump the right compiler info and code to create the value at -;;; load-time. -;;; -(defmacro defalien (name type size &optional (address :static)) - "defalien Name Type Size [address] - Define a global Alien variable with the specified Name, Type, Size and - Address. If Address is not supplied allocate storage to hold it." - `(progn - (eval-when (load eval) - (defparameter ,name (make-alien ',type ,size ,address))) - (eval-when ,*alien-eval-when* - (setf (info variable alien-value ',name) - (make-ct-a-val - :type ',type - :size ,size - :offset ,(if (numberp address) - (rem (* address alien-address-unit) alien-alignment) - 0) - :sap `(alien-value-sap ,',name) - :alien ',name))))) - - -;;; Define-Alien-Stack -- Public -;;; -;;; Define some variables and a function to grow the stack. Put good -;;; stuff on the property list. -;;; -(defmacro define-alien-stack (name type size) - "Define-Stack-Alien Name Type Size - Defines a new alien stack for use with the With-Stack-Alien macro. - The aliens have the specifed Type and Size, and are static." - (let ((n-head (concat-pnames name '-alien-stack-head)) - (n-current (concat-pnames name '-alien-stack)) - (grow-fun (concat-pnames name '-grow-stack))) - `(progn - (eval-when ,*alien-eval-when* - (setf (info alien-stack info ',name) - (make-stack-info :head ',n-head :current ',n-current - :grow ',grow-fun :type ',type - :size ,size))) - (defvar ,n-head ()) - (defvar ,n-current ()) - (defun ,grow-fun () - (let ((new (list (make-alien ',type ,size :static)))) - (setq ,n-head (nconc ,n-head new) ,n-current new) - (car new)))))) - - -;;; Defoperator -- Public -;;; -;;; Make the Alien-Info for the compiler and the function for the -;;; interpreter. -;;; -(defmacro defoperator ((name result-type) args body) - (do ((arg args (cdr arg)) - (argnames ()) - (arg-types ()) - (n 0 (1+ n))) - ((null arg) - `(eval-when ,*alien-eval-when* - (setf (info function alien-operator ',name) - (make-alien-info #'(lambda ,(nreverse argnames) ,body) - ,(length args) ',arg-types ',result-type)) - (setf (info function source-transform ',name) - #'c::alien=>lisp-transform) - (defun ,name (&rest dummy-arglist) - (displace-operator-definition ',name dummy-arglist)))) - (cond - ((symbolp (car arg)) - (push (car arg) argnames)) - (t - (push (cons n (cadar arg)) arg-types) - (push (caar arg) argnames))))) - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* nil)) - - -;;;; Alien allocation: - -(eval-when (compile) - (dolist (x '(system-space-start alien-allocation-end)) - (remprop x 'lisp::%constant))) - -;;; In order to improve memory locality static alien values are allocated -;;; contiguously in a pre-validated area at the beginning of system space. We -;;; keep a free pointer to the next word we can allocate. -;;; -(defparameter system-space-start - (%primitive make-immediate-type 0 %static-alien-area) - "The address of the first statically allocated alien.") - -(defparameter alien-allocation-end - (%primitive make-immediate-type #x40000 %static-alien-area) - "The end of statically allocated aliens.") - -(defvar *current-alien-free-pointer* system-space-start - "The next word in system space for static alien allocation.") - -;;; Allocate-Static-Alien -- Internal -;;; -;;; Allocate enough storage to hold the specified number of bits -;;; and return the address. -;;; -(defun allocate-static-alien (bits) - (declare (fixnum bits)) - (let* ((alien *current-alien-free-pointer*) - (bytes (logand (ash (the fixnum (+ bits 31)) -3) (lognot 3))) - (new (%primitive sap+ *current-alien-free-pointer* bytes))) - (when (%primitive pointer> new alien-allocation-end) - (error "Not enough room to allocate a ~D bit alien." bits)) - (setq *current-alien-free-pointer* new) - alien)) - - -;;; DO-VALIDATE -- Internal Interface. -;;; -;;; Do a ValidateMemory on our kernel port and flame out if error. -;;; -;;; Hemlock and other code files use this, even though it is not exported from -;;; a more appropriate package. -;;; -(defun do-validate (addr bytes mask) - (gr-call* mach::vm_allocate *task-self* addr bytes (if (eq mask -1) t NIL))) - - -;;; Make-Alien -- Public -;;; -;;; Create an Alien value structure, validating memory to hold the data -;;; if necessary. We convert the rational address into a word address + -;;; bit offset. -;;; -(defun make-alien (type size &optional (address :dynamic)) - "Return an Alien value of the specified Type, whose size is Size bits. - Address is the word address of the value to create, if this is not - supplied then memory is allocated to contain the data." - (case address - (:dynamic - (setq address (do-validate 0 (ash size -3) -1))) - (:static - (setq address (allocate-static-alien size))) - (t - (if (not (integerp address)) - (setq address (%primitive sap-int address))) - (check-type address (rational 0)))) - (check-type size (integer 0)) - (if (numberp address) - (multiple-value-bind (base frac) (truncate address) - (let ((offset (* frac alien-address-unit))) - (unless (integerp frac) - (error "Address ~S does not fall on a bit position." address)) - (make-alien-value (%primitive int-sap base) offset size type))) - (make-alien-value address 0 size type))) - - -;;; Copy-Alien -- Public -;;; -;;; Validate some memory and byte-blt the contents to it. Since we just move -;;; words we preserve a nonzero bit-offset when it might be desirable to -;;; eliminate it, but that is more trouble than it is worth, since non-aligned -;;; fields are probably rarely copied. -;;; -(defun copy-alien (alien) - "Copy the storage pointed to by Alien and return a new alien value that - describes it." - (check-type alien alien-value) - (let* ((offset (alien-value-offset alien)) - (length (alien-value-size alien)) - (bytes (ash (+ length offset 15) -3)) - (new (%primitive int-sap (do-validate 0 bytes -1)))) - (%primitive byte-blt (alien-value-sap alien) (ash offset -3) - new 0 bytes) - (make-alien-value new offset length (alien-value-type alien)))) - - -;;; Dispose-Alien -- Public -;;; -;;; Invalidate the memory pointed to by unless it is a statically -;;; allocated alien. -;;; -(defun dispose-alien (alien) - "Release the storage allocated for Alien." - (check-type alien alien-value) - (let ((address (alien-value-sap alien))) - (unless (not (or (%primitive pointer< address system-space-start) - (%primitive pointer> address alien-allocation-end))) - (gr-call mach:vm_deallocate *task-self* address - (logand #x-200 (ash (+ (alien-value-size alien) #xFFF) -3)))))) - - -;;;; Operator definition primitives: - -;;; Alien-Index -- Public -;;; -;;; Check that the selected field fits within the Alien, and add it -;;; in if it does. -;;; -(defun alien-index (alien offset size) - "Return a new Alien value that is Offset bits within Alien, and is - Size bits long." - (check-type alien alien-value) - (check-type offset (integer 0)) - (check-type size (integer 0)) - (when (> (+ offset size) (alien-value-size alien)) - (error "~S is too small to extract a ~A bit field at ~A." - alien size offset)) - (multiple-value-bind (words bits) - (truncate (+ offset (alien-value-offset alien)) 8) - (make-alien-value - (%primitive int-sap (+ words (%primitive sap-int (alien-value-sap alien)))) - bits - size - nil))) - -;;; Alien-Indirect -- Public -;;; -;;; Check that Alien is word-aligned and 32 bits long. If it is, grab -;;; the value. Check that the value falls within the system area. If -;;; it does then make a new Alien-Value out of it. -;;; -(defun alien-indirect (alien size) - "Return a new Alien value that points to what the value of Alien points to - which is Size bits long." - (check-type alien alien-value) - (check-type size (integer 0)) - (unless (= (alien-value-size alien) 32) - (error "~S is not thirty-two bits long." alien)) - (unless (zerop (alien-value-offset alien)) - (error "~S is not word aligned.")) - (let* ((sap (alien-value-sap alien)) - (value (logior (ash (%primitive 16bit-system-ref sap 0) 16) - (%primitive 16bit-system-ref sap 1)))) -#| - (unless (<= system-space-start value most-positive-fixnum) - (error "The value of ~S, #x~X, does not point into system space." - alien value)) -|# - (make-alien-value (%primitive int-sap value) 0 size nil))) - - -;;; Bits, Bytes, Words, Long-Words -- Public -;;; -;;; -(macrolet ((frob (name n) - `(progn - (proclaim '(inline ,name)) - (defun ,name (n) - (declare (type (integer 0 ,(truncate most-positive-fixnum n)) - n)) - (* n ,n))))) - (frob bits 1) - (frob bytes 8) - (frob words 16) - (frob long-words 32)) - - -;;;; General case versions of compiler internal functions: - -;;; %Alien-Indirect -- Internal -;;; -;;; Alien-Indirect is transformed into this. Calls can take place at -;;; run-time when the operation can't be proven safe at compile time. -;;; -(defun %alien-indirect (size sap offset exp) - (unless (eql size 32) - (error "Argument to Alien-Indirect is ~D bits, 32:~% ~S." size exp)) - (unless (zerop (logand offset #x1F)) - (error "Offset ~D to Alien-Indirect is not long-word-aligned:~% ~S." - offset exp)) - (%primitive sap-system-ref sap (ash offset -4))) - - -;;; %Aligned-SAP -- Internal -;;; -;;; Various things transform into this when the alien is declared to be -;;; aligned. In this case, we absorb the offset into the SAP, and make the -;;; bound offset 0. -;;; -(defun %aligned-sap (sap offset form) - (unless (zerop (logand offset #xF)) - (error "Offset ~S was declared to be word aligned, but isn't:~% ~S" - offset form)) - (%primitive sap+ sap (ash offset -3))) - -#+new-compiler -;;; Naturalize-Integer -- Internal -;;; -;;; Read a possibly signed integer somewhere. For the 16 and 32 bit -;;; cases we let the transform do the work, for random fields we do it -;;; by hand. -;;; -(defun naturalize-integer (signed sap offset size form) - (multiple-value-bind (q r) (truncate offset 16) - (cond - ((> size 15) - (unless (zerop r) - (error "Offset ~D for ~D bit access is not word-aligned:~% ~S" - offset size form)) - (case size - (32 - (if signed - (%primitive signed-32bit-system-ref sap (ash q 4)) - (%primitive unsigned-32bit-system-ref sap (ash q 4)))) - (16 - (if signed - (naturalize-integer t sap (ash q 4) 16 nil) - (naturalize-integer nil sap (ash q 4) 16 nil))) - (t - (error "Access of ~D bit integers is not supported." size)))) - (t - (when (> (+ size r) 16) - (error "~D bit field at ~D offset crosses a word boundry:~% ~S" - size offset form)) - (if signed - (let ((val (ldb (byte size (- 16 size r)) - (%primitive 16bit-system-ref sap q)))) - (if (logbitp val (1- size)) - (logior val (ash -1 size)) - val)) - (ldb (byte size (- 16 size r)) - (%primitive 16bit-system-ref sap q))))))) - -#+new-compiler -;;; Deport-Integer -- Internal -;;; -;;; Like Naturalize-Integer, but writes an integer. -;;; -(defun deport-integer (signed sap offset size value form) - (declare (ignore signed)) - (multiple-value-bind (q r) (truncate offset 16) - (declare (fixnum r)) - (cond - ((> size 15) - (unless (zerop r) - (error "Offset ~D for ~D bit store is not word-aligned:~% ~S" - offset size form)) - (case size - (32 - (%primitive signed-32bit-system-set sap q value)) - (16 - (%primitive 16bit-system-set sap q value)) - (t - (error "Storing of ~D bit integers is not supported:~% ~S" - size form)))) - ((= size 8) - (setq q (ash q 1)) - (when (= r 8) - (setq q (1+ q)) - (setq r 0)) - (when (/= r 0) - (error "8 bit field at ~D offset crosses a byte boundary:~% ~S" - offset form)) - (%primitive 8bit-system-set sap q value)) - ((> size 7) - (when (> (+ size r) 16) - (error "~D bit field at ~D offset crosses a word boundry:~% ~S" - size offset form)) - (%primitive 16bit-system-set sap q - (dpb value (byte size (- 16 size r)) - (%primitive 16bit-system-ref sap q)))) - (T - (multiple-value-bind (nq nr) (truncate offset 8) - (when (> (+ size nr) 8) - (error "~D bit field at ~D offset crosses a byte boundry:~% ~S" - size offset form)) - (%primitive 8bit-system-set sap nq - (dpb value (byte size (- 8 size nr)) - (%primitive 8bit-system-ref sap nq))))))) - nil) - - -;;; Naturalize and Deport Boolean -- Internal -;;; -;;; Handle the general case of boolean access. The transforms -;;; should pick off the normal cases. -;;; -#+new-compiler -(defun naturalize-boolean (sap offset size form) - (declare (notinline naturalize-integer)) - (not (zerop (naturalize-integer nil sap offset size form)))) -;;; -#+new-compiler -(defun deport-boolean (sap offset size value form) - (declare (notinline deport-integer)) - (deport-integer nil sap offset size (if value 1 0) form) - nil) - -;;; Check<=, Check= -- Internal -;;; -;;; Interpreter stubs for functions normally open-coded. Note that the -;;; compiler will constant-fold these, possibly producing an error at compile -;;; time. -;;; -(defun check<= (x y) (check<= x y)) -(defun check= (x y) - #| - (check= x y) - |# - ;### Bootstrap hack: - (unless (and (fixnump x) (>= x 0) - (fixnump y) (>= y 0) - (= x y)) - (error "Not ~S not = to ~S at compile time." x y))) - - -;;;; Utility functions used by macros and special forms: - -;;; Check-Alien-Type -- Internal -;;; -;;; Check that Alien is of the specified Alien type, and give an -;;; error if it is not. -;;; -(defun check-alien-type (alien type) - (unless (alien-value-p alien) - (error "~S is not an Alien value." alien)) - (unless (equal (alien-value-type alien) type) - (error "Wrong Alien type ~S, should have been of type ~S." - (alien-value-type alien) type)) - alien) - - -;;; Assert-Alien-Type -- Internal -;;; -;;; Make a new Alien value having the specified type. -;;; -(defun assert-alien-type (alien type) - (unless (alien-value-p alien) - (error "~S is not an Alien value." alien)) - (make-alien-value (alien-value-sap alien) - (alien-value-offset alien) - (alien-value-size alien) - type)) - - -;;; Displace-Operator-Definition -- Internal -;;; -;;; To save space and load & compile time for defoperators, we don't -;;; actually generate the function for the operator until it is called. -;;; This results in a significant space savings at the cost of -;;; always running the operator definition interpreted when called -;;; that way. -;;; -(defun displace-operator-definition (name actual-args) - (let ((info (info function alien-operator name))) - (unless info - (error "Operator ~S has no Alien-Operator-Info property.")) - (let ((num-args (alien-info-num-args info)) - (arg-types (alien-info-arg-types info))) - (do ((i 0 (1+ i)) - (args ()) - (binds ())) - ((= i num-args) - (let* ((args (nreverse args)) - (res (coerce `(lambda ,args - (alien-bind ,(nreverse binds) - (assert-alien-type - ,(apply (alien-info-function info) args) - ',(alien-info-result-type info)))) - 'function))) - (setf (symbol-function name) res) - (apply res actual-args))) - (let ((type (assoc i arg-types)) - (sym (gensym))) - (push sym args) - (if type - (push `(,sym ,sym ,(cdr type)) binds))))))) - - -;;;; Alien access method definition: -;;; -;;; We describe how to access and store at an Alien's address in -;;; a way that permits the same code to be use both for the compiler -;;; and the interpreter. What we do is have experts that ask things -;;; about the alien value and return a piece of code to do the access. -;;; -;;; -(defvar *alien-access-table* (make-hash-table :test #'eq) - "Hashtable from lisp types to Alien access functions.") -(defvar *alien-only-access-table* (make-hash-table :test #'eq) - "Hashtable from alien types to Alien access functions.") -(defvar *alien-to-lisp-types* (make-hash-table :test #'eq) - "Hashtable we use to tell whether there is a unique lisp-type - for a given alien-type.") - -(defmacro mostcar (x) - `(if (listp ,x) (car ,x) ,x)) - - -;;; %Define-Alien-Access -- Internal -;;; -(defun %define-alien-access (lisp-type atypes fun) - (dolist (type atypes) - (let ((res (gethash type *alien-to-lisp-types*))) - (cond ((not res) - (setf (gethash type *alien-to-lisp-types*) lisp-type)) - ((eq res lisp-type)) - (t - (setf (gethash type *alien-to-lisp-types*) '%conflict%)))) - - (setf (gethash type *alien-only-access-table*) fun) - (setf (gethash lisp-type *alien-access-table*) fun))) - - -;;; Get-Alien-Access-Method -- Internal -;;; -;;; Returns the alien-access method corresponding to Alien-Type and -;;; Lisp-Type or dies trying. -;;; -(defun get-alien-access-method (alien-type lisp-type) - (let* ((alien-type (mostcar alien-type)) - (lisp-type (mostcar lisp-type)) - (unique? (gethash alien-type *alien-to-lisp-types*))) - (cond - ((not unique?) - (error "Alien type ~S does not correspond to any Lisp type." alien-type)) - ((and (null lisp-type) - (not (eq unique? '%conflict%)) - (gethash alien-type *alien-only-access-table*))) - ((not (eq unique? '%conflict%)) - (gethash unique? *alien-access-table*)) - ((not lisp-type) - (error "Lisp-Type must be specified with Alien type ~S." alien-type)) - ((gethash lisp-type *alien-access-table*)) - (t - (error "~S is not a Lisp-Type known to Alien-Access." - lisp-type))))) - - -;;; Define-Alien-Access -- Internal -;;; -(defmacro define-alien-access ((lisp-type &optional (atype lisp-type) - &rest more-types) - (alien-var kind-var value-var - &optional - (source-var (gensym) source-p)) - &body body) - "Define-Alien-Access (Lisp-Type {Alien-Type}*) (Alien-Var Kind-Var Value-Var) - {form}* - - Define a new type for Alien-Access. When Alien-Access is given the specified - Lisp-Type and the alien is one of the specified Alien-Types, then body will - be evaluated to get an expression that does the the appropriate access/store. - If no Alien-Type is supplied, then the accepted Alien type is Lisp-Type. If - the type of the Alien is a list, then we use the car as the type. - - Alien-Var - Bound to the Alien type of the Alien value to access. - - Kind-Var - Bound to :read or :write, indicating whether to read or store a value. - - Value-Var - When Kind-Var is :write, this is bound to an expression to evaluate to - obtain the value to be stored. - - Source-Var - If specified, this is bound to the original Alien-Access form - (for use in error messages.) - - In order to obtain the Alien value at which the access is to be done, the - local With-Alien macro should be used: - - With-Alien (Sap-Var) (Offset-Var {Key Value}*) (Size-Var {Key Value}*) - {Form}* - This macro is for use within the body of a Define-Alien-Access. It - analyzes and verifies assertions on the alien value to be accessed. - Sap-Var, Offset-Var and Size-Var are bound to expressions for the - system-area-pointer to the value, the offset from it in bits and - the size of the Alien in bits. - - The keyword arguments for the offset and size may be used to place - constraints on the values they may assume. If the value - is Nil, that is taken to be a null constraint. The following - keys are defined: - :unit -- A integer (default 16). - Asserts that the value is a multiple of this number, and - that the value is to be divided by this number before any - other options are processed. - :constant -- An integer (default Nil). - Asserts that the value must be exactly the supplied value. - :minimum -- An integer (default Nil). - Asserts that the value may not be less than the supplied - value. - - The value of With-Alien is the value of the last form." - - (let ((n-sap (gensym)) - (n-offset (gensym)) - (n-size (gensym))) - `(%define-alien-access - ',lisp-type '(,atype ,@more-types) - #'(lambda (,n-sap ,n-offset ,n-size ,alien-var ,kind-var ,value-var - ,source-var) - ,@(unless source-p - `((declare (ignore ,source-var)))) - - (unless (memq (mostcar ,alien-var) '(,atype ,@more-types)) - (error "Wrong Alien type ~S, should have been ~S~ - ~{~#[~; or~:;,~] ~S~}." - ,alien-var ',atype ',more-types)) - - (macrolet ((with-alien ((sap) - (offset &key - ((:unit ounit) 16)) - (size &key - ((:constant sconst) nil) - ((:minimum smin) nil) - ((:unit sunit) 16)) - &body (body decls)) - (%with-alien sap offset ounit - size sconst smin sunit - ',n-sap ',n-offset ',n-size - body decls))) - ,@body))))) - - -(eval-when (compile load eval) - -(defun %with-alien (sap offset ounit size sconst smin sunit - n-sap n-offset n-size body decls) - (let ((sunit (or sunit 1)) - (ounit (or ounit 1)) - (n-scaled-offset (gensym)) - (n-scaled-size (gensym))) - `(let ((,sap ,n-sap) - (,offset ',n-scaled-offset) - (,size ',n-scaled-size)) - ,@decls - `(let ((,',n-scaled-offset (/ ,,n-offset ,,ounit)) - (,',n-scaled-size (/ ,,n-size ,,sunit))) - ,',n-scaled-size ; Ignorable... - ,@',(when sconst - `((check= ,n-scaled-size ,sconst))) - ,@',(when smin - `((check<= ,smin ,n-scaled-size))) - ,,@body)))) - -); Eval-When (Compile Load Eval) - - -;;; Alien-Access -- Public -;;; -;;; This is only called when we can't open-code because the types aren't -;;; constant (or are erroneous.) In this case, we must look up the access -;;; method at run-time, compute the access form, then eval it. -;;; -(defun alien-access (alien &optional lisp-type) - "Converts the bits described by Alien into an object of type Lisp-Type, - or dies trying." - (declare (type alien-value alien)) - (let* ((alien-type (alien-value-type alien)) - (access (get-alien-access-method alien-type lisp-type)) - (n-sap (gensym)) - (n-offset (gensym)) - (n-size (gensym))) - (eval - `(let ((,n-sap ',(alien-value-sap alien)) - (,n-offset ',(alien-value-offset alien)) - (,n-size ',(alien-value-size alien))) - ,(funcall access n-sap n-offset n-size alien-type :read nil - 'alien-access))))) - -(defsetf alien-access %set-alien-access - "Stores the representation of the value into the alien.") - -;;; %Set-Alien-Access -- Public -;;; -;;; Like Alien-Access, only we call the expert with :write and return -;;; the new value. -;;; -(defun %set-alien-access (alien lisp-type &optional (new-value nil nvp)) - (declare (type alien-value alien)) - (let* ((lisp-type (if nvp lisp-type nil)) - (new-value (if nvp new-value lisp-type)) - (alien-type (alien-value-type alien)) - (access (get-alien-access-method alien-type lisp-type)) - (n-sap (gensym)) - (n-offset (gensym)) - (n-size (gensym)) - (n-nval (gensym))) - (eval - `(let ((,n-sap ',(alien-value-sap alien)) - (,n-offset ',(alien-value-offset alien)) - (,n-size ',(alien-value-size alien)) - (,n-nval ,new-value)) - ,(funcall access n-sap n-offset n-size alien-type :write n-nval - '(setf alien-access)))) - new-value)) - - -;;;; Miscellaneous alien access methods: - -;;; Alien-Access expert for Port -- Internal -;;; -;;; Just find the place and grab or store a 32-bit port, depending -;;; on the access kind, treating ports as 32-bit signed integers. --JRG -;;; -(define-alien-access (port) (type kind value form) - ;; - ;; We want to know if the offset is constant, and the size must be two - ;; words. - (with-alien (sap) - (offset :unit nil) - (size :constant 32 - :unit nil) - (declare (ignore size)) - (if (eq kind :read) - `(naturalize-integer t ,sap ,offset 32 ',form) - `(deport-integer t ,sap ,offset 32 ,value ',form)))) - -;;; Alien-Access expert for String-Char -- Internal -;;; -;;; Kind of easy, but we need to deal with random bit positions. What we do -;;; is call Naturalize-Integer or Deport-Integer to do the access, and just do -;;; the type conversion. -;;; -(define-alien-access (string-char) (type kind value form) - (with-alien (sap) - (offset :unit nil) - (size :unit nil :minimum 8) - (if (eq kind :read) - `(code-char (naturalize-integer nil ,sap ,offset ,size ',form)) - `(deport-integer nil ,sap ,offset ,size (char-code ,value) ',form)))) - -;;; Alien-Access experts for Unsigned-Byte, Signed-Byte -- Internal -;;; -;;; Like, just call Naturalize or Deport Integer. -;;; -(define-alien-access (unsigned-byte) (type kind value form) - (with-alien (sap) - (offset :unit nil) - (size :minimum (cadr type) - :unit nil) - (if (eq kind :read) - `(naturalize-integer nil ,sap ,offset ,size ',form) - `(deport-integer nil ,sap ,offset ,size ,value ',form)))) -;;; -(define-alien-access (signed-byte) (type kind value form) - (with-alien (sap) - (offset :unit nil) - (size :minimum (cadr type) - :unit nil) - (if (eq kind :read) - `(naturalize-integer t ,sap ,offset ,size ',form) - `(deport-integer t ,sap ,offset ,size ,value ',form)))) - -#| -I didn't write this, and it is wrong, since it assumes the size is constant. -In fact, it will never be constant at this point in the new compiler. I also -don't know that it is supposed to be used for. I suspect it is a PERQ crock. - -(define-alien-access (unstructured) (type kind value) - (with-alien (sap) - (offset :unit nil) - (size :unit nil - :minimum (cadr type)) - (if (eq kind :read) - (if (<= size 32) - `(naturalize-integer nil ,sap ,offset ,size) - (if (and (= (mod offset 32) 0) (= (mod size 32) 0)) - (do ((i 32 (+ i 32)) - (form `(naturalize-integer nil ,sap ,offset 32))) - ((>= i size) form) - (setq form - `(logior (ash ,form 32) - (naturalize-integer nil ,sap - ,(+ offset i) 32)))) - (error - "Unstructured aliens of size ~D and offset ~D not supported." - size offset))) - (if (<= size 32) - `(deport-integer nil ,sap ,offset ,size ,value) - (if (and (= (mod offset 32) 0) (= (mod size 32) 0)) - (do ((i (- size 32) (- i 32)) - (shift 0 (- shift 32)) - (form ())) - ((< i 0) (nreverse form)) - (push `(deport-integer nil ,sap ,(+ offset i) 32 - (logand (ash ,value ,shift) - #xFFFFFFFF)) - form)) - (error - "Unstructured aliens of size ~D and offset ~D not supported." - size offset))))))) - -|# - -;;; Alien-Access expert for Boolean -- Internal -;;; -;;; A boolean is a single bit, represented in Lisp as T or NIL. -;;; -(define-alien-access (boolean) (type kind value form) - (with-alien (sap) - (offset :unit 1) - (size :unit 1 :minimum 1) - (if (eq kind :read) - `(naturalize-boolean ,sap ,offset ,size ',form) - `(deport-boolean ,sap ,offset ,size ,value ',form)))) - - -;;; Alien-Access expert for short-floats -;;; -(define-alien-access (short-float) (type kind value) - (with-alien (sap) - (offset) - (size :constant 2) - (declare (ignore size)) - (if (eq kind :read) - `(%primitive int-sap - (logior (ash (%primitive unsigned-32bit-system-ref ,sap ,offset) - (- clc::short-float-shift-16)) - (ash clc::short-float-4bit-type - (- 32 clc::short-float-shift-16)))) - (let ((var (gensym))) - `(let ((,var (float ,value 1.0s0))) - (setq ,var (ash (%primitive sap-int ,var) clc::short-float-shift-16)) - (%primitive signed-32bit-system-set ,sap ,offset ,var)))))) - - -;;; Alien-Access expert for long-floats -;;; -(define-alien-access (long-float) (type kind value) - (with-alien (sap) - (offset) - (size :constant 4) - (declare (ignore size)) - (if (eq kind :read) - (let ((var (gensym))) - `(let ((,var (%primitive float-long 0))) - (%primitive 16bit-system-set ,var 2 - (%primitive 16bit-system-ref ,sap ,offset)) - (%primitive 16bit-system-set ,var 3 - (%primitive 16bit-system-ref ,sap (1+ ,offset))) - (%primitive 16bit-system-set ,var 4 - (%primitive 16bit-system-ref ,sap (+ ,offset 2))) - (%primitive 16bit-system-set ,var 5 - (%primitive 16bit-system-ref ,sap (+ ,offset 3))) - ,var)) - (let ((var (gensym))) - `(let ((,var (float ,value 1.0L0))) - (%primitive 16bit-system-set ,sap ,offset - (%primitive 16bit-system-ref ,var 2)) - (%primitive 16bit-system-set ,sap (1+ ,offset) - (%primitive 16bit-system-ref ,var 3)) - (%primitive 16bit-system-set ,sap (+ ,offset 2) - (%primitive 16bit-system-ref ,var 4)) - (%primitive 16bit-system-set ,sap (+ ,offset 3) - (%primitive 16bit-system-ref ,var 5))))))) - -;;; Alien-access expert for procedure objects. These should be used -;;; with caution. -;;; -(define-alien-access (c-procedure) (type kind value) - (with-alien (sap) - (offset) - (size :constant 2) - (declare (ignore size)) - (if (eq kind :read) - `(error "It is illegal to reference a c-procedure object.") - `(%primitive set-c-procedure-pointer ,sap ,offset ,value)))) - - -;;;; Strings accesses: - -;;; Alien-Access expert for String -- Internal -;;; -;;; Read a Perq-String into a string or write a string out into -;;; a Perq-String. -;;; -(define-alien-access (simple-string perq-string) (type kind n-value) - (with-alien (n-sap) - (n-offset :unit 8) - (size :unit 8 - :minimum (1+ (cadr type))) - (declare (ignore size)) - (if (eq kind :read) - (let ((size (gensym)) - (str (gensym))) - `(let* ((,size (%primitive 8bit-system-ref ,n-sap ,n-offset)) - (,str (make-string ,size))) - (%primitive byte-blt ,n-sap (1+ ,n-offset) ,str 0 ,size) - ,str)) - (let ((len (gensym)) - (1+off (gensym))) - `(let ((,len (length (the simple-string - ,n-value))) - (,1+off (1+ ,n-offset))) - (check<= ,len ,(cadr type)) - (%primitive 8bit-system-set ,n-sap ,n-offset ,len) - (%primitive byte-blt ,n-value 0 ,n-sap ,1+off - (+ ,1+off ,len))))))) - - -;;; Alien-Access expert for null terminated string -- Internal -;;; -;;; Read a null terminated string into a string or write a string out into -;;; a null terminated string. -;;; -(define-alien-access (simple-string null-terminated-string) (type kind n-value) - (with-alien (n-sap) - (n-offset :unit 8) - (size :unit 8 - :minimum (cadr type)) - (declare (ignore size)) - (if (eq kind :read) - (let ((size (gensym)) - (str (gensym))) - `(let* ((,size (the fixnum - (- (the fixnum - (%primitive find-character - ,n-sap ,n-offset - most-positive-fixnum 0)) - (the fixnum ,n-offset)))) - (,str (make-string ,size))) - (%primitive byte-blt ,n-sap ,n-offset ,str 0 ,size) - ,str)) - (let ((len (gensym)) - (end (gensym))) - `(let* ((,len (the fixnum (1+ (length (the simple-string - ,n-value))))) - (,end (the fixnum (+ (the fixnum ,len) ,n-offset)))) - (declare (fixnum ,len ,end)) - (check<= ,len ,(cadr type)) - (%primitive byte-blt ,n-value 0 ,n-sap ,n-offset ,end) - (%primitive 8bit-system-set ,n-sap - (the fixnum (1+ ,end)) 0)))))) - - -;;;; Pointer alien access: - -;;; Alien-Access expert for System-Area-Pointer -- Internal -;;; -;;; Get or store a pointer. In the store case this is the same -;;; as Pointer. -;;; -(define-alien-access (system-area-pointer system-area-pointer alien) - (type kind value) - (with-alien (sap) - (offset) - (size :constant 2) - (declare (ignore size)) - (if (eq kind :read) - `(%primitive sap-system-ref ,sap ,offset) - `(%primitive pointer-system-set ,sap ,offset ,value)))) - -;;; Alien-Access expert for (Alien <type> [<bits>]) -- Internal -;;; -;;; Get or store an alien value. On read, we cons up a value, getting -;;; the size of out the type. On write, we just store the SAP. -;;; -(define-alien-access (alien) (type kind value) - (with-alien (sap) - (offset) - (size :constant 2) - (declare (ignore size)) - (unless (and (consp type) (consp (cdr type))) - (error "Bad type for accessing as an Alien: ~S" type)) - (let ((atype (second type)) - (size (third type))) - (cond - ((eq kind :read) - (unless size - (error "Size not specified when reading alien type: ~S" type)) - (unless (and (integerp size) (>= size 0)) - (error "Size is not a positive integer: ~S" type)) - `(make-alien-value - (%primitive sap-system-ref ,sap ,offset) - 0 - ,size - ',atype)) - (t - `(%primitive pointer-system-set ,sap ,offset - (alien-value-sap ,value))))))) - -;;; Alien-Access expert for (Pointer xxx) -- Internal -;;; -;;; We can't read pointers, and can only store pointers to unboxed -;;; things. -;;; -(define-alien-access (pointer pointer alien) (type kind value) - (with-alien (sap) - (offset) - (size :constant 2) - (declare (ignore size)) - (when (eq kind :read) - (error "Cannot read with Pointer Alien type:~%~S" type)) - `(%primitive pointer-system-set ,sap ,offset ,value))) - - -;;;; Enumeration Alien access: - -(compiler-let ((lisp::*bootstrap-defmacro* t)) - -;;; Defenumeration -- Public -;;; -;;; Cons up the from alist, keeping track of the minimum and maximum -;;; values, then decide whether to use a vector or alist to mapping. -;;; -(defmacro defenumeration (name &rest elements) - "Defenumeration Name {{Element}+ | {(Element Value)}+} - Define an enumeration for use with Alien-Access and the Enumeration - Alien type." - (let ((min nil) - (max nil) - (from-alist ())) - (declare (list from-alist)) - (when (null elements) - (error "An anumeration must contain at least one element.")) - (if (listp (car elements)) - (dolist (el elements) - (unless (listp el) - (error "Element value is not specified: ~S." el)) - (push (cons (first el) (second el)) from-alist)) - (let ((num -1)) - (dolist (el elements) - (push (cons el (incf num)) from-alist)))) - (do ((el from-alist (cdr el))) - ((null el)) - (let ((sym (caar el)) - (val (cdar el))) - (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 (cdr el)) - (error "Element value ~S used more than once." val)) - (when (assq sym (cdr el)) - (error "Enumeration element ~S used more than once." sym)))) - (let* ((signed (minusp min)) - (to (intern (concatenate 'simple-string (string name) - "-TO-ENUMERATION-" (string (gensym))))) - (from (intern (concatenate 'simple-string (string name) - "-FROM-ENUMERATION-" (string (gensym))))) - (info (make-enumeration-info :signed signed - :size (if signed - (1+ (max (integer-length min) - (integer-length max))) - (integer-length max)) - :from from :to to)) - to-thing) - (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)) - (setq to-thing (make-array (1+ (- max min)))) - (dolist (el from-alist) - (setf (svref to-thing (- (cdr el) min)) (car el))) - (setf (enumeration-info-kind info) :vector) - (setf (enumeration-info-offset info) (- min))) - (t - (setf (enumeration-info-kind info) :alist) - (setq to-thing (mapcar #'(lambda (x) (cons (cdr x) (car x))) from-alist)))) - `(progn - (eval-when (compile load eval) - (proclaim '(special ,to ,from)) - (set ',to ',to-thing) - (set ',from ',from-alist)) - (eval-when ,*alien-eval-when* - (setf (info enumeration info ',name) ',info)) - ',name)))) - -); compiler-let - -;;; Enumeration-Error -- Internal -;;; -;;; Tell the luser what permissable values the enumeration has when she -;;; gives us something bogus. We even give them a chance to specify -;;; something else. -;;; -(defun enumeration-error (alist) - (loop - (cerror "Prompt for a new value." - "Enumeration value is not one of the following: ~{~<~% ~:;~S ~>~}" - (mapcar #'car alist)) - (write-string "New value: " *query-io*) - (let* ((response (read *query-io*)) - (res (cdr (assq response alist)))) - (when res (return res))))) - - -(define-alien-access (enumeration) (type kind value form) - (let* ((enum (cadr type)) - (info (or (info enumeration info enum) - (error "~S is not a defined enumeration." enum))) - (signed (enumeration-info-signed info)) - (to (enumeration-info-to info)) - (from (enumeration-info-from info))) - (with-alien (sap) - (offset :unit nil) - (size :unit nil - :minimum (enumeration-info-size info)) - (if (eq kind :read) - (ecase (enumeration-info-kind info) - (:vector - `(svref ,to - (+ ,(enumeration-info-offset info) - (naturalize-integer ,signed ,sap ,offset ,size - ',form)))) - (:alist - `(cdr (assoc (naturalize-integer ,signed ,sap ,offset ,size - ',form) - ,to)))) - `(deport-integer - ,signed ,sap ,offset ,size - (or (cdr (assq ,value ,from)) - (enumeration-error ,from)) - ',form))))) - diff --git a/code/array.lisp b/code/array.lisp deleted file mode 100644 index 77cbf80e12a6b71eec885d58de3df5da5e145ddf..0000000000000000000000000000000000000000 --- a/code/array.lisp +++ /dev/null @@ -1,873 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Functions to implement arrays for Spice Lisp -;;; Written by Skef Wholey. -;;; -(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)) - -(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 function used by WITH-ARRAY-DATA, which has to be defined in -;;; init.lisp. -;;; -(defun find-data-vector (array) - (do ((data array (%primitive header-ref data %array-data-slot)) - (cumulative-offset 0 - (the fixnum - (+ cumulative-offset - (the fixnum - (or (%primitive header-ref data - %array-displacement-slot) - 0)))))) - ((not (array-header-p data)) - (values data cumulative-offset)) - (declare (fixnum cumulative-offset)))) - - - -(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." - (unless (listp dimensions) (setq dimensions (list dimensions))) - (let ((array-rank (length (the list dimensions)))) - (declare (fixnum array-rank)) - (if (eq fill-pointer t) (setq fill-pointer (car dimensions))) - (if (and fill-pointer (> array-rank 1)) - (error "Multidimensional arrays can't have fill pointers.")) - (cond (displaced-to - ;; If the array is displaced, make a header and fill it up. - (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))) - (if (or initial-element initial-contents) - (error "The :initial-element or initial-contents option may not ~ - be specified with :displaced-to.")) - (let ((displacement (or displaced-index-offset 0)) - (array-size (array-linear-length 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.")) - (set-array-header (%primitive alloc-array array-rank) - displaced-to array-size - (or fill-pointer array-size) - displacement dimensions t))) - ((and (not adjustable) (= array-rank 1) (not fill-pointer)) - ;; If the array can be represented as a simple thing, do that. - (if (and initial-element-p initial-contents) - (error "The :initial-contents option may not be specified with ~ - :initial-element.")) - (data-vector-from-inits dimensions (car dimensions) array-rank - element-type initial-contents - initial-element initial-element-p)) - (t - ;; Otherwise, build a complex array. - (if (and initial-element-p initial-contents) - (error "The :initial-contents option may not be specified with ~ - :initial-element.")) - (let* ((array-size (array-linear-length dimensions)) - (array (%primitive alloc-array array-rank)) - (array-data (data-vector-from-inits - dimensions array-size array-rank element-type - initial-contents initial-element - initial-element-p))) - (set-array-header array array-data array-size - (or fill-pointer array-size) - 0 ;displacement - dimensions nil)))))) - -;;; 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)) - -;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array -;;; characteristics. Dimensions is only used to pass to COPY-CONTENTS-AUX -;;; for error checking on the structure of initial-contents. -;;; -(defun data-vector-from-inits (dimensions total-size rank element-type - initial-contents initial-element - initial-element-p) - (let ((data (cond ((subtypep element-type 'string-char) - (%primitive alloc-string total-size)) - ((subtypep element-type '(unsigned-byte 32)) - (%primitive alloc-i-vector total-size - (element-type-to-access-code element-type))) - (t - (%primitive alloc-g-vector total-size initial-element))))) - (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 - (copy-contents-aux dimensions initial-contents element-type - rank 0 data))) - data)) - -;;; COPY-CONTENTS-AUX spins down into the Data vector and the Initial-Contents -;;; filling the former from the latter. -;;; -(defun copy-contents-aux (dimensions initial-contents element-type - depth index data) - (declare (fixnum depth index)) - (cond ((= depth 0) - (unless (typep initial-contents element-type) - (error "~S cannot be used to initialize an array of element-type ~S." - initial-contents element-type)) - (setf (aref data index) initial-contents) - (the fixnum (1+ index))) - ((listp initial-contents) - (unless (= (length (the list initial-contents)) (car dimensions)) - (error "This part of initial-contents, ~S, is an unappropriate ~ - length for the dimension, ~S." - initial-contents (car dimensions))) - (do ((initial-contents initial-contents (cdr initial-contents)) - (next-dimensions (cdr dimensions)) - (next-depth (the fixnum (1- depth)))) - ((null initial-contents) index) - (declare (list initial-contents)) - (setq index (copy-contents-aux - next-dimensions (car initial-contents) element-type - next-depth index data)))) - ((vectorp initial-contents) - (unless (= (length (the vector initial-contents)) (car dimensions)) - (error "This part of initial-contents, ~S, is an unappropriate ~ - length for the dimension, ~S." - initial-contents (car dimensions))) - (do ((i-index 0 (1+ i-index)) - (i-end (length (the vector initial-contents))) - (next-dimensions (cdr dimensions)) - (next-depth (the fixnum (1- depth)))) - ((= i-index i-end) index) - (declare (fixnum i-index i-end)) - (setq index (copy-contents-aux - next-dimensions (aref initial-contents index) - element-type next-depth index data)))) - (t - (error "~S is not a sequence, and cannot be used to initialize~%~ - the contents of an array." initial-contents)))) - -;;; ELEMENT-TYPE-TO-ACCESS-CODE returns the Spice Lisp I-Vector access code to -;;; be used for the data vector of an array with the given access code. -;;; -(defun element-type-to-access-code (type) - (cond ((subtypep type 'bit) 0) - ((subtypep type '(unsigned-byte 2)) 1) - ((subtypep type '(unsigned-byte 4)) 2) - ((subtypep type '(unsigned-byte 8)) 3) - ((subtypep type '(unsigned-byte 16)) 4) - ((subtypep type '(unsigned-byte 32)) 5) - (t (error "Unexpected array element type -- ~S." type)))) - - -;;; ARRAY-LINEAR-LENGTH returns the number of elements an array with the -;;; specified dimensions would have. -;;; -(defun array-linear-length (dimensions) - (do ((dimensions dimensions (cdr dimensions)) - (length 1)) - ((null dimensions) length) - (declare (fixnum length)) - (setq length (* length (the fixnum (car dimensions)))))) - -(defun aref (array &rest subscripts) - "Returns the element of the Array specified by the Subscripts." - (if (and subscripts (null (cdr subscripts))) - (aref array (car subscripts)) - (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts)) - (dim-index (1- (the fixnum (%primitive header-length array))) - (1- dim-index)) - (chunk-size 1) - (result 0)) - ((= (the fixnum dim-index) %array-dim-base) - (if (atom subscripts) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (aref data (the fixnum (+ start result)))) - (error "Too many subscripts for array reference."))) - (declare (fixnum dim-index chunk-size result)) - (let ((axis (%primitive header-ref array dim-index))) - (declare (fixnum axis)) - (cond ((atom subscripts) - (error "Too few subscripts for array reference.")) - ((not (< -1 (the fixnum (car subscripts)) axis)) - (error "Subscript ~S is out of bounds." (car subscripts))) - (t - (setq result (the fixnum - (+ result - (the fixnum - (* (the fixnum (car subscripts)) - chunk-size))))) - (setq chunk-size (* chunk-size axis)))))))) - -(defun %aset (array &rest stuff) - (if (and (cdr stuff) (null (cddr stuff))) - (setf (aref array (car stuff)) (cadr stuff)) - (let ((rstuff (nreverse (the list stuff)))) - (do ((subscripts (cdr rstuff) (cdr subscripts)) - (dim-index (1- (the fixnum (%primitive header-length array))) - (1- dim-index)) - (chunk-size 1) - (result 0)) - ((= dim-index %array-dim-base) - (if (atom subscripts) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (setf (aref data (+ start result)) (car rstuff))) - (error "Too many subscripts for array reference."))) - (declare (fixnum dim-index chunk-size result)) - (let ((axis (%primitive header-ref array dim-index))) - (declare (fixnum axis)) - (cond ((atom subscripts) - (error "Too few subscripts for array reference.")) - ((not (< -1 (the fixnum (car subscripts)) axis)) - (error "Subscript ~S is out of bounds." - (car subscripts))) - (t - (setq result (+ result - (the fixnum (* (the fixnum (car subscripts)) - chunk-size)))) - (setq chunk-size (* chunk-size axis))))))))) - - -;;; %Apply-aset is called when (setf (apply #'aref ...) new-value) is -;;; called. - -(defun %apply-aset (new-value array &rest stuff) - (if (null (cdr stuff)) - (setf (aref array (car stuff)) new-value) - (let ((rstuff (nreverse (the list stuff)))) - (do ((subscripts rstuff (cdr subscripts)) - (dim-index (1- (the fixnum (%primitive header-length array))) - (1- dim-index)) - (chunk-size 1) - (result 0)) - ((= dim-index %array-dim-base) - (if (atom subscripts) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (setf (aref data (+ start result)) new-value)) - (error "Too many subscripts for array reference."))) - (declare (fixnum dim-index chunk-size result)) - (let ((axis (%primitive header-ref array dim-index))) - (declare (fixnum axis)) - (cond ((atom subscripts) - (error "Too few subscripts for array reference.")) - ((not (< -1 (the fixnum (car subscripts)) axis)) - (error "Subscript ~S is out of bounds." - (car subscripts))) - (t - (setq result (+ result - (the fixnum (* (the fixnum (car subscripts)) - chunk-size)))) - (setq chunk-size (* chunk-size axis))))))))) - -(defun array-element-type (array) - "Returns the type of the elements of the array" - (cond ((bit-vector-p array) - '(mod 2)) - ((stringp array) - 'string-char) - ((simple-vector-p array) - t) - ((array-header-p array) - (with-array-data ((data array) (start) (end)) - (declare (ignore start end)) - (array-element-type data))) - ((vectorp array) - (case (%primitive get-vector-access-code array) - (0 'bit) - (1 '(unsigned-byte 2)) - (2 '(unsigned-byte 4)) - (3 '(unsigned-byte 8)) - (4 '(unsigned-byte 16)) - (5 '(unsigned-byte 32)))) - (t (error "~S is not an array." array)))) - -(defun array-rank (array) - "Returns the number of dimensions of the Array." - (if (array-header-p array) - (the fixnum (- (the fixnum (%primitive header-length array)) - %array-first-dim-slot)) - 1)) - -(defun array-dimension (array axis-number) - "Returns length of dimension Axis-Number of the Array." - (declare (fixnum axis-number)) - (if (array-header-p array) - (if (and (>= axis-number 0) - (< axis-number (the fixnum (array-rank array)))) - (%primitive header-ref array (the fixnum (+ %array-first-dim-slot axis-number))) - (error "~S is an illegal axis number." axis-number)) - (if (= axis-number 0) - (%primitive vector-length array) - (error "~S is an illegal axis number." axis-number)))) - -(defun array-dimensions (array) - "Returns a list whose elements are the dimensions of the array" - (if (array-header-p array) - (do ((index %array-first-dim-slot (1+ index)) - (end (%primitive header-length array)) - (result ())) - ((= index end) (nreverse result)) - (declare (fixnum index end)) - (push (%primitive header-ref array index) result)) - (list (%primitive vector-length array)))) - -(defun array-total-size (array) - "Returns the total number of elements in the Array." - (if (array-header-p array) - (%primitive header-ref array %array-length-slot) - (%primitive vector-length array))) - -(defun array-in-bounds-p (array &rest subscripts) - "Returns T if the Subscipts are in bounds for the Array, Nil otherwise." - (if (array-header-p array) - (do ((dim-index %array-first-dim-slot (1+ dim-index)) - (dim-index-limit (+ %array-first-dim-slot - (the fixnum (array-rank array)))) - (subs subscripts (cdr subs))) - ((= dim-index dim-index-limit) - (atom subs)) - (declare (fixnum dim-index dim-index-limit)) - (if (atom subs) - (return nil) - (if (not (< -1 - (the fixnum (car subs)) - (the fixnum (%primitive header-ref array dim-index)))) - (return nil)))) - (and (null (cdr subscripts)) - (< -1 - (the fixnum (car subscripts)) - (the fixnum (%primitive vector-length array)))))) - -(defun array-row-major-index (array &rest subscripts) - "Returns the index into the Array's data vector for the given subscripts." - (if (array-header-p array) - (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts)) - (dim-index (1- (the fixnum (%primitive header-length array))) - (1- dim-index)) - (chunk-size 1) - (result 0)) - ((= dim-index %array-dim-base) - (if (atom subscripts) - result - (error "Too many subscripts for array reference."))) - (declare (fixnum dim-index chunk-size result)) - (let ((axis (%primitive header-ref array dim-index))) - (declare (fixnum axis)) - (cond ((null subscripts) - (error "Too few subscripts for array reference.")) - ((not (< -1 (the fixnum (car subscripts)) axis)) - (error "Subscript ~S is out of bounds." (car subscripts))) - (t - (setq result (+ result - (the fixnum (* (the fixnum (car subscripts)) - chunk-size)))) - (setq chunk-size (* chunk-size axis)))))) - (cond ((null subscripts) - (error "Too few subscripts for array reference.")) - ((not (< -1 - (the fixnum (car subscripts)) - (length (the simple-array array)))) - (error "Subscript ~S is out of bounds." (car subscripts))) - (t - (car subscripts))))) - -(defun adjustable-array-p (array) - "Returns T if the given Array is adjustable, or Nil otherwise." - (array-header-p array)) - - -(defun row-major-aref (array index) - "Returns the element of array corressponding to the row-major index. This is - SETF'able." - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (aref data (+ start index)))) - -(defsetf row-major-aref %set-row-major-aref) - -(defun %set-row-major-aref (array index new-value) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (setf (aref data (+ start index)) new-value))) - -(defun svref (simple-vector index) - "Returns the Index'th element of the given Simple-Vector." - (svref simple-vector index)) - -(defun %svset (simple-vector index new) - (setf (svref simple-vector index) new)) - -;;; The following function is used when (setf (apply #'svref ...) new -;;; is compiled. - -(defun %apply-svset (new simple-vector index) - (setf (svref simple-vector index) new)) - -(defun array-has-fill-pointer-p (array) - "Returns T if the given Array has a fill pointer, or Nil otherwise." - (and (vectorp array) (array-header-p array))) - -(defun fill-pointer (vector) - "Returns the Fill-Pointer of the given Vector." - (if (and (vectorp vector) (array-header-p vector)) - (%primitive header-ref vector %array-fill-pointer-slot) - (error "~S is not an array with a fill-pointer." vector))) - -(defun %set-fill-pointer (vector new) - (declare (fixnum new)) - (if (and (vectorp vector) (array-header-p vector)) - (if (> new (the fixnum (%primitive header-ref vector %array-length-slot))) - (error "New fill pointer, ~S, is larger than the length of the vector." - new) - (%primitive header-set vector %array-fill-pointer-slot 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 new fill pointer value is - returned." - (if (array-header-p array) - (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot))) - (declare (fixnum fill-pointer)) - (cond ((= fill-pointer - (the fixnum (%primitive header-ref array %array-length-slot))) - nil) - (t (%primitive header-set array %array-fill-pointer-slot - (1+ fill-pointer)) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (setf (aref data (+ fill-pointer start)) new-el)) - fill-pointer))) - (error "~S: Object has no fill pointer." array))) - -(defun vector-push-extend (new-el array &optional (extension (length array))) - "Like Vector-Push except that if the fill pointer gets too large, the - Array is extended rather than Nil being returned." - (declare (fixnum extension)) - (if (array-header-p array) - (let ((length (%primitive header-ref array %array-length-slot)) - (fill-pointer (%primitive header-ref array %array-fill-pointer-slot))) - (declare (fixnum length fill-pointer)) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (if (= fill-pointer length) - (do* ((new-index 0 (1+ new-index)) - (new-length (let ((l (+ length extension))) - (declare (fixnum l)) - (if (zerop l) 1 l))) - (old-index start (1+ old-index)) - (new-data (make-array (if (zerop new-length) 1 new-length) - :element-type (array-element-type - array)))) - ((= new-index length) - (setq data new-data) - (setq start 0) - (set-array-header array data new-length - (1+ fill-pointer) start new-length nil)) - (declare (fixnum new-index new-length old-index)) - (setf (aref new-data new-index) (aref data old-index))) - (%primitive header-set array - %array-fill-pointer-slot (1+ fill-pointer))) - (setf (aref data (+ fill-pointer start)) new-el) - fill-pointer)) - (error "~S has no fill pointer." array))) - -(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 new value of the fill - pointer is 0, an error occurs." - (if (array-header-p array) - (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot))) - (declare (fixnum fill-pointer)) - (cond ((< fill-pointer 1) - (error "Fill-pointer reached 0.")) - (t - (let ((fill-pointer (1- fill-pointer))) - (declare (fixnum fill-pointer)) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (%primitive header-set array %array-fill-pointer-slot - fill-pointer) - (aref data (+ fill-pointer start))))))) - (error "~S: Object has no fill pointer." 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." - (unless (listp dimensions) (setq dimensions (list dimensions))) - (cond ((not (array-header-p array)) - (error "~S is not an adjustable array." array)) - ((/= (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 - (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 (array-linear-length dimensions)) - (array-data (data-vector-from-inits - dimensions array-size array-rank element-type - initial-contents initial-element - initial-element-p))) - (set-array-header array array-data array-size - (get-new-fill-pointer array array-size - fill-pointer) - 0 dimensions nil))) - (displaced-to - (when initial-element ;no initial-contents supplied is already known - (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 (array-linear-length 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.")) - (set-array-header array displaced-to array-size - (get-new-fill-pointer array array-size - fill-pointer) - displacement dimensions t))) - ((= array-rank 1) - (let ((old-length (%primitive header-ref array %array-length-slot)) - (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 (%displacedp array) (< old-length new-length)) - (setf new-data - (data-vector-from-inits - dimensions new-length array-rank element-type - initial-contents initial-element - initial-element-p)) - (replace new-data old-data - :start2 old-start :end2 old-end)) - (t (setf new-data - (%primitive shrink-vector old-data new-length)))) - (set-array-header array new-data new-length - (get-new-fill-pointer array new-length - fill-pointer) - 0 dimensions nil)))) - (t - (let ((old-length (%primitive header-ref array %array-length-slot)) - (new-length (array-linear-length 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 (%displacedp array) - (> new-length old-length)) - (data-vector-from-inits - dimensions new-length array-rank - 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))))))) - array) - -(defun get-new-fill-pointer (old-array new-array-size fill-pointer) - (cond ((not fill-pointer) - (%primitive header-ref old-array %array-fill-pointer-slot)) - ((numberp fill-pointer) - fill-pointer) - (t new-array-size))) - -(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." - (cond ((array-header-p vector) - ;; (%primitive shrink-vector - ;; (%primitive header-ref vector %array-data-slot) - ;; new-size) - ;; (%primitive header-set vector %array-length-slot new-size) - ;; Instead of shrinking the vector, just set the fill-pointer field. - (%primitive header-set vector %array-fill-pointer-slot new-size) - vector) - (t - (%primitive shrink-vector vector new-size)))) - -(defun set-array-header (array data length fill-pointer displacement dimensions - &optional displacedp) - "Fills in array header with provided information. Returns array." - (%primitive header-set array %array-data-slot data) - (%primitive header-set array %array-length-slot length) - (%primitive header-set array %array-fill-pointer-slot fill-pointer) - (%primitive header-set array %array-displacement-slot displacement) - (if (listp dimensions) - (do ((index %array-first-dim-slot (1+ index)) - (dims dimensions (cdr dims))) - ((null dims)) - (declare (fixnum index)) - (%primitive header-set array index (car dims))) - (%primitive header-set array %array-first-dim-slot dimensions)) - (%set-array-displacedp 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* (%primitive alloc-g-vector 1000 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* (%primitive alloc-g-vector length 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 (bit-array &rest subscripts) - "Returns the bit from the Bit-Array at the specified Subscripts." - (apply #'aref bit-array subscripts)) - -(defun %bitset (bit-array &rest stuff) - (apply #'%aset bit-array stuff)) - -(defun sbit (simple-bit-array &rest subscripts) - "Returns the bit from the Simple-Bit-Array at the specified Subscripts." - (apply #'aref simple-bit-array subscripts)) - -(defun %sbitset (bit-array &rest stuff) - (apply #'%aset bit-array stuff)) - -(defun bit-array-same-dimensions-p (array1 array2) - (and (= (the fixnum (%primitive header-length array1)) - (the fixnum (%primitive header-length array2))) - (do ((index %array-first-dim-slot (1+ index)) - (length (%primitive header-length array1))) - ((= index length) t) - (declare (fixnum index length)) - (if (/= (the fixnum (%primitive header-ref array1 index)) - (the fixnum (%primitive header-ref array2 index))) - (return nil))))) - -(defun bit-array-boole (array1 array2 op result-array) - (if (eq result-array t) (setq result-array array1)) - (cond ((simple-bit-vector-p array1) - (let ((length (%primitive vector-length array1))) - (declare (fixnum length)) - (unless (and (simple-bit-vector-p array2) - (= (the fixnum (%primitive vector-length array2)) length)) - (error "~S and ~S do not have the same dimensions." array1 array2)) - (if result-array - (unless (and (simple-bit-vector-p result-array) - (= (the fixnum (%primitive vector-length result-array)) - length)) - (error "~S and ~S do not have the same dimensions." - array1 result-array)) - (setq result-array (%primitive alloc-bit-vector length))) - (%primitive bit-bash array1 array2 result-array op))) - (t - (unless (bit-array-same-dimensions-p array1 array2) - (error "~S and ~S do not have the same dimensions." array1 array2)) - (if result-array - (unless (bit-array-same-dimensions-p array1 result-array) - (error "~S and ~S do not have the same dimensions." - array1 result-array)) - (setq result-array (make-array (array-dimensions array1) - :element-type '(mod 2)))) - (with-array-data ((data1 array1) (start1) (end1)) - (declare (ignore end1)) - (with-array-data ((data2 array2) (start2) (end2)) - (declare (ignore end2)) - (with-array-data ((data3 result-array) (start3) (end3)) - (declare (ignore end3)) - (let ((length (%primitive header-ref array1 %array-length-slot))) - (declare (fixnum length)) - (do ((index 0 (1+ index)) - (index1 start1 (1+ index1)) - (index2 start2 (1+ index2)) - (index3 start3 (1+ index3))) - ((= index length) result-array) - (declare (fixnum index index1 index2 index3)) - (setf (sbit data3 index3) - (boole op (sbit data1 index1) - (sbit data2 index2)))))))))) - result-array) - -(defun bit-and (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical AND on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-and result-bit-array)) - -(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical IOR on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-ior result-bit-array)) - -(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical XOR on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-xor result-bit-array)) - -(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical EQV on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-eqv result-bit-array)) - -(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical NAND on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-nand result-bit-array)) - -(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical NOR on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-nor result-bit-array)) - -(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical ANDC1 on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-andc1 result-bit-array)) - -(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical ANDC2 on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-andc2 result-bit-array)) - -(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical ORC1 on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-orc1 result-bit-array)) - -(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array) - "Performs a bit-wise logical ORC2 on the elements of Bit-Array1 and Bit-Array2 - putting the results in the Result-Bit-Array." - (bit-array-boole bit-array1 bit-array2 boole-orc2 result-bit-array)) - -(defun bit-not (bit-array &optional result-bit-array) - "Performs a bit-wise logical NOT in the elements of the Bit-Array putting - the results into the Result-Bit-Array." - (bit-array-boole bit-array bit-array boole-nor result-bit-array)) diff --git a/code/backq.lisp b/code/backq.lisp deleted file mode 100644 index 4d40fc3485d750828adf4e396963b40ddf7bcd89..0000000000000000000000000000000000000000 --- a/code/backq.lisp +++ /dev/null @@ -1,174 +0,0 @@ -;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher. -;;; -(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 (read stream t nil t)) - (if (eq flag *bq-at-flag*) - (error ",@ after backquote in ~S" thing)) - (if (eq flag *bq-dot-flag*) - (error ",. 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)) - (error "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 (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 (cdr code)) - (values 'vector (backquotify-1 dflag d)))) - (t (multiple-value-bind (aflag a) (backquotify (car code)) - (multiple-value-bind (dflag d) (backquotify (cdr code)) - (if (eq dflag *bq-at-flag*) - ;; get the errors later. - (error ",@ after dot in ~S" code)) - (if (eq dflag *bq-dot-flag*) - (error ",. 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 'cons thing)) - (t (cons 'list* thing)))) - ((eq flag 'vector) - (list 'apply '#'vector thing)) - (t (cons (cdr - (assq flag - `((cons . cons) (list . list) - (append . append) (nconc . nconc)))) - thing)))) - - - - -(defun backq-init () - (let ((*readtable* std-lisp-readtable)) - (set-macro-character #\` #'backquote-macro) - (set-macro-character #\, #'comma-macro))) diff --git a/code/bignum.lisp b/code/bignum.lisp deleted file mode 100644 index d58d77e0792d59856d5f590125d9895941d010cf..0000000000000000000000000000000000000000 --- a/code/bignum.lisp +++ /dev/null @@ -1,2182 +0,0 @@ -;;; -*- Mode: completion; Log: code.log; Package: bignum -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains code to implement bignum support. -;;; - -(in-package "BIGNUM") - -(export '(add-bignums multiply-bignums negate-bignum subtract-bignum - bignum-ashift-right bignum-ashift-left bignum-gcd - bignum-to-single-float bignum-to-double-float 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)) - - -;;;; 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 -;;; %FIXNUM-DIGIT-WITH-CORRECT-SIGN -;;; %SIGN-DIGIT -;;; %ASHR -;;; %ASHL -;;; %bignum-0-or-plusp -;;; 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: -;;; Relational operators: -;;; %LOGAND -;;; %LOGIOR -;;; %LOGXOR -;;; Float conversion: -;;; %SIGNED-DIGIT-TO-SINGLE-FLOAT -;;; %DIGIT-TO-SINGLE-FLOAT -;;; %SIGNED-DIGIT-TO-DOUBLE-FLOAT -;;; %DIGIT-TO-DOUBLE-FLOAT -;;; LDB -;;; %FIXNUM-TO-DIGIT -;;; TRUNCATE -;;; %FLOOR -;;; -;;; 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 vm:word-bits) - -(defconstant maximum-bignum-length (1- (ash 1 (- vm:word-bits 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)) - (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)) - -;;; %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)))) - -;;; %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. -;;; -(proclaim '(notinline %floor)) -(defun %floor (a b c) - (declare (type bignum-element-type a b c)) - (error "Can't truncate bignums." 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)) - -#| -;;; %SIGNED-DIGIT-TO-SINGLE-FLOAT -- Internal. -;;; -;;; Convert the digit into a single float treating the digit as a signed number. -;;; -(defun %signed-digit-to-single-float (digit) - (declare (type bignum-element-type digit)) - (coerce (%fixnum-digit-with-correct-sign digit) 'single-float)) - -;;; %SIGNED-DIGIT-TO-SINGLE-FLOAT -- Internal. -;;; -;;; Convert the digit into a single float treating the digit as an unsigned -;;; number. -;;; -(proclaim '(inline %digit-to-single-float)) -(defun %digit-to-single-float (digit) - (declare (type bignum-element-type digit)) - (+ (* (%signed-digit-to-single-float (ash digit #.(- (floor digit-size 2)))) - #.(coerce (ash 1 (floor digit-size 2)) 'single-float)) - (%signed-digit-to-single-float - (logand digit #.(1- (ash 1 (floor digit-size 2))))))) - -;;; %SIGNED-DIGIT-TO-DOUBLE-FLOAT -- Internal. -;;; -;;; Convert the digit into a double float treating the digit as a signed number. -;;; -(defun %signed-digit-to-double-float (digit) - (declare (type bignum-element-type digit)) - (coerce (%fixnum-digit-with-correct-sign digit) 'double-float)) - -;;; %SIGNED-DIGIT-TO-DOUBLE-FLOAT -- Internal. -;;; -;;; Convert the digit into a double float treating the digit as an unsigned -;;; number. -;;; -(proclaim '(inline %digit-to-double-float)) -(defun %digit-to-double-float (digit) - (declare (type bignum-element-type digit)) - (+ (* (%signed-digit-to-double-float (ash digit #.(- (floor digit-size 2)))) - #.(coerce (ash 1 (floor digit-size 2)) 'double-float)) - (%signed-digit-to-double-float - (logand digit #.(1- (ash 1 (floor digit-size 2))))))) -|# - -;;; %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)) - -;;; %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))) - - - -(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))) - (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)))) - - -;;;; 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)) - (shorter-len (gensym)) - (i (gensym)) - (v (gensym)) - (k (gensym))) - `(let* ((,borrow 1) - (,shorter-len (min ,len-a ,len-b))) - (declare (type bignum-index)) - (dotimes (,i ,shorter-len) - (multiple-value-bind (,v ,k) - (%subtract-with-borrow (%bignum-ref ,a ,i) - (%bignum-ref ,b ,i) - ,borrow) - (setf (%bignum-ref ,res ,i) ,v) - (setf ,borrow ,k))) - (cond ((> ,len-a ,len-b) - (finish-subtract-a ,a ,res ,borrow (%sign-digit ,b ,len-b) - ,len-b ,len-a)) - ((> ,len-b ,len-a) - (finish-subtract-b (%sign-digit ,a ,len-a) ,res ,borrow ,b - ,len-a ,len-b))) - (,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 (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))) - - -(defun finish-subtract-a (a res borrow sign-digit-b start end) - (declare (type bignum-type a res) - (type (mod 2) borrow) - (type bignum-element-type sign-digit-b) - (type bignum-index start end)) - (do ((i start (1+ i))) - ((= i end)) - (multiple-value-bind (v k) - (%subtract-with-borrow (%bignum-ref a i) sign-digit-b - borrow) - (setf (%bignum-ref res i) v) - (setf borrow k)))) - -(defun finish-subtract-b (sign-digit-a res borrow b start end) - (declare (type bignum-element-type sign-digit-a) - (type bignum-type res b) - (type (mod 2) borrow) - (type bignum-index start end)) - (do ((i start (1+ i))) - ((= i end)) - (multiple-value-bind (v k) - (%subtract-with-borrow sign-digit-a (%bignum-ref b i) - borrow) - (setf (%bignum-ref res i) v) - (setf borrow k)))) - - - -;;;; 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-a-1 (1- len-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-a-1 len-b len-res)) - (dotimes (i len-a) - (declare (type bignum-index i)) - (let ((carry 0) - (x (%bignum-ref a i)) - (k i)) - (declare (type bignum-index k)) - (dotimes (j len-b - (unless (= i len-a-1) - (setf (%bignum-ref res (1+ k)) carry))) - (multiple-value-bind (high-digit low-digit) - (%multiply x (%bignum-ref b j)) - (multiple-value-bind (res-low-digit temp-carry) - (%add-with-carry low-digit (%bignum-ref res k) - carry) - (setf (%bignum-ref res k) res-low-digit) - (incf k) - (multiple-value-bind (res-high-digit temp-carry) - (%add-with-carry high-digit - (%bignum-ref res k) - temp-carry) - (setf (%bignum-ref res k) res-high-digit) - (setf carry temp-carry))))))) - (when negate-res (negate-bignum-in-place res)) - (%normalize-bignum res len-res))) - - - -;;;; GCD. - -#| - -(defvar *bignum-gcd-a-buffer* (%allocate-bignum 5)) -(defvar *bignum-gcd-b-buffer* (%allocate-bignum 5)) -(defvar *bignum-gcd-res-buffer* (%allocate-bignum 5)) - -;;; SETUP-BIGNUM-BUFFERS -- Internal. -;;; -;;; This makes all buffers as long as we could possibly want since the -;;; arguments to GCD get switched around during the process. -;;; -(defun setup-bignum-buffers (a len-a b len-b) - (macrolet ((frob (var len) - `(when (< (the bignum-index (%bignum-length ,var)) ,len) - (setf ,var (%allocate-bignum ,len))))) - (let ((len (max len-a len-b))) - (frob *bignum-gcd-a-buffer* len) - (frob *bignum-gcd-b-buffer* len) - (frob *bignum-gcd-res-buffer* len)) - (replace (the bignum-type *bignum-gcd-a-buffer*) (the bignum-type a) - :end1 len-a :end2 len-a) - (replace (the bignum-type *bignum-gcd-b-buffer*) (the bignum-type b) - :end1 len-b :end2 len-b))) - -(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))) - (b (if (%bignum-0-or-plusp b (%bignum-length b)) b (negate-bignum b)))) - (if (bignum= a b) ;Hack for now to remind me of this situation. - a - (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b))) - (declare (type bignum-index len-a len-b)) - (setup-bignum-buffers a len-a b len-b) - (let* ((factors-of-two - (bignum-factors-of-two *bignum-gcd-a-buffer* len-a - *bignum-gcd-b-buffer* len-b)) - (len-a (make-gcd-bignum-odd - *bignum-gcd-a-buffer* - (bignum-buffer-ashift-right *bignum-gcd-a-buffer* len-a - factors-of-two))) - (len-b (make-gcd-bignum-odd - *bignum-gcd-b-buffer* - (bignum-buffer-ashift-right *bignum-gcd-b-buffer* len-b - factors-of-two)))) - (declare (type bignum-index len-a len-b)) - (let ((x *bignum-gcd-a-buffer*) - (len-x len-a) - (y *bignum-gcd-b-buffer*) - (len-y len-b) - (z *bignum-gcd-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) - (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 ((= a-digit b-digit)) - ((> 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) - (if (oddp (%bignum-ref a 0)) - len-a - (do ((i 1 (1+ i)) - (x (%ashr (%bignum-ref a 0) 1) (%ashr x 1))) - ((oddp x) - (bignum-buffer-ashift-right a len-a i))))) - -(defun bignum-factors-of-two (a len-a b len-b) - (do ((i 0 (1+ i)) - (end (min len-a len-b))) - ((= i end) (error "Unexpected zero bignums?")) - (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)))))))) - -|# - - -;;;; 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)) - (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 - -(defun negate-bignum (x) - (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))) - (%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) - -;;; %MAKE-ONES -- Internal. -;;; -;;; This returns n 1's in the low end of a digit, and it assumes n is between -;;; 0 and digit-size inclusively. -;;; -(proclaim '(inline %make-ones)) -(proclaim '(function %make-ones ((integer 0 (#.digit-size))) - bignum-element-type)) -;;; -(defun %make-ones (n) - (declare (type (integer 0 (#.digit-size)) n)) - (the bignum-element-type - (if (= n digit-size) all-ones-digit (1- (%ashl 1 n))))) - - -(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. -;;; -;;; The formation of a new digit could involve two logical shifts and a logical -;;; OR, but since Common Lisp is missing the former, we use some masks: -;;; Low-mask is start-pos number of low ones. We use this to GRAB low bits -;;; from the i+1'th source digit, shifting them to the high end of a word to -;;; form a resulting digit. -;;; High-mask is digit-size minus start-pos number of low ones. We use this to -;;; CLEAR high bits after shifting down some high bits from the i'th source -;;; digit to form a resulting digit. -;;; -(defmacro shift-right-unaligned (source start-digit start-pos res-len-form - termination - &optional result) - `(let* ((low-mask (%make-ones ,start-pos)) - (high-bits-in-first-digit (- digit-size ,start-pos)) - (high-mask (%make-ones high-bits-in-first-digit)) - (minus-start-pos (- ,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) - (type bignum-element-type low-mask high-mask)) - (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 (logand (ash (%bignum-ref ,source i) minus-start-pos) - ;; LOGAND should be unnecessary here with a logical - ;; right shift or a correct unsigned-byte-32 one. - high-mask) - (%ashl (logand (%bignum-ref ,source i+1) low-mask) - 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)) - (x (abs x))) ;For now, ABS x. - (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. -;;; -;;; This is mostly equivalent to -;;; (replace res bignum :start2 digits) -;;; If I knew there was a good REPLACE transform that handled -;;; '(unsigned-byte 32) element arrays properly, I could use it. -;;; -(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)) - (do ((i digits (1+ i)) - (j 0 (1+ j))) - ((= j res-len) (%normalize-bignum res res-len)) - (declare (type bignum-index i j)) - (setf (%bignum-ref res j) (%bignum-ref bignum i))))) - - -;;; 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)) - (unless (typep x 'fixnum) - (error "Can't shift a bignum number of bits.")) - (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))) - (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. -;;; -;;; This is mostly equivalent to -;;; (replace res bignum :start1 digits) -;;; If I knew there was a good REPLACE transform that handled -;;; '(unsigned-byte 32) element arrays properly, I could use it. -;;; -(defun bignum-ashift-left-digits (bignum bignum-len digits) - (let* ((res-len (+ bignum-len digits)) - (res (%allocate-bignum res-len))) - (do ((i 0 (1+ i)) - (j digits (1+ j))) - ((= j res-len) res) - (setf (%bignum-ref res j) (%bignum-ref bignum i))))) - -;;; 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)) - (let* ((mask (%make-ones n-bits)) - (-remaining-bits (- n-bits digit-size)) - (res-len-1 (1- res-len)) - (res (or res (%allocate-bignum res-len)))) - (declare (type bignum-index res-len res-len-1) - (type bignum-element-type mask)) - (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 (logand (ash (%bignum-ref bignum i) -remaining-bits) - ;; LOGAND should be unnecessary here with a - ;; logical right n-bits or a correct - ;; unsigned-byte-32 one. - mask) - (%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))) - ((zerop i) 0) - (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 (> a-digit b-digit) - (return 1)) - (when (> b-digit a-digit) - (return -1))))) - ((> len-a len-b) - (if a-plusp 1 -1)) - (t - (if a-plusp -1 1))))) - - - -;;;; Float conversion. - -#| - -(eval-when (compile eval) - -;;; BIGNUM-TO-FLOAT -- Internal. -;;; -;;; This macro takes the float format to generate, a function that will -;;; convert a *signed* digit into that format, and a dunction that will -;;; convert an *unsigned* digit into that format. -;;; -(defmacro bignum-to-float (format signed-conv unsigned-conv) - `(do* ((posn (1- (%bignum-length bignum)) (1- posn)) - (res (,signed-conv (%bignum-ref bignum posn)) - (+ (* res ,(coerce (ash 1 digit-size) format)) - (,unsigned-conv (%bignum-ref bignum posn))))) - ((= posn 0) res))) - -) ;EVAL-WHEN - - -;;; BIGNUM-TO-SINGLE-FLOAT -- Public. -;;; -;;; This converts bignum into a single float. -;;; -(defun bignum-to-single-float (bignum) - (declare (type bignum-type bignum)) - (bignum-to-float single-float - %signed-digit-to-single-float - %digit-to-single-float)) - -;;; BIGNUM-TO-DOUBLE-FLOAT -- Public. -;;; -;;; This converts bignum into a double float. -;;; -(defun bignum-to-double-float (bignum) - (declare (type bignum-type bignum)) - (bignum-to-float double-float - %signed-digit-to-double-float - %digit-to-double-float)) - -|# - - - -;;;; Integer length and logcount - -#| Original Bill code: - -(defun bignum-integer-length (bignum) - (declare (type bignum-type bignum)) - (let* ((len (%bignum-length bignum)) - (len-1 (1- len)) - (plusp (%bignum-0-or-plusp bignum len))) - (if plusp - (let ((digit (%bignum-ref bignum len-1))) - (declare (type bignum-element-type digit)) - (if (zerop digit) - (* len-1 digit-size) - (+ (* len-1 digit-size) - (dotimes (i digit-size digit-size) - (when (zerop digit) (return i)) - (setf digit (ash digit -1)))))) - (multiple-value-bind (carry last-digit) - (bignum-negate-loop bignum len) - (declare (type bignum-element-type last-digit)) - (unless (zerop carry) - (error "Unexpected non-zero negation carry.")) - (+ (* len-1 digit-size) - (dotimes (i digit-size digit-size) - (when (zerop last-digit) (return i)) - (setf last-digit (ash last-digit -1)))))))) - -|# - -(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) - -#| - -(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* (%allocate-bignum 5)) -(defvar *truncate-y* (%allocate-bignum 5)) - -;;; 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))) - (y (if y-plusp y (negate-bignum y))) - (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)) - ((bignum> 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 ((y-shift (shift-y-for-truncate y))) - (multiple-value-bind (len-x len-y) - (shift-and-store-truncate-buffers - x len-x y len-y y-shift) - (declare (type bignum-index len-x len-y)) - (values (do-truncate len-x len-y) - ;; DO-TRUNCATE must execute first. - (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) (- q)) - (t (negate-bignum-in-place q)))) - (rem (cond (x-plusp r) - ((typep r '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. -;;; -(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. -;;; -(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) - (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 0) - (guess*y-hold 0) - (borrow 1) - (i low-x-digit)) - (declare (type bignum-element-type guess*y-hold) - (type bignum-index i) - (fixnum carry borrow i)) - ;; Multiply guess and divisor, subtracting from dividend simultaneously. - (dotimes (j len-y) - (multiple-value-bind (high-digit low-digit) - (%multiply guess (%bignum-ref *truncate-y* j)) - (declare (type bignum-element-type high-digit low-digit)) - (multiple-value-bind (low-digit temp-carry) - (%add-with-carry low-digit guess*y-hold carry) - (declare (type bignum-element-type low-digit)) - (multiple-value-bind (high-digit temp-carry) - (%add-with-carry high-digit temp-carry 0) - (declare (type bignum-element-type high-digit)) - (setf guess*y-hold high-digit) - (setf carry temp-carry) - (multiple-value-bind (x temp-borrow) - (%subtract-with-borrow - (%bignum-ref *truncate-x* i) - low-digit borrow) - (declare (type bignum-element-type x)) - (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) - guess*y-hold 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 two large in magnitude. - (format t "~&***GUESS ONE HIGH***~%") - (setf i low-x-digit) - (setf 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) carry 0)) - (if (%digit-0-or-plusp guess) - (%subtract-with-borrow guess 1 1) - (%add-with-carry guess 1 0)))))) - -;;; 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 ??? -;;; I'm not sure why, but we test this ignoring the high digit, comparing only -;;; the bottom two digits with the two digits of guess*y2. If guess*y2 is -;;; greater, then we need to decrement the guess and test again. -;;; -(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 (= 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) - (ignore 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)) - (let ((middle-digit (%subtract-with-borrow x-i-1 low-guess*y1 1))) - ;; Supplying borrow of 1 means there was no borrow, and we know - ;; x-i-2 minus 0 requires no borrow. - (declare (type bignum-element-type middle-digit)) - (if (or (> high-guess*y2 middle-digit) - (and (= middle-digit high-guess*y2) - (> low-guess*y2 x-i-2))) - (progn (decf guess)) - (progn (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. -;;; -(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)) - (if (zerop last) - (1- digit-size) - (- digit-size - (dotimes (i digit-size) - (when (zerop last) (return i)) - (setf last (ash last -1))) - 1)))) - -;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS -- Internal. -;;; -;;; Stores two bignums into the truncation bignum buffers, shifting them on the -;;; way in. This first makes sure the buffers are big enough and that the last -;;; element possibly needed is zero, in case we never store there. This -;;; assumes x and y are positive and at least two in length. Return the number -;;; of pertinent digits in each buffer, but make sure *truncate-x* has at least -;;; three digits. We also check for x and y having the same length because -;;; similar lengths make TRY-BIGNUM-TRUNCATE-GUESS index below 0 in x when -;;; doing the subtraction; just make sure x is one greater. -;;; -(defun shift-and-store-truncate-buffers (x len-x y len-y shift) - (declare (type bignum-index len-x len-y)) - (let ((len-x+1 (1+ len-x)) - (len-y+1 (1+ len-y))) - (macrolet ((frob (var len) - `(progn - (when (< (the bignum-index (%bignum-length ,var)) ,len) - (setf ,var (%allocate-bignum ,len))) - (setf (%bignum-ref ,var (1- ,len)) 0)))) - (frob *truncate-x* len-x+1) - (frob *truncate-y* len-y+1) - (let ((len-x (bignum-ashift-left-unaligned x 0 shift len-x+1 - *truncate-x*)) - (len-y (bignum-ashift-left-unaligned y 0 shift len-y+1 - *truncate-y*))) - (when (< len-x 3) - (setf (%bignum-ref *truncate-x* len-x) 0) - (setf len-x 3)) - (when (= len-x len-y) - (let ((old-x *truncate-x*) - (len-x+2 (1+ len-x+1))) - (frob *truncate-x* len-x+2) - (replace *truncate-x* old-x :end1 len-x+1) - (setf len-x len-x+2))) - (values len-x len-y))))) - -|# - - -;;;; 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))) diff --git a/code/bit-bash.lisp b/code/bit-bash.lisp deleted file mode 100644 index 006140dd4966b20f5ab98a938d7168b519984f82..0000000000000000000000000000000000000000 --- a/code/bit-bash.lisp +++ /dev/null @@ -1,361 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Functions to implement bit bashing. -;;; -;;; Written by William Lott. -;;; - -(in-package "LISP") - - - -;;;; Constants and Types. - - -(eval-when (compile load eval) - -(defconstant unit-bits 32 - "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 word-offset () - `(integer 0 (,(ceiling max-bits unit-bits)))) - - -); eval-when - - - -;;;; Macros for generating bit-bashing routines. - - -(eval-when (compile eval) - -(defmacro end-bits (count) - "Returns the byte spec for COUNT bits at the end of a word, i.e. the bits - at the largest address." - (ecase vm:target-byte-order - (:little-endian `(byte ,count (- unit-bits ,count))) - (:big-endian `(byte ,count 0)))) - -(defmacro start-bits (count) - "Returns the byte spec for COUNT bits at the start of a word, i.e. the bits - at the smallest address." - (ecase vm:target-byte-order - (:little-endian `(byte ,count 0)) - (:big-endian `(byte ,count (- unit-bits ,count))))) - -(defmacro middle-bits (count where) - "Return the byte spec for COUNT bits starting at bit WHERE. WHERE of zero - corresponds to the start of the word (lowest address) and WHERE of - unit-bits corresponds to the end of the word (highest address). In other - words, act like :little-endian" - (ecase vm:target-byte-order - (:little-endian `(byte ,count ,where)) - (:big-endian `(byte ,count (- unit-bits ,where ,count))))) - - -(defmacro bit-bash-bindings (&body guts) - `(let* ((final-bits (mod (+ len dst-bit-offset) unit-bits)) - (interior (floor (- len final-bits) unit-bits))) - (declare (type bit-offset final-bits) - (type word-offset interior)) - ,@guts)) - -(defmacro bind-srcs ((kind incf-p ref-fn) &body body) - (ecase kind - (:constant `(progn - ,@body - ,@(when incf-p - `((incf dst-word-offset))))) - (:unary `(let ((next-1 (,ref-fn src-1 src-1-word-offset))) - (declare (type unit next-1)) - ,@body - ,@(when incf-p - '((incf dst-word-offset) - (incf src-1-word-offset))))) - (:binary `(let ((next-1 (,ref-fn src-1 src-1-word-offset)) - (next-2 (,ref-fn src-2 src-2-word-offset))) - (declare (type unit next-1 next-2)) - ,@body - ,@(when incf-p - '((incf dst-word-offset) - (incf src-1-word-offset) - (incf src-2-word-offset))))))) - - -(defmacro bit-bash-loop (kind ref-fn set-fn function &optional update) - `(progn - (unless (zerop dst-bit-offset) - (bind-srcs (,kind t ,ref-fn) - (setf (,set-fn dst dst-word-offset) - (the unit - (dpb ,function - (end-bits (the (integer (0) (#.unit-bits)) - (- unit-bits dst-bit-offset))) - (,set-fn dst dst-word-offset)))) - ,update)) - (dotimes (count interior) - (declare (type word-offset count)) - (bind-srcs (,kind t ,ref-fn) - (setf (,set-fn dst dst-word-offset) ,function) - ,update)) - (unless (zerop final-bits) - (bind-srcs (,kind nil ,ref-fn) - (setf (,set-fn dst dst-word-offset) - (the unit - (dpb ,function - (start-bits (the (integer (0) (#.unit-bits)) - final-bits)) - (,set-fn dst dst-word-offset)))))))) - - -(defun pick-args (op kind arg1 arg2) - (ecase kind - (:constant - op) - (:unary - (list op arg1)) - (:binary - (list op arg1 arg2)))) - -(defmacro def-bit-basher (name op &optional (kind :binary) (ref-fn '%raw-bits) - (set-fn ref-fn)) - (let ((form - `(cond - ((<= (+ dst-bit-offset len) unit-bits) - ;; It's narrow. - (setf (,set-fn dst dst-word-offset) - (the unit - (dpb (the unit - ,(pick-args op kind - `(the unit - (ldb (middle-bits (the bit-offset len) - src-1-bit-offset) - (,ref-fn src-1 - src-1-word-offset))) - `(the unit - (ldb (middle-bits (the bit-offset len) - src-2-bit-offset) - (,ref-fn src-2 - src-2-word-offset))))) - (middle-bits len dst-bit-offset) - (,set-fn dst dst-word-offset))))) - (,(ecase kind - (:constant t) - (:unary '(= src-1-bit-offset dst-bit-offset)) - (:binary '(= src-1-bit-offset src-2-bit-offset dst-bit-offset))) - ;; Everything is aligned evenly. - (bit-bash-bindings - (bit-bash-loop ,kind ,ref-fn ,set-fn - ,(pick-args op kind 'next-1 'next-2)))) - ,@(when (eq kind :binary) - `(((= src-1-bit-offset dst-bit-offset) - ;; Src1 and the destination are aligned, but src2 is not. - (bit-bash-bindings - (when (> dst-bit-offset src-2-bit-offset) - (decf src-2-word-offset)) - (let* ((src-2-shift - (mod (- dst-offset src-2-offset) unit-bits)) - (prev-2 (,ref-fn src-2 src-2-word-offset))) - (declare (type bit-offset src-2-shift)) - (declare (type unit prev-2)) - (incf src-2-word-offset) - (bit-bash-loop ,kind ,ref-fn ,set-fn - (,op next-1 (merge-bits src-2-shift prev-2 next-2)) - (setf prev-2 next-2))))) - ((= src-2-bit-offset - dst-bit-offset) - ;; Src2 and the destination are aligned, but src1 is not. - (bit-bash-bindings - (when (> dst-bit-offset src-1-bit-offset) - (decf src-1-word-offset)) - (let* ((src-1-shift - (mod (- dst-offset src-1-offset) unit-bits)) - (prev-1 (,ref-fn src-1 src-1-word-offset))) - (declare (type bit-offset src-1-shift)) - (declare (type unit prev-1)) - (incf src-1-word-offset) - (bit-bash-loop ,kind ,ref-fn ,set-fn - (,op (merge-bits src-1-shift prev-1 next-1) next-2) - (setf prev-1 next-1))))))) - ,@(unless (eq kind :constant) - `((t - ;; Nothing is aligned. Ack. - (bit-bash-bindings - (when (> dst-bit-offset src-1-bit-offset) - (decf src-1-word-offset)) - ,@(when (eq kind :binary) - '((when (> dst-bit-offset src-2-bit-offset) - (decf src-2-word-offset)))) - (let* ((src-1-shift - (mod (- dst-offset src-1-offset) unit-bits)) - (prev-1 (,ref-fn src-1 src-1-word-offset)) - ,@(when (eq kind :binary) - `((src-2-shift - (mod (- dst-offset src-2-offset) unit-bits)) - (prev-2 (,ref-fn src-2 src-2-word-offset))))) - (declare (type bit-offset src-1-shift - ,@(when (eq kind :binary) - '(src-2-shift))) - (type unit prev-1 - ,@(when (eq kind :binary) '(prev-2)))) - (incf src-1-word-offset) - ,@(when (eq kind :binary) - '((incf src-2-word-offset))) - (bit-bash-loop ,kind ,ref-fn ,set-fn - ,(pick-args op kind - '(merge-bits src-1-shift prev-1 next-1) - '(merge-bits src-2-shift prev-2 next-2)) - (setf prev-1 next-1 - ,@(when (eq kind :binary) - '(prev-2 next-2))))))))))) - (function-args '(len)) - (function-decls '(len))) - (dolist (arg (ecase kind - (:constant '(dst)) - (:unary '(dst src-1)) - (:binary '(dst src-2 src-1)))) - (let* ((name (string arg)) - (offset - (intern (concatenate 'simple-string name "-OFFSET"))) - (bit-offset - (intern (concatenate 'simple-string name "-BIT-OFFSET"))) - (word-offset - (intern (concatenate 'simple-string name "-WORD-OFFSET")))) - (setf form - `(multiple-value-bind (,word-offset ,bit-offset) - (floor ,offset unit-bits) - (declare (type word-offset ,word-offset) - (type bit-offset ,bit-offset)) - ,form)) - (push offset function-args) - (push offset function-decls) - (push arg function-args))) - `(defun ,name ,function-args - (declare (type offset ,@function-decls)) - ,form))) - -); eval when - - -;;;; Support routines. - -;;; These are compiler primitives. - -(defun %raw-bits (object offset) - (declare (type index offset)) - (%raw-bits object offset)) - -(defun (setf %raw-bits) (object offset value) - (declare (type index offset) - (type unit value)) - (setf (%raw-bits object offset) value)) - -(defun merge-bits (shift prev next) - "Return (ldb (byte 32 0) (ash (logior (ash prev 32) next) (- shift))) but - stay out of bignum land." - (declare (type bit-offset shift) - (type unit prev next)) - (merge-bits shift prev next)) - - -;;; These are not supported as primitives. - -#| - -(proclaim '(inline 32bit-logical-eqv 32bit-logical-nand 32bit-logical-andc1 - 32bit-logical-andc2 32bit-logical-orc1 32bit-logical-orc2)) - -(defun 32bit-logical-eqv (x y) - (32bit-logical-not (32bit-logical-xor x y))) - -(defun 32bit-logical-nand (x y) - (32bit-logical-not (32bit-logical-and x y))) - -(defun 32bit-logical-andc1 (x y) - (32bit-logical-and (32bit-logical-not x) y)) - -(defun 32bit-logical-andc2 (x y) - (32bit-logical-and x (32bit-logical-not y))) - -(defun 32bit-logical-orc1 (x y) - (32bit-logical-or (32bit-logical-not x) y)) - -(defun 32bit-logical-orc2 (x y) - (32bit-logical-or x (32bit-logical-not y))) - - - -;;;; The actual bashers. - -(proclaim '(optimize (speed 3) (safety 0))) - -(def-bit-basher bit-bash-clear 0 :constant) -(def-bit-basher bit-bash-set (1- (ash 1 unit-bits)) :constant) - -(def-bit-basher bit-bash-not 32bit-logical-not :unary) - -(def-bit-basher bit-bash-and 32bit-logical-and) -(def-bit-basher bit-bash-ior 32bit-logical-or) -(def-bit-basher bit-bash-xor 32bit-logical-xor) -(def-bit-basher bit-bash-eqv 32bit-logical-eqv) -(def-bit-basher bit-bash-nand 32bit-logical-nand) -(def-bit-basher bit-bash-nor 32bit-logical-nor) -(def-bit-basher bit-bash-andc1 32bit-logical-andc1) -(def-bit-basher bit-bash-andc2 32bit-logical-andc2) -(def-bit-basher bit-bash-orc1 32bit-logical-orc1) -(def-bit-basher bit-bash-orc2 32bit-logical-orc2) - - -;;; Sap-ref-32 can be used to index into SAP objects. - -(def-bit-basher system-area-clear 0 :constant sap-ref-32) - -|# - - -;;;; Copy routines. - -;;; These are written in assembler. - -(defun copy-to-system-area (src src-offset dst dst-offset length) - (declare (type (simple-unboxed-array (*)) src) - (type system-area-pointer dst) - (type index src-offset dst-offset length)) - (copy-to-system-area src src-offset dst dst-offset length)) - -(defun copy-from-system-area (src src-offset dst dst-offset length) - (declare (type system-area-pointer src) - (type (simple-unboxed-array (*)) dst) - (type index src-offset dst-offset length)) - (copy-from-system-area src src-offset dst dst-offset length)) - -(defun system-area-copy (src src-offset dst dst-offset length) - (declare (type system-area-pointer src dst) - (type index src-offset dst-offset length)) - (system-area-copy src src-offset dst dst-offset length)) - -(defun bit-bash-copy (src src-offset dst dst-offset length) - (declare (type (simple-unboxed-array (*)) src dst) - (type index src-offset dst-offset length)) - (bit-bash-copy src src-offset dst dst-offset length)) diff --git a/code/c-call.lisp b/code/c-call.lisp deleted file mode 100644 index 18d86aa15f4e45f60359e3fa1573891ed0a8b04a..0000000000000000000000000000000000000000 --- a/code/c-call.lisp +++ /dev/null @@ -1,886 +0,0 @@ -;;; -*- Mode: Lisp; Package: EXTENSIONS; Log: code.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 used for calling out to C routines that are -;;; linked into the Lisp process. -;;; -;;; Written by Rob MacLachlan. -;;; -(in-package "EXTENSIONS" :use '("LISP" "SYSTEM")) -(import '(lisp::enumeration-info lisp::enumeration-info-size - lisp::enumeration-info-kind - lisp::enumeration-info-offset - lisp::enumeration-info-to - lisp::call-lisp-from-c)) -(export '(c-sizeof def-c-type def-c-record def-c-array def-c-pointer - char unsigned-char short unsigned-short - int unsigned-int long unsigned-long - void def-c-routine def-c-variable - def-c-procedure)) - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* t)) - -#+nil -(defvar foreign-routines-defined NIL - "List of symbol/routine name pairs used to reset code pointers - for foreign routines.") - -#+nil -(defvar foreign-variables-defined NIL - "List of symbol/variable name pairs used to reset pointers to - foreign variables.") - -(eval-when (compile load eval) - -;;; The C-Type structure is used to represent aspects of C data representations -;;; that aren't directly implemented by Aliens. -;;; -(defstruct c-type - ;; - ;; A form which is a printable representation of this type. - description - ;; - ;; The size in bits of objects of this type. NIL if the size is variable. - (size nil :type (or unsigned-byte null)) - ;; - ;; The bit alignment used for allocating objects of this type. - (alignment nil :type (integer 1 32))) - -(defun %print-c-type (s stream d) - (declare (ignore d)) - (format stream "#<C-Type ~S>" (c-type-description s))) - - -;;; A c-type which corresponds directly to an alien type. The Description is -;;; the alien type. -;;; -(defstruct (primitive-type - (:include c-type) - (:print-function %print-c-type))) - - -;;; The Record-Type represnts a c structure type. -;;; -(defstruct (record-type - (:include c-type) - (:print-function %print-c-type)) - ;; - ;; A list of the field descriptions for the fields in the record, in order of - ;; increasing bit offset. - (fields nil :type list)) - - -;;; The Field-Info structure describes a single field in a record. The Size -;;; recorded here may be larger than the Size in the Type, since more bits may -;;; be allocated to the field than are actually necessary to hold a value of -;;; that type. -;;; -(defstruct field-info - ;; - ;; The symbol name of this field. - (name nil :type symbol) - ;; - ;; The c-type of this field. - (type nil :type c-type) - ;; - ;; The bit offset from the start of the record that this field is located at. - (offset nil :type unsigned-byte) - ;; - ;; The number of bits in this field. - (size nil :type unsigned-byte)) - - -;;; The Array-Type represents a C array type. -;;; -(defstruct (array-type - (:include c-type) - (:print-function %print-c-type)) - ;; - ;; The c-type of the elements in the array. - (element-type nil :type c-type) - ;; - ;; The number of bits used to store each element. May be larger than the - ;; Size in the Element-Type due to padding. - (element-size nil :type unsigned-byte)) - - -;;; The Pointer-Type represents a C pointer type. -;;; -(defstruct (pointer-type - (:include c-type) - (:print-function %print-c-type)) - ;; - ;; The type of object pointed to. - (to nil :type c-type)) - - -;;; An EQ hashtable from the names of c-types to the structures describing them. -;;; -(defvar *c-type-names* (make-hash-table :test #'eq)) - -;;; Find-Alignment -- Internal -;;; -;;; Return the bit alignment for an object of the specified Size. -;;; -(proclaim '(function find-alignment (unsigned-byte) (integer 1 32))) -(defun find-alignment (size) - (cond ((> size 16) 32) - ((> size 8) 16) - ((> size 1) 8) - (t 1))) - - -;;; Align-Offset -- Internal -;;; -;;; Return Offset with enough added to bring it out to the specified -;;; Alignment. -;;; -(proclaim '(function align-offset (unsigned-byte (integer 1 32)) - unsigned-byte)) -(defun align-offset (offset alignment) - (let ((extra (rem offset alignment))) - (if (zerop extra) offset (+ offset (- alignment extra))))) - - -;;; Get-C-Type -- Internal -;;; -;;; Get the C-Type structure corresponding to the supplied Spec. If the -;;; spec is a named type, then just return the info. Otherwise, the Spec must -;;; be a primitive Alien type with an obvious size. If we can't decide the -;;; Spec, we signal an error. -;;; -(proclaim '(function get-c-type (t) c-type)) -(defun get-c-type (spec) - (cond ((gethash spec *c-type-names*)) - ((member spec - '(c-procedure short-float long-float null-terminated-string)) - (let ((size (if (eq spec 'long-float) 64 32))) - (make-primitive-type - :description spec - :size size - :alignment (find-alignment size)))) - ((and (listp spec) (> (length spec) 1) - (symbolp (first spec))) - (case (first spec) - ((signed-byte unsigned-byte) - (let ((size (second spec))) - (make-primitive-type - :description spec - :size size - :alignment (find-alignment size)))) - (perq-string - (make-primitive-type - :description spec - :size (* (1+ (second spec)) 8) - :alignment 8)) - (null-terminated-string - (make-primitive-type - :description spec - :size (* (second spec) 8) - :alignment 8)) - (enumeration - (let* ((name (second spec)) - (info (get name 'enumeration-info))) - (unless info - (error "~S is not a defined enumeration." name)) - (let ((size (enumeration-info-size info))) - (make-primitive-type - :description spec - :size size - :alignment (find-alignment size))))) - (pointer - (make-primitive-type - :description spec - :size vm:word-bits - :alignment vm:word-bits)) - (alien - (let ((size (third spec))) - (unless size - (error "Must specify size in Alien C-Type: ~S." spec)) - (make-primitive-type - :description spec - :size size - :alignment (find-alignment size)))) - (t - (error "~S is not a known C-Type." spec)))) - (t (error "Losing C-Type: ~S." spec)))) - - -); Eval-When (Compile Load Eval) - - -;;;; Exported type operations: - -(eval-when (compile load eval) - -;;; Symbolicate -- Internal -;;; -;;; 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) - - -;;; C-Sizeof -- Public -;;; -(proclaim '(function c-sizeof (t) unsigned-byte)) -(defun c-sizeof (spec) - "Return the size in bits of the C-Type described by Spec." - (c-type-size (get-c-type spec))) - -#-new-compiler -(pushnew 'clc::fold-transform (get 'c-sizeof 'clc::clc-transforms)) - - -;;; Def-C-Type -- Public -;;; -(defmacro def-c-type (name spec) - "Def-C-Type Name Spec - Define Name to be an abbreviation for the C-Type indicated by Spec." - `(eval-when (compile load eval) - (setf (gethash ',name *c-type-names*) ',(get-c-type spec)) - ',name)) - - -;;; Def-C-Record -- Public -;;; -(defmacro def-c-record (name &rest fields) - "Name {(Name Type)}* - Define a record C-Type. Name is the name of the type. The Fields and Types - specify the name and type of each field. An Alien operator Name-Field is - defined to select each field. The Function Make-Name creates a dynamic alien - of the appropriate size and type. Also a pointer to name type is created, so - that you can have pointers to a thing of type name in the definition of name. - The name of the pointer type is *name." - (let* ((info ()) - (pname (symbolicate "*" name)) - (pos 0) - (align 0) - (res (make-record-type - :description name - :size NIL - :alignment 1 - :fields NIL)) - (pres (make-pointer-type - :description NIL - :size 32 - :alignment 32 - :to res))) - (setf (gethash name *c-type-names*) res) - (setf (gethash pname *c-type-names*) pres) - (dolist (field fields) - (unless (= (length field) 2) - (error "Malformed field specification: ~S." field)) - (let* ((ftype (second field)) - (type (if (eq ftype pname) pname (get-c-type (second field)))) - (size (if (eq ftype pname) 32 (c-type-size type))) - (start (align-offset pos (if (eq ftype pname) 32 - (c-type-alignment type))))) - (push (make-field-info :name (first field) - :type type - :offset start - :size size) - info) - (unless size - (error "Variable size field ~A in record ~A not allowd." - (first field) name)) - (setq pos (+ start size)) - (setq align (max (find-alignment size) align)))) - - (setf (record-type-size res) pos) - (setf (record-type-alignment res) align) - (setf (record-type-fields res) (nreverse info)) - (setf (pointer-type-description pres) `(alien ,name ,pos)) - `(progn - (eval-when (compile load eval) - (setf (gethash ',name *c-type-names*) ',res) - (setf (gethash ',pname *c-type-names*) ',pres)) - (defun ,(symbolicate "MAKE-" name) () - (make-alien ',name ,(c-type-size res))) - (defoperator (,(symbolicate "INDIRECT-" pname) - ,(record-type-description res)) - ((pointer ,pname)) - `(alien-indirect (alien-value ,pointer) ,,pos)) - ,@(define-record-operators res)))) - -(eval-when (compile load eval) - -;;; Define-Record-Operators -- Internal -;;; -;;; Compute the operator definitions for accessing the fields in Record. -;;; -(proclaim '(function define-record-operators (record-type) list)) -(defun define-record-operators (record) - (let ((name (c-type-description record))) - (mapcar #'(lambda (x) - `(defoperator (,(symbolicate name "-" (field-info-name x)) - ,(c-type-description (let ((type (field-info-type x))) - (if (structurep type) type - (get-c-type type))))) - ((rec ,name)) - `(alien-index (alien-value ,rec) - ,,(field-info-offset x) - ,,(field-info-size x)))) - (record-type-fields record)))) - -); Eval-When (Compile Load Eval) - - -;;; Def-C-Array -- Public -;;; -(defmacro def-c-array (name element-type &optional size) - "Def-C-Array Name Element-Type [Size] - Define Name to be an array C-Type with the specified Element-Type. If size - is not specified, then it is a variable size array." - (let* ((eltype (get-c-type element-type)) - (elalign (c-type-alignment eltype)) - (elsize (align-offset (c-type-size eltype) elalign)) - (elts (eval size)) - (res (make-array-type :description name - :size (if elts (* elsize elts) nil) - :alignment elalign - :element-type eltype - :element-size elsize))) - `(progn - (eval-when (compile load eval) - (setf (gethash ',name *c-type-names*) ',res)) - - (defun ,(symbolicate "MAKE-" name) - ,(if elts () '(size)) - (make-alien ',name ,(if elts (* elsize elts) `(* ,elsize size)))) - - (defoperator (,(symbolicate name "-REF") - ,(c-type-description eltype)) - ((array ,name) i) - `(alien-index (alien-value ,array) (* ,,elsize ,i) ,,elsize))))) - - -;;; Def-C-Pointer -- Public -;;; -(defmacro def-c-pointer (name to) - "Def-C-Pointer Name To - Define a pointer C-Type which points to an object of type To." - (let* ((type (get-c-type to)) - (res (make-pointer-type - :description `(alien ,(c-type-description type) - ,@(when (c-type-size type) - `(,(c-type-size type)))) - :size 32 - :alignment 32 - :to type))) - `(progn - (eval-when (compile load eval) - (setf (gethash ',name *c-type-names*) ',res)) - (defoperator (,(symbolicate "INDIRECT-" name) - ,(c-type-description type)) - ((pointer ,name) - ,@(unless (c-type-size type) - '(size))) - `(alien-indirect (alien-value ,pointer) - ,,(or (c-type-size type) 'size)))))) - -;;; Some trivial builtin types... -;;; -(setf (gethash 'port *c-type-names*) - (make-primitive-type :description 'port - :size 32 - :alignment 32)) - -(setf (gethash 'string-char *c-type-names*) - (make-primitive-type :description 'string-char - :size 8 - :alignment 8)) - -(setf (gethash 'boolean *c-type-names*) - (make-primitive-type :description 'boolean - :size 1 - :alignment 1)) - -(setf (gethash 'system-area-pointer *c-type-names*) - (make-primitive-type :description 'system-area-pointer - :size 32 - :alignment 32)) - - -;;; Some more standard types: - -(def-c-type char (signed-byte 8)) -(def-c-type unsigned-char (unsigned-byte 8)) -(def-c-type short (signed-byte 16)) -(def-c-type unsigned-short (unsigned-byte 16)) -(def-c-type int (signed-byte 32)) -(def-c-type unsigned-int (unsigned-byte 32)) -(def-c-type long (signed-byte 32)) -(def-c-type unsigned-long (unsigned-byte 32)) - -(def-c-pointer *char char) - - - -(defstruct (routine-info - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Routine-Info ~S>" (routine-info-name s))))) - ;; - ;; String name of the routine and symbol name of the interface function. - (name "" :type string) - (function-name nil :type symbol) - ;; - ;; List of all the doc strings. - docs - ;; - ;; The number of words of arguments. - (arg-size 0 :type unsigned-byte) - ;; - ;; The name of the record that describes all the stuff on the stack. - (stack-record nil :type symbol) - ;; - ;; The name of the alien :copy args are allocated in. - (copy-args-buffer nil :type (or null symbol)) - ;; - ;; List of Arg-Info structures describing the args. - (args nil :type list) - ;; - ;; The specified return-type for the function value. Null if Void was - ;; specified. - (return-type nil :type (or c-type null)) - ;; - ;; The SC the return value is passed in. - return-sc - ;; - ;; The vop we should use to coerce the return value. - return-move-vop - ;; - ;; The type for the return value, after the move vop and before any lisp - ;; level coerce code. - return-lisp-type - ;; - ;; Generate the lisp-level code to coerce the return value (if any) - return-coerce-generator - ) - -(defstruct arg-info - ;; - ;; Symbol name of the arg. - (name nil :type symbol) - ;; - ;; C-Type describing the actual argument to the routine. - (type nil :type c-type) - ;; - ;; Specified mode and options. - mode - options - ;; - ;; Where we pass this arg. Either a storage class or :stack - allocation - ;; - ;; Either the offset in the storage class or stack. - offset - ;; - ;; Either the vop necessary to do the move, or the stack operator. - accessor - ;; - ;; Either operator to get at the arg, or NIL if it's :in. - buffer - ;; - ;; Either the name for :in, or some form for others. - passing-form - ) - - -(defun anotate-foreign-call (info) - (let ((offset 0)) - (dolist (arg (routine-info-args info)) - (setf (arg-info-allocation arg) :stack) - (setf (arg-info-offset arg) offset) - (let ((size (if (eq (arg-info-mode arg) :in) - (c-type-size (arg-info-type arg)) - (c-sizeof 'system-area-pointer)))) - (setf offset (align-offset (+ offset size) - (find-alignment size))))) - (setf (routine-info-arg-size info) offset)) - (multiple-value-bind - (sc move-vop lisp-type) - (let ((type (routine-info-return-type info))) - (etypecase type - (null) - (primitive-type - (let* ((descr (c-type-description type)) - (name (if (atom descr) descr (car descr))) - (arg (if (consp descr) (cadr descr)))) - (ecase name - (signed-byte - (values 'c::signed-reg 'c::move descr)) - (unsigned-byte - (values 'c::unsigned-reg 'c::move descr)) - (null-terminated-string - (setf (routine-info-return-coerce-generator info) - #'(lambda (form) - `(import-string ,form))) - (values 'c::sap-reg 'c::move 'system-area-pointer)) - (boolean - (setf (routine-info-return-coerce-generator info) - #'(lambda (form) - `(not (zerop ,form)))) - (values 'c::signed-reg 'c::move 'fixnum)) - ((system-area-pointer alien) - (when (eq name 'alien) - (unless (> (length descr) 2) - (error "Alien return types must include the size: ~S" - descr)) - (setf (routine-info-return-coerce-generator info) - #'(lambda (form) - `(make-alien ',arg ',(caddr descr) ,form)))) - (values 'c::sap-reg 'c::move 'system-area-pointer)) - ((enumeration simple-string port short-float long-float) - (error "Can't return ~S yet." descr))))) - (record-type - (error "Can't return ~S yet." (c-type-description type))) - ((or array-type pointer-type) - (unless (c-type-size type) - (error "Can't return arrays of unknown size: ~S" - (c-type-description type))) - (setf (routine-info-return-coerce-generator info) - #'(lambda (form) - `(make-alien ',(c-type-description type) - ',(c-type-size type) - ,form))) - (values 'c::sap-ref 'c::move 'system-area-pointer)))) - (setf (routine-info-return-sc info) sc) - (setf (routine-info-return-move-vop info) move-vop) - (setf (routine-info-return-lisp-type info) lisp-type)) - (undefined-value)) - -(defun pick-names (info) - (setf (routine-info-stack-record info) - (symbolicate (routine-info-function-name info) "-STACK-FRAME")) - (dolist (arg (routine-info-args info)) - (unless (eq (arg-info-mode arg) :in) - (setf (arg-info-buffer arg) - (symbolicate (routine-info-function-name info) - "-" - (arg-info-name arg) - "-BUFFER"))) - (when (eq (arg-info-allocation arg) :stack) - (setf (arg-info-accessor arg) - (symbolicate (routine-info-function-name info) - "-" - (arg-info-name arg) - (if (eq (arg-info-mode arg) :in) - "-DATA" - "-POINTER")))))) - -(defun compute-c-call-forms (info) - (let ((lisp-args nil) - (top-level-forms nil) - (arg-set-forms nil) - (result-get-forms nil)) - (dolist (arg (routine-info-args info)) - (cond ((arg-info-buffer arg) - (unless (pointer-type-p (arg-info-type arg)) - (error "~S argument ~S must be a pointer type." - (arg-info-mode arg) - (arg-info-name arg))) - (let* ((type (pointer-type-to (arg-info-type arg))) - (size (c-type-size type)) - (offset (align-offset (routine-info-arg-size info) - (find-alignment size)))) - (setf (routine-info-arg-size info) - (+ offset size)) - (push `(defoperator (,(arg-info-buffer arg) - ,(c-type-description - (pointer-type-to - (arg-info-type arg)))) - ((foo ,(routine-info-stack-record info))) - `(alien-index (alien-value ,foo) ,,offset ,,size)) - top-level-forms) - (setf (arg-info-passing-form arg) - `(alien-sap (,(arg-info-buffer arg) - (alien-value stack)))))) - (t - (setf (arg-info-passing-form arg) (arg-info-name arg)))) - - (unless (eq (arg-info-mode arg) :out) - (push (arg-info-name arg) lisp-args) - (when (arg-info-buffer arg) - (push `(setf (alien-access (,(arg-info-buffer arg) - (alien-value stack))) - ,(arg-info-name arg)) - arg-set-forms))) - - (when (eq (arg-info-allocation arg) :stack) - (let* ((type (arg-info-type arg)) - (descr (c-type-description type)) - (size (c-type-size type))) - (push `(defoperator (,(arg-info-accessor arg) ,descr) - ((foo ,(routine-info-stack-record info))) - `(alien-index (alien-value ,foo) - ,,(arg-info-offset arg) - ,,size)) - top-level-forms)) - (push - `(setf (alien-access (,(arg-info-accessor arg) - (alien-value stack)) - ,@(when (or (not (eq (arg-info-mode arg) :in)) - (pointer-type-p (arg-info-type arg))) - '('system-area-pointer))) - ,(arg-info-passing-form arg)) - arg-set-forms)) - - (when (member (arg-info-mode arg) '(:out :in-out)) - (push `(alien-access (,(arg-info-buffer arg) stack)) - result-get-forms))) - - (values (nreverse top-level-forms) - (nreverse lisp-args) - (nreverse arg-set-forms) - (nreverse result-get-forms)))) - - -(defmacro def-c-routine (name (return-type &key) &rest specs) - "Def-C-Routine Name (Return-Type Option*) - {(Arg-Name Arg-Type [Mode] Arg-Option*)}* - - Define a foreign interface function for the routine with the specified string - Name. Normally the interface function is named by interning the uppercased - name in the current package. A different interface function name may be - specified by using a list (Name Function-Name) in the place of Name. - - Return-Type is the C-Type for the C 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. Mode 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(s) being returned from - the interface function. - - :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 supplied argument(s) and - return value(s) being determined by accessing the object on return." - - (let ((info (make-routine-info))) - (cond ((stringp name) - (setf (routine-info-name info) name) - (setf (routine-info-function-name info) - (intern (string-upcase name)))) - ((and (listp name) (= (length name) 2) - (stringp (first name)) (symbolp (second name))) - (setf (routine-info-name info) (first name)) - (setf (routine-info-function-name info) (second name))) - (t - (error "Malformed routine name specification: ~S." name))) - - (let ((docs ()) - (arg-info ())) - (dolist (spec specs) - (cond ((stringp spec) - (push spec docs)) - ((and (listp spec) (>= (length spec) 2)) - (let ((arg-name (first spec)) - (arg-type (get-c-type (second spec))) - (mode (or (third spec) :in)) - (options (cdddr spec))) - (when (oddp (length options)) - (error "Odd number of options in ~S." spec)) - (unless (symbolp arg-name) - (error "Arg name is not a symbol: ~S." arg-name)) - (push (make-arg-info :name arg-name :type arg-type - :mode mode :options options) - arg-info))) - (t - (error "Bad argument spec: ~S." spec)))) - - (setf (routine-info-docs info) (nreverse docs)) - (setf (routine-info-args info) (nreverse arg-info))) - - (unless (eq return-type 'void) - (setf (routine-info-return-type info) (get-c-type return-type))) - - (anotate-foreign-call info) - (pick-names info) - - (multiple-value-bind - (top-level-forms lisp-args arg-set-forms result-get-forms) - (compute-c-call-forms info) - (let ((call-form `(call-foreign-function - ,(routine-info-name info) - ',info - ,@(mapcar #'arg-info-passing-form - (remove :stack (routine-info-args info) - :key #'arg-info-allocation))))) - (when (routine-info-return-coerce-generator info) - (setf call-form - (funcall (routine-info-return-coerce-generator info) - call-form))) - `(progn - (compiler-let ((*alien-eval-when* '(compile eval))) - ,@top-level-forms) - (defun ,(routine-info-function-name info) ,lisp-args - ,@(or (routine-info-docs info) - (list (make-doc-string info))) - (declare (optimize (speed 3) (safety 0))) - (with-stack-alien (stack ,(routine-info-stack-record info) - ,(routine-info-arg-size info)) - ,@arg-set-forms - ,@(if (null (routine-info-return-type info)) - (if (null result-get-forms) - `(,call-form - (undefined-value)) - `(,call-form - (values ,@result-get-forms))) - (if (null result-get-forms) - `(,call-form) - `((values ,call-form - ,@result-get-forms))))))))))) - - - -;;; Make-Doc-String -- Internal -;;; -;;; Make a doc string for the interface routine described by Info. Values -;;; is a list of the names of the by-reference return values. -;;; -(proclaim '(function make-doc-string (routine-info) string)) -(defun make-doc-string (info) - (let ((*print-pretty* t) - (*print-case* :downcase) - (values (mapcar #'arg-info-name - (remove-if-not #'(lambda (mode) - (member mode '(:out :in-out))) - (routine-info-args info) - :key #'arg-info-mode)))) - (format nil "Interface to foreign routine ~S~:[; returns no values.~;~ - ~:*, return values:~% ~A~]" - (routine-info-name info) - (if (routine-info-return-type info) - (cons 'return-value values) - values)))) - - - -;;; Def-C-Variable defines a global C-Variable, so that it is available to -;;; Lisp. It accepts the name of the variable (as a string) and the type -;;; of the variable. - -(defmacro def-c-variable (name type) - "Defines a foreign variable so that it is available from Lisp. - Name should either be a string with the name of the foreign variable or - a list of the string and the symbol to use as the alien variable. - Type is the foreign type of the variable." - (multiple-value-bind - (symbol name) - (cond ((stringp name) - (values (intern (string-upcase name)) - name)) - ((and (consp name) (= (length name) 2) - (stringp (car name)) (symbolp (cadr name))) - (values (cadr name) (car name))) - (t - (error "Bogus name for def-c-variable: ~S.~%~ - Should be either a string or a list of a string and symbol." - name))) - (let* ((c-info (get-c-type type)) - (c-type (if (primitive-type-p c-info) - (c-type-description c-info) - type)) - (c-size (c-type-size c-info))) - `(progn - (defparameter ,symbol - (make-alien ',c-type ,c-size - (%primitive c::foreign-symbol-address ,name))) - (eval-when ,*alien-eval-when* - (setf (info variable alien-value ',symbol) - (lisp::make-ct-a-val - :type ',c-type - :size ,c-size - :offset 0 - :sap '(%primitive c::foreign-symbol-address ,name) - :alien ',symbol))))))) - -#| -;;; Def-C-Procedure defines data structures etc. so that C can be passed -;;; a pointer to a C procedure object which when called will invoke a Lisp -;;; function. Def-C-Procedure accepts three arguments: a symbol whose -;;; value is set to an object which can be written to alien-structures -;;; that will look like a c procedure object; a number which is a constant -;;; number of arguments that the C routine will be called with; and a Lisp -;;; function (an object callable as a function) which should accept the -;;; same number of arguments and will be called when the C procedure object -;;; is invoked. - -(defmacro def-c-procedure (name nargs lfunc) - "Assigns to the value of the symbol name an object which can be - passed to a foreign function as a procedure object. Nargs is the - number of arguments the procedure should accept. Lfunc is the Lisp - function will be called when the procedure is called. Lfunc should - be callable by apply." - (let ((var (gensym))) - `(defparameter ,name - (let ((,var (%primitive alloc-static-g-vector 3))) - (setf (svref ,var 0) - (int-sap (logior (ash clc::type-assembler-code - (+ clc::type-shift-16 16)) - (get 'clc::call-lisp - 'lisp::%loaded-address)))) - (setf (svref ,var 1) ,nargs) - (setf (svref ,var 2) ,lfunc) - ,var)))) - -;;; Call-Lisp-from-C is a Lisp function that gains control when a C -;;; function calls a procedure object that is defined as above. It -;;; wraps an unwind-protect around the call to the function, so that -;;; if we throw passed it, the c-stack-information will be reset. - -(defun call-lisp-from-c (old-c-stack procedure &rest args) - (unwind-protect - (let ((rv (apply (svref procedure 2) args))) - (%primitive return-to-c old-c-stack rv)) - (%primitive reset-c-stack old-c-stack))) - -;;; Reset-foreign-pointers goes through the list of all defined foreign -;;; functions and variables and sets the pointers to their new location. - -(defun reset-foreign-pointers () - "Reset all the code and variable pointers that may have moved." - (dolist (x foreign-routines-defined) - (setf (symbol-value (car x)) (get-code-pointer (cdr x)))) - (dolist (x foreign-variables-defined) - (setf (lisp::alien-value-sap (symbol-value (car x))) - (get-data-pointer (cdr x))))) -|# - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* nil)) diff --git a/code/char.lisp b/code/char.lisp deleted file mode 100644 index 12adb4aec94f14904060e85027d9f992c84ec6c0..0000000000000000000000000000000000000000 --- a/code/char.lisp +++ /dev/null @@ -1,368 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; 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)) - ("LINEFEED" . ,(code-char 10)) ("LF" . ,(code-char 10)) - ("NEWLINE" . ,(code-char 10)) ("NL" . ,(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)) - ("ALTMODE" . ,(code-char 27)) ("ALT" . ,(code-char 27)) - ("ESCAPE" . ,(code-char 27)) ("ESC" . ,(code-char 27)) - ("SPACE" . ,(code-char 32)) ("SP" . ,(code-char 32)) - ("RUBOUT" . ,(code-char 127)) ("DELETE" . ,(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-character (char-code (truly-the base-character 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-character) - (let ((n (char-code (the base-character char)))) - (or (< 31 n 127) - (= n 13) - (= n 10))))) - - -(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-character) - (< 31 - (char-code (the base-character 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 4bc19198624c7473263929c2ab6eb1f284727904..0000000000000000000000000000000000000000 --- a/code/clx-ext.lisp +++ /dev/null @@ -1,584 +0,0 @@ -;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; 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. 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))) - (cond (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)) - (values display (elt screens screen-num)))) - (t - (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) - (let ((font-dir (namestring elt))) - (unless (member font-dir font-path :test #'string=) - (push font-dir 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 (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) - (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 (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/commandline.lisp b/code/commandline.lisp deleted file mode 100644 index 2ae87e6af6fb8aa3f18d03f2586ce7aad517d816..0000000000000000000000000000000000000000 --- a/code/commandline.lisp +++ /dev/null @@ -1,188 +0,0 @@ -;;; -*- Mode: Lisp; Package: Extensions; Log: code.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). -;;; ********************************************************************** -;;; -;;; 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-info.lisp b/code/debug-info.lisp deleted file mode 100644 index c21e795a2b4c397fff93721d02ecedb01815c973..0000000000000000000000000000000000000000 --- a/code/debug-info.lisp +++ /dev/null @@ -1,374 +0,0 @@ -;;; -*- Log: code.log; Package: C -*- -;;; -;;; ********************************************************************** -;;; 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 structures used for recording debugger information. -;;; -(in-package "C") - - -;;;; SC-Offsets: -;;; -;;; We represent the place where some value is stored with a SC-OFFSET, -;;; which is the SC number and offset encoded as an integer. - -(defconstant sc-offset-scn-byte (byte 5 0)) -(defconstant sc-offset-offset-byte (byte 22 5)) -(deftype sc-offset () '(unsigned-byte 27)) - -(defmacro make-sc-offset (scn offset) - `(dpb ,scn sc-offset-scn-byte - (dpb ,offset sc-offset-offset-byte 0))) - -(defmacro sc-offset-scn (sco) `(ldb sc-offset-scn-byte ,sco)) -(defmacro sc-offset-offset (sco) `(ldb sc-offset-offset-byte ,sco)) - - -;;;; Variable length integers: -;;; -;;; The debug info representation makes extensive use of integers encoded in -;;; a byte vector using a variable number of bytes: -;;; 0..253 => the integer -;;; 254 => read next two bytes for integer -;;; 255 => read next four bytes for integer - -;;; READ-VAR-INTEGER -- Interface -;;; -;;; Given a byte vector Vec and an index variable Index, read a variable -;;; length integer and advance index. -;;; -(defmacro read-var-integer (vec index) - (once-only ((val `(aref ,vec ,index))) - `(cond ((<= ,val 253) - (incf ,index) - ,val) - ((= ,val 254) - (prog1 - (logior (aref ,vec (+ ,index 1)) - (ash (aref ,vec (+ ,index 2)) 8)) - (incf ,index 3))) - (t - (prog1 - (logior (aref ,vec (+ ,index 1)) - (ash (aref ,vec (+ ,index 2)) 8) - (ash (aref ,vec (+ ,index 3)) 16) - (ash (aref ,vec (+ ,index 4)) 24)) - (incf ,index 5)))))) - - -;;; WRITE-VAR-INTEGER -- Interface -;;; -;;; Takes an adjustable vector Vec with a fill pointer and pushes the -;;; variable length representation of Int on the end. -;;; -(defun write-var-integer (int vec) - (declare (type (unsigned-byte 32) int)) - (cond ((<= int 253) - (vector-push-extend int vec)) - (t - (let ((32-p (> int #xFFFF))) - (vector-push-extend (if 32-p 255 254) vec) - (vector-push-extend (ldb (byte 8 0) int) vec) - (vector-push-extend (ldb (byte 8 8) int) vec) - (when 32-p - (vector-push-extend (ldb (byte 8 16) int) vec) - (vector-push-extend (ldb (byte 8 24) int) vec))))) - (undefined-value)) - - - -;;;; Packed strings: -;;; -;;; A packed string is a variable length integer length followed by the -;;; character codes. - - -;;; READ-VAR-STRING -- Interface -;;; -;;; Read a packed string from Vec starting at Index, leaving advancing -;;; Index. -;;; -(defmacro read-var-string (vec index) - (once-only ((len `(read-var-integer ,vec ,index))) - (once-only ((res `(make-string ,len))) - `(progn - (%primitive byte-blt ,vec ,index ,res 0 ,len) - (incf ,index ,len) - ,res)))) - - -;;; WRITE-VAR-STRING -- Interface -;;; -;;; Write String into Vec (adjustable, fill-pointer) represented as the -;;; length (in a var-length integer) followed by the codes of the characters. -;;; -(defun write-var-string (string vec) - (declare (simple-string string)) - (let ((len (length string))) - (write-var-integer len vec) - (dotimes (i len) - (vector-push-extend (char-code (schar string i)) vec))) - (undefined-value)) - - -;;;; Packed bit vectors: -;;; - -;;; READ-PACKED-BIT-VECTOR -- Interface -;;; -;;; Read the specified number of Bytes out of Vec at Index and convert them -;;; to a bit-vector. Index is incremented. -;;; -(defmacro read-packed-bit-vector (bytes vec index) - (once-only ((n-bytes bytes)) - (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit))) - `(progn - (%primitive byte-blt ,vec ,index ,n-res 0 ,n-bytes) - (incf ,index ,n-bytes) - ,n-res)))) - - -;;; WRITE-PACKED-BIT-VECTOR -- Interface -;;; -;;; Write Bits out to Vec. Bits must be an eight-bit multiple. -;;; -(defun write-packed-bit-vector (bits vec) - (declare (type simple-bit-vector bits)) - (let ((len (length bits)) - (start (fill-pointer vec))) - (cond ((eq target-byte-order native-byte-order) - (let ((bytes (ash len -3))) - (dotimes (i bytes) - (vector-push-extend 0 vec)) - (lisp::with-array-data ((data vec) (ig1) (ig2)) - (declare (ignore ig1 ig2)) - (%primitive byte-blt bits 0 data start (+ start bytes))))) - (t - (macrolet ((frob (initial step done) - `(let ((shift ,initial) - (byte 0)) - (dotimes (i len) - (let ((int (aref bits i))) - (setq byte (logior byte (ash int shift))) - (,step shift)) - (when ,done - (vector-push-extend byte vec) - (setq shift ,initial byte 0))) - (unless (= shift ,initial) - (vector-push-extend byte vec))))) - (ecase target-byte-order - (:little-endian - (frob 0 incf (= shift 8))) - (:big-endian - (frob 7 decf (minusp shift)))))))) - - (undefined-value)) - - -;;;; Compiled debug variables: -;;; -;;; Compiled debug variables are in a packed binary representation in the -;;; DEBUG-FUNCTION-VARIABLES: -;;; 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)] - -(defconstant compiled-debug-variable-uninterned #b00000001) -(defconstant compiled-debug-variable-packaged #b00000010) -(defconstant compiled-debug-variable-environment-live #b00000100) -(defconstant compiled-debug-variable-save-loc-p #b00001000) -(defconstant compiled-debug-variable-id-p #b00010000) - - -;;;; Compiled debug blocks: -;;; -;;; Compiled debug blocks are in a packed binary representation in the -;;; DEBUG-FUNCTION-BLOCKS: -;;; number of successors + bit flags (single byte) -;;; elsewhere-p -;;; ...ordinal number of each successor in the function's blocks vector... -;;; number of locations in this block -;;; kind of first location (single byte) -;;; delta from previous PC (or from 0 if first location in function.) -;;; [offset of first top-level form, if no function TLF-NUMBER] -;;; form number of first source form -;;; first live mask (length in bytes determined by number of VARIABLES) -;;; ...more <kind, delta, top-level form offset, form-number, live-set> -;;; tuples... - - -(defconstant compiled-debug-block-nsucc-byte (byte 2 0)) -(defconstant compiled-debug-block-elsewhere-p #b00000100) - -(defconstant compiled-code-location-kind-byte (byte 3 0)) -(defconstant compiled-code-location-kinds - '#(:unknown-return :known-return :internal-error :non-local-exit - :block-start)) - - - -;;;; Debug function: - -(defstruct debug-function) - -(defstruct (compiled-debug-function (:include debug-function)) - ;; - ;; The name of this function. If from a DEFUN, etc., then this is the - ;; function name, otherwise it is a descriptive string. - (name nil :type (or simple-string cons symbol)) - ;; - ;; The kind of function (same as FUNCTIONAL-KIND): - (kind nil :type (member nil :optional :external :top-level :cleanup)) - ;; - ;; A vector of the packed binary representation of variable locations in this - ;; function. These are in alphabetical order by name. This ordering is used - ;; in lifetime info to refer to variables: the first entry is 0, the second - ;; entry is 1, etc. Variable numbers are *not* the byte index at which the - ;; representation of the location starts. The entire vector must be parsed - ;; before function, alphabetically sorted by the NAME. This slot may be NIL - ;; to save space. - (variables nil :type (or (simple-array (unsigned-byte 8) (*)) null)) - ;; - ;; A vector of the packed binary representation of the COMPILED-DEBUG-BLOCKS - ;; in this function, in the order that the blocks were emitted. The first - ;; block is the start of the function. This slot may be NIL to save space. - (blocks nil :type (or (simple-array (unsigned-byte 8) (*)) null)) - ;; - ;; If all code locations in this function are in the same top-level form, - ;; then this is the number of that form, otherwise NIL. If NIL, then each - ;; code location represented in the BLOCKS specifies the TLF number. - (tlf-number nil :type (or index null)) - ;; - ;; A vector describing the variables that the argument values are stored in - ;; within this function. The locations are represented by the ordinal number - ;; of the entry in the VARIABLES. The locations are in the order that the - ;; arguments are actually passed in, but special marker symbols can be - ;; interspersed to indicate the orignal call syntax: - ;; - ;; DELETED - ;; There was an argument to the function in this position, but it was - ;; deleted due to lack of references. The value cannot be recovered. - ;; - ;; SUPPLIED-P - ;; The following location is the supplied-p value for the preceding - ;; keyword or optional. - ;; - ;; OPTIONAL-ARGS - ;; Indicates that following unqualified args are optionals, not required. - ;; - ;; REST-ARG - ;; The following location holds the list of rest args. - ;; - ;; MORE-ARG - ;; The following two locations are the more arg context and count. - ;; - ;; <any other symbol> - ;; The following location is the value of the keyword argument with the - ;; specified name. - ;; - ;; This may be NIL to save space. If no symbols are present, then this will - ;; be represented with an I-vector with sufficiently large element type. - (arguments nil :type (or (simple-array * (*)) null)) - ;; - ;; There are three alternatives for this slot: - ;; - ;; A vector - ;; A vector of SC-OFFSETS describing the return locations. The - ;; vector element type is chosen to hold the largest element. - ;; - ;; :Standard - ;; The function returns using the standard unknown-values convention. - ;; - ;; :Fixed - ;; The function returns using the a fixed-values convention, but we - ;; elected not to store a vector to save space. - (returns :fixed :type (or (simple-array * (*)) (member :standard :fixed))) - ;; - ;; SC-Offsets describing where the return PC and return FP are kept. - (return-pc nil :type sc-offset) - (old-fp nil :type sc-offset) - ;; - ;; SC-Offset for the number stack FP in this function, or NIL if no NFP - ;; allocated. - (nfp nil :type (or sc-offset null)) - ;; - ;; The earliest PC in this function at which the environment is properly - ;; initialized (arguments moved from passing locations, etc.) - (start-pc nil :type index) - ;; - ;; The start of elsewhere code for this function (if any.) - (elsewhere-pc nil :type index)) - - -(defstruct debug-source - ;; - ;; This slot indicates where the definition came from: - ;; :File - from a file (Compile-File) - ;; :Lisp - from Lisp (Compile) - ;; :Stream - from a non-file stream (Compile-From-Stream) - (from nil :type (member :file :stream :lisp)) - ;; - ;; If :File, the file name, if :Lisp, the lambda compiled, otherwise some - ;; descriptive string. - (name nil :type (or pathname list simple-string)) - ;; - ;; File comment for this file, if any. - (comment nil :type (or simple-string null)) - ;; - ;; The universal time that the source was written, or NIL if unavailable. - (created nil :type (or unsigned-byte null)) - ;; - ;; The universal time that the source was compiled. - (compiled nil :type unsigned-byte) - ;; - ;; The source path root number of the first form read from this source (i.e. - ;; the total number of forms converted previously in this compilation.) - (source-root 0 :type index) - ;; - ;; The file-positions of each truly top-level form read from this file (if - ;; applicable). The vector element type will be chosen to hold the largest - ;; element. May be null to save space. - (start-positions nil :type (or (simple-array * (*)) null))) - - -(defstruct debug-info) - -(defstruct (compiled-debug-info (:include debug-info)) - ;; - ;; Some string describing something about the code in this component. - (name nil :type simple-string) - ;; - ;; A list of DEBUG-SOURCE structures describing where the code for this - ;; component came from, in the order that they were read. - ;; - ;; *** NOTE: the offset of this slot is wired into the fasl dumper so that it - ;; *** can backpatch the source info when compilation is complete. - (source nil :type list) - ;; - ;; The name of the package that DEBUG-FUNCTION-VARIABLES were dumped relative - ;; to. Locations that aren't packaged are in this package. - (package nil :type simple-string) - ;; - ;; A simple-vector of alternating Debug-Function structures and fixnum - ;; PCs. This is used to map PCs to functions, so that we can figure out - ;; what function we were running in. The function is valid between the PC - ;; before it (inclusive) and the PC after it (exclusive). The PCs are in - ;; sorted order, so we can binary-search. We omit the first and last PC, - ;; since their values are 0 and the length of the code vector. Null only - ;; temporarily. - (function-map nil :type (or simple-vector null))) diff --git a/code/debug-int.lisp b/code/debug-int.lisp deleted file mode 100644 index 485cde3e595791cd6fb8b3a11d67d15e685ec327..0000000000000000000000000000000000000000 --- a/code/debug-int.lisp +++ /dev/null @@ -1,1854 +0,0 @@ -;;; -*- Mode: completion; Log: code.log; Package: debug-internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the implementation of the programmer's interface -;;; to writing debugging tools. -;;; -;;; Written by Bill Chiles. -;;; Designed by Rob Maclachlan and Bill Chiles. -;;; - -(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::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 frame-debug-function - frame-code-location eval-in-frame return-from-frame frame-catches - frame-number frame frame-p - - do-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 - - do-debug-block-locations debug-block-successors debug-block - debug-block-p debug-block-elsewhere-p - - make-breakpoint activate-breakpoint deactivate-breakpoint - breakpoint-hook-function breakpoint-info breakpoint-kind - breakpoint-what breakpoint breakpoint-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 code-location-p - unknown-code-location unknown-code-location-p - - 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)) - - - -;;;; 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)) - (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 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))))) - - - -;;;; 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" - condition)))) - -(define-condition invalid-control-stack-pointer (debug-error) - () - (:report (lambda (condition stream) - (declare (ignore condition)) - (write-string "Invalid control stack pointer." stream)))) - -(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-value (debug-error) - ((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))))) - - -;;; 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 (ext:signal ,datum ,@arguments))) - (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 make-debug-variable - (name package id alive-p sc-offset - save-sc-offset))) - ;; - ;; 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) - ;; - ;; 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))) - -(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.") - -;;; -;;; Frames -;;; - -;;; These represents call-frames on the stack. -;;; -(defstruct (frame (:print-function print-frame) - (:constructor make-frame - (pointer up debug-function code-location number - &optional escaped))) - ;; - ;; 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) - pointer - ;; - ;; Indicates whether someone interrupted frame. (unexported). - ;; If escaped, this is a pointer to the escape frame on the control stack. - escaped - ;; - ;; This is the frame's number for prompt printing. Top is zero. - number) - -(defun print-frame (obj str n) - (declare (ignore n)) - (format str "#<Frame ~S~:[~;, interrupted~]>" - (debug-function-name (frame-debug-function obj)) - (frame-escaped obj))) - -(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.") - -;;; -;;; 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 "#<Debug-function ~S>" (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) - -;;; 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))) - -;;; -;;; Debug-blocks. -;;; - -;;; These exist for caching data stored in packed binary form in compiler -;;; debug-blocks. -;;; -(defstruct (debug-block (:print-function print-debug-block) - (:constructor make-debug-block - (code-locations successors elsewhere-p))) - ;; - ;; Code-location information for the block. - (code-locations nil :type simple-vector) - ;; - ;; Code-locations where execution continues after this block. - (successors nil :type list) - ;; - ;; This notes the block as a special glob of code shared by various functions - ;; and tucked away elsewhere in a component. This kind of block has not - ;; start code-location. - (elsewhere-p nil :type c::boolean)) - -(defun print-debug-block (obj str n) - (declare (ignore n)) - (format str "#<Debug-block ~S>" - ;; Fix up, for now assuming always have a code-location in 0. - (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.") - -;;; -;;; Breakpoints. -;;; - -(defstruct (breakpoint (:print-function print-breakpoint) - (:constructor %make-breakpoint)) - hook-function ;Function takes frame, breakpoint, and optional values. - what ;Code-location or debug-function. - kind ;:code-location, :function-start, or :function-end. - info ;User settable and usable information. - active-p) ;Whether this breakpoint is in effect. - -(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)))))) - -;;; -;;; Code-locations. -;;; - -(defstruct (code-location (:print-function print-code-location) - (:constructor make-code-location - (pc debug-function &optional - %tlf-offset %form-number %live-set kind - ;; Any optional means it's known. - (%unknown-p (not kind)))) - (:constructor make-unknown-code-location - (pc debug-function &aux (%unknown-p t)))) - ;; - ;; This is an index into debug-function's component slot. - (pc nil :type c::index) - ;; - ;; 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))) - ;; - ;; 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) - (kind :unparsed :type (member :unparsed :unknown-return :known-return - :internal-error :non-local-exit :block-start))) - -(defun print-code-location (obj str n) - (declare (ignore n)) - (format str "#<~A ~S>" - (ecase (code-location-unknown-p obj) - ((nil) "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.") - -;;; -;;; 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-p 'function) - "Returns whether object is a debug-source.") - -;;; -;;; Interpreted-debug-infos. -;;; - -(defstruct (interpreted-debug-info - (:print-function print-interpreted-debug-info)) - ) - -(defun print-interpreted-debug-info (obj str n) - (declare (ignore n obj)) - (write-string "#<Interpreted-Debug-Info>" str)) - - - -;;;; Frames. - -(proclaim '(inline pointer+offset pointer- stack-ref env-valid-p - cstack-pointer-valid-p %set-stack-ref)) - -;;; -;;; These are only used by stack parsing and making frame objects. -;;; - -(defun pointer- (next previous) - (system:%primitive pointer- next previous)) - -(defun pointer+offset (x y) - (system:%primitive sap+ x (ash y 2))) - -(defun env-valid-p (env) - (and (functionp env) - (eql (system:%primitive get-vector-subtype env) - system:%function-constants-subtype))) - -(defun cstack-pointer-valid-p (x) - (and (system:%primitive pointer< x (system:%primitive current-sp)) - (not (system:%primitive pointer< x - (system:%primitive make-immediate-type 0 - system:%control-stack-type))))) - - -;;; -;;; STACK-REF needs to exist on MIPS and future implementations. -;;; - -(defun stack-ref (s n) - (system:%primitive read-control-stack (pointer+offset s n))) - -(defun %set-stack-ref (s n value) - (system:%primitive write-control-stack (pointer+offset s n) value)) -;;; -(defsetf stack-ref %set-stack-ref) - - -;;; These are the names of all the functions that the system could have called -;;; while interpreting. We need to detect these when parsing the stack and -;;; make frames representing the code the intepreter is evaluating. -;;; -(defconstant interpreter-function-names nil) - -;;; TOP-FRAME -- Public. -;;; -(defun top-frame () - "Returns the top frame of the control stack as it was before calling this - function." - (compute-calling-frame (system:%primitive current-fp) nil)) - -(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) - (setf (frame-%down frame) - (compute-calling-frame (frame-pointer frame) frame)) - down))) - -;;; 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. -;;; -(defun compute-calling-frame (current-fp up-frame) - (let ((caller (stack-ref current-fp c::old-fp-save-offset))) - (unless (cstack-pointer-valid-p caller) - (return-from compute-calling-frame nil)) - (multiple-value-bind (env env-fp escaped) - (fp-env caller current-fp) - (cond (escaped - ;; If env-fp is escaped, then caller is the escape frame. - (multiple-value-bind - (env pc) - (pc-offset (escape-register caller c::return-pc-offset) - env up-frame) - (let ((d-fun (debug-function-from-pc env pc))) - (make-frame env-fp up-frame d-fun - (code-location-from-pc d-fun pc) - (if up-frame (1+ (frame-number up-frame)) 0) - escaped)))) - #|((member (system:%primitive header-ref env - system:%function-name-slot) - interpreter-function-names) - ;; Just print calls within the interpreter as ... uh ... real calls - ;; for now - )|# - (t - (multiple-value-bind - (env pc) - (pc-offset (stack-ref current-fp c::return-pc-save-offset) - env up-frame) - (let ((d-fun (debug-function-from-pc env pc))) - ;; env-fp = caller. - (make-frame env-fp up-frame d-fun - (code-location-from-pc d-fun pc) - (if up-frame (1+ (frame-number up-frame)) 0))))))))) - -;;; PC-OFFSET -- Internal. -;;; -;;; THIS FUNCTION BECOMES TOTALLY UNNECESSARY IN THE NEW SYSTEM WHEN PC'S -;;; ALWAYS DIRECTLY POINT TO COMPONENTS (OR ENVIRONMENTS). -;;; -;;; This takes a pc in the form of an interior pointer, the environment (code -;;; component) in which to interpret the pc, and next frame up the stack. -;;; Conceptually, we fetch the code vector from the environment and subtract -;;; the code vector's address from pc, turning pc into an offset. We also -;;; subtract off the code vector's header size. This leaves a pc that is an -;;; offset into the code vector. -;;; -;;; We actually have to be careful performing the above activity. Sometimes -;;; the argument env is not a function or environment due to funny calling -;;; conventions. That is, someone accessed a slot in a frame to get the env, -;;; but the particular calling convention used blew off storing a valid env in -;;; the slot. In this situation, use the frame's debug-function's environment -;;; and call CHECK-PC to compute and check the offset's validity, signalling -;;; an error if for some weird reason we still don't have a valid environment. -;;; -;;; Otherwise, assume the argument env is the environment and call CHECK-PC -;;; without signalling an error when env is invalid. The problem here is the -;;; test described in the previous paragraph could yield a valid environment -;;; object, but it isn't our environment as determined by CHECK-PC on the pc's -;;; offset validity. In this situation, as above, use the frame's -;;; debug-function's environment and call CHECK-PC signalling an error if we -;;; don't have a good environment still. -;;; -;;; CHECK-PC: -;;; We check the offset's validity by making sure it is a valid index into -;;; the code vector. If the pc, as an interior pointer, pointed into some -;;; other code vector, then the address arithmetic would yield an invalid -;;; index. When the index is invalid, so is the environment, and we have to -;;; iterate up the stack to find a frame that saved the appropriate -;;; environment. Not every frame saves its environment due to optimized local -;;; calling conventions. In this code, we always know someone has saved the -;;; environment because before we get here, we know someone has used the full -;;; call sequence (due to calling a debugger routine, calling ERROR, etc.), or -;;; some frame has escaped. We only have to look up the stack one frame since -;;; the appropriate environment propagates down through the frame objects. -;;; -(defun pc-offset (pc env up-frame) - (flet ((check-pc (pc env errorp) - (let* ((code-vector (system:%primitive header-ref env - system:%function-code-slot)) - (offset (- (pointer- pc code-vector) - clc::i-vector-header-size))) - (cond ((<= 0 offset (length code-vector)) - (values env offset)) - (errorp - (error "Unexpected inappropriate environment for pc.")) - (t nil))))) - (if (not (and (functionp env) - (eql (system:%primitive get-vector-subtype env) - #.system:%function-constants-subtype))) - (check-pc pc - (compiled-debug-function-component - (frame-debug-function up-frame)) - t) - (multiple-value-bind (env offset) (check-pc pc env nil) - (if env - (values env offset) - (check-pc pc - (compiled-debug-function-component - (frame-debug-function up-frame)) - t)))))) - -;;; FP-ENV -- Internal. -;;; -;;; This takes a frame pointer and returns its saved environment, taking care -;;; if fp points to an escape frame. As multiple values, this returns the -;;; environment, the appropriate frame pointer for the environment, and whether -;;; fp referenced an escape. If fp is an escape frame, then we return fp as -;;; the last value for convenience in accessing data saved in the escape frame. -;;; -(defun fp-env (fp current-fp) - (let ((env (stack-ref fp c::env-save-offset))) - (if (and (eql env 0) - ;; If env is zero indicating an escape frame, then its return-pc - ;; must point into an assembler routine for interrupts. - (= (system:%primitive get-type - (stack-ref current-fp - c::return-pc-save-offset)) - system:%assembler-code-type)) - ;; Get the env of the interrupted frame. - (let ((env (escape-register fp c::env-offset))) - (cond ((eql (system:%primitive get-type env) system:%trap-type) - ;; Just ignore these for frame handling. - ) - ((env-valid-p env) - (values env - ;; This is valid since the escape frame must be - ;; preceded by some frame. - (stack-ref fp c::old-fp-save-offset) - fp)) - (t - (error "Escaping frame ENV invalid?")))) - (values env fp nil)))) - -;;; -;;; Frame utilities. -;;; - -;;; ESCAPE-REGISTER -- Internal. -;;; -;;; An escape register saves the value of a register for a frame that someone -;;; interrupts. This function returns the n'th saved register. F is the -;;; frame pointer to the escape frame which notes that someone interrupted the -;;; previous frame. -;;; -(defun escape-register (f n) - (stack-ref f (+ n system:%escape-frame-general-register-start-slot))) - -;;; DEBUG-FUNCTION-FROM-PC -- Internal. -;;; -;;; This returns a compiled-debug-function for env 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 (env pc) - (let* ((component (function-code-header env)) - (info (system:%primitive header-ref component - system:%function-constants-debug-info-slot))) - (unless info - (debug-signal 'no-debug-info)) - (let* ((function-map (c::compiled-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))))))) - -;;; FUNCTION-CODE-HEADER -- Internal. -;;; -;;; This returns a pointer to the code data-block containing the function. The -;;; code header contains constants and debug-info. First we fetch the -;;; function's header word and shift out the type tag, leaving the offset back -;;; to the code header. Negate that and add it to the pointer to fun. -;;; -;;; IGNORE THE ABOVE COMMENT UNTIL RUNNING WITH THE NEW DATA FORMAT FOR THE -;;; NEW SYSTEM. -;;; -(defun function-code-header (fun) - (ecase (system:%primitive get-vector-subtype fun) - ((#.system:%function-entry-subtype #.system:%function-closure-entry-subtype) - (system:%primitive header-ref fun system:%function-entry-constants-slot)) - (#.system:%function-closure-subtype - (system:%primitive header-ref - (system:%primitive header-ref fun - system:%function-name-slot) - system:%function-entry-constants-slot)) - (#.system:%function-constants-subtype - fun))) - -;;; 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 there is debug-block info, we assume -;;; the code-location is known by making a default one. It may later prove -;;; to be unknown as :unparsed slots are accessed. -;;; -(defun code-location-from-pc (debug-fun pc) - ;; For now, and this might be right: - (if (c::compiled-debug-function-blocks - (compiled-debug-function-compiler-debug-fun - debug-fun)) - (make-code-location pc debug-fun) - (make-unknown-code-location pc debug-fun))) - -(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:%primitive active-catch-frame)) - (res nil) - (fp (frame-pointer frame))) - (loop - (when (eql catch 0) (return (nreverse res))) - (when (eq fp (stack-ref catch system:%unwind-block-current-fp)) - (push (cons (stack-ref catch system:%catch-block-tag) - (make-code-location - (- (stack-ref catch system:%unwind-block-entry-pc) - clc::i-vector-header-size) - (frame-debug-function frame))) - res)) - (setf catch (stack-ref catch system:%catch-block-previous-catch))))) - - - -;;;; Debug-functions. - -;;; DO-BLOCKS -- Public. -;;; -(defmacro do-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-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. -;;; -;;; ??? Can't work on the RT before back porting the new system from the MIPS. -;;; -(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." - (etypecase debug-function - (compiled-debug-function - (setf (debug-function-%function debug-function) nil)) - (interpreted-debug-function - (error "Can't currently debug interpreted functions.")))) - -;;; 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 - (error "Can't get interpreted-debug-function names now.")))) - -;;; FUNCTION-DEBUG-FUNCTION -- Public. -;;; -(defun function-debug-function (fun) - "Returns a debug-function that represents debug information for function." - (debug-function-from-pc - fun - (- (system:%primitive header-ref fun system:%function-offset-slot) - clc::i-vector-header-size))) - -;;; 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 - (error "We don't debug interpreted functions now.")))) - -;;; 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." - (let ((lambda-list (debug-function-%lambda-list debug-function))) - (cond ((eq lambda-list :unparsed) - (etypecase debug-function - (compiled-debug-function - (multiple-value-bind - (args argsp) - (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)))) - (interpreted-debug-function - (error "Can't get lambda-lists for interpreted-debug-functions ~ - currently.")))) - (lambda-list) - ((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))))) - -;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal. -;;; -;;; 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 compiled-debug-function-lambda-list (debug-function) - (let ((args (c::compiled-debug-function-arguments - (compiled-debug-function-compiler-debug-fun - debug-function)))) - (declare (type (or (simple-array * (*)) null) args)) - (if (not args) - (values nil nil) - (let ((vars (debug-function-debug-variables debug-function)) - (i 0) - (len (length args)) - (res nil)) - (declare (type (or null simple-vector) vars)) - (loop - (when (>= i len) (return)) - (let ((ele (aref args i))) - (if (symbolp ele) - (case ele - (c::deleted - ;; Deleted required arg at beginning of args array. - (push :deleted res)) - (c::optional-args - ;; When I fill this in, I can remove the (typep last 'cons) - ;; below. - ) - (c::supplied-p - ;; supplied-p var immediately following keyword or optional. - ;; Stick the extra var in the result element representing - ;; the keyword or optional. - ;; ACTUALLY, WE DON'T HANDLE OPTIONALS CORRECTLY YET. ??? - (let ((last (car res)) - (v (compiled-debug-function-lambda-list-var - args (incf i) vars))) - (if (typep last 'cons) - (nconc last (list v)) - (setf (car res) (list :optional last v))))) - (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))) - ;; 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."))))) - -;;; DEBUG-FUNCTION-DEBUG-INFO -- Internal Interface. -;;; -(defun debug-function-debug-info (debug-fun) - (etypecase debug-fun - (compiled-debug-function - (system:%primitive header-ref - (compiled-debug-function-component debug-fun) - system:%function-constants-debug-info-slot)) - (interpreted-debug-function - (error "Can't currently get the debug-info for an ~ - interpreted-debug-function.")))) - - - -;;;; 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 and PARSE-DEBUG-VARIABLES 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 Interface. -;;; -;;; 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) - (etypecase debug-function - (compiled-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))))) - (interpreted-debug-function - (error "We don't currently support interpreted-debug-functions.")))) - -;;; PARSE-DEBUG-BLOCKS -- Internal. -;;; -;;; Debug-fun is a c::compiled-debug-function. Var-count is how many variables -;;; the live-set data in packed binary form represents. -;;; -(defun parse-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-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-code-location - pc debug-function tlf-offset - form-number live-set kind) - locations-buffer) - (setf last-pc pc)))) - (block (make-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))))) - -;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal Interface. -;;; -;;; 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) - (etypecase debug-function - (compiled-debug-function - (let ((vars (debug-function-debug-vars debug-function))) - (if (eq vars :unparsed) - (setf (debug-function-debug-vars debug-function) - (parse-debug-variables debug-function)) - vars))) - (interpreted-debug-function - (error "We don't currently support interpreted-debug-functions.")))) - -;;; PARSE-DEBUG-VARIABLES -- Internal. -;;; -;;; This parses the packed binary representation of debug-variables from -;;; debug-function's c::compiled-debug-function. -;;; -(defun parse-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 - (debug-function-debug-info debug-function)))) - (unless packed-vars - (return-from parse-debug-variables nil)) - (when (zerop (length packed-vars)) - ;; Return a simple-vector not whatever packed-vars may be. - (return-from parse-debug-variables '#())) - (let ((i 0) - (len (length packed-vars))) - (with-parsing-buffer (buffer) - (loop - (let ((flags (aref packed-vars i))) - (declare (type (unsigned-byte 8) flags)) - (incf i) - ;; The routines in the "C" package are macros that advance the index. - (let ((name (c::read-var-string packed-vars i)) - (package (cond ((not - (zerop - (logand c::compiled-debug-variable-packaged - flags))) - (c::read-var-string packed-vars i)) - ((zerop - (logand c::compiled-debug-variable-uninterned - flags)) - default-package) - (t nil))) - (id (if (zerop (logand c::compiled-debug-variable-id-p - flags)) - 0 - (c::read-var-integer packed-vars i))) - (sc-offset (c::read-var-integer packed-vars i)) - (save-sc-offset (if (zerop - (logand - c::compiled-debug-variable-save-loc-p - flags)) - nil - (c::read-var-integer packed-vars i)))) - (vector-push-extend - (make-debug-variable - name package id - (not (zerop (logand c::compiled-debug-variable-environment-live - flags))) - sc-offset save-sc-offset) - buffer))) - (when (>= i len) (return))) - (result buffer))))) - - - -;;;; 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. -;;; -;;; We don't use CODE-LOCATION= since the code-location may be unknown, but -;;; even when it is, we can determine the block. To do this we have to check -;;; pc ranges for the blocks. We use DEBUG-FUNCTION-DEBUG-BLOCKS to make sure -;;; any block info is unparsed and to signal a no-debug-blocks condition when -;;; appropriate. -;;; -;;; If there's only one block, it must be it. If there's more than one, we -;;; skip the first one and find the first block whose first code-location is -;;; greater than we want. Then we know we want the previous block. The last -;;; block is special since it may represent elsewhere code which has no start -;;; code-location. If it is elsewhere code, it starts where the -;;; c::compiled-debug-function tells us the elsewhere code starts. -;;; -;;; ??? How to write this for interpreted code-locations. -;;; -(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) - (let* ((pc (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 - (code-location-pc - (svref (debug-block-code-locations last) - 0))) - (svref blocks (1- end))) - (t last)))) - (declare (type c::index i end)) - (when (< pc - (code-location-pc - (svref (debug-block-code-locations (svref blocks i)) - 0))) - (return (svref blocks (1- i)))))))) - block))) - -;;; CODE-LOCATION-DEBUG-SOURCE -- Public. -;;; -(defun code-location-debug-source (code-location) - "Returns the code-location's debug-source." - (let ((info (debug-function-debug-info - (code-location-debug-function code-location)))) - (etypecase info - (c::compiled-debug-info - (let* ((sources (c::compiled-debug-info-source info)) - (len (length sources))) - (declare (list sources)) - (if (= len 1) - (car sources) - (do ((prev (car 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))) - (car prev)))))) - (interpreted-debug-info - (error "Can't handle interpreted-debug-infos."))))) - -;;; 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) - (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)) - (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) - (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)) - (t form-num)))) - -;;; CODE-LOCATION-LIVE-SET -- Internal Interface. -;;; -;;; This returns the code-location's live-set if it is available. If there -;;; is no debug-block information, this returns nil. -;;; -(defun code-location-live-set (code-location) - (if (code-location-unknown-p code-location) - nil - (let ((live-set (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.")) - (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." - (let ((d-fun1 (code-location-debug-function obj1)) - (d-fun2 (code-location-debug-function obj2))) - (and (eq d-fun1 d-fun2) - (sub-code-location= d-fun1 obj1 obj2)))) - -(defun sub-code-location= (d-fun1 obj1 obj2) - (etypecase d-fun1 - (compiled-debug-function - (= (code-location-pc obj1) (code-location-pc obj2))) - (interpreted-debug-function - ;; ??? compare IR1 nodes? - (error "Cannot compare interpreted-debug-functions currently.")))) - -;;; 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) - (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 (debug-block-code-locations block))) - (declare (simple-vector locations)) - (dotimes (j (length locations)) - (let ((loc (svref locations j))) - (when (sub-code-location= debug-function 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 (code-location-%live-set code-location) - (code-location-%live-set loc)) - (setf (code-location-kind code-location) - (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." - (let ((code-locs (debug-block-code-locations debug-block))) - (declare (simple-vector code-locs)) - (when (zerop (length code-locs)) - (error "No code-locations in debug-block? -- ~S." debug-block)) - (debug-function-name (code-location-debug-function (svref code-locs 0))))) - - - -;;;; 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." - (let ((res (access-debug-var-slot debug-var frame))) - (if (indirect-value-cell-p res) - (system:%primitive header-ref res - system:%function-value-cell-value-slot) - res))) - -(defun access-debug-var-slot (debug-var frame) - (let ((escaped (frame-escaped frame))) - (if escaped - (sub-access-debug-var-slot - (frame-pointer frame) - (debug-variable-sc-offset debug-var) - escaped) - (sub-access-debug-var-slot - (frame-pointer frame) - (or (debug-variable-save-sc-offset debug-var) - (debug-variable-sc-offset debug-var)))))) - -(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) - (ecase (c::sc-offset-scn sc-offset) - ((0 1) ;; Any register or descriptor register. - (if escaped - (stack-ref escaped (+ system:%escape-frame-general-register-start-slot - (c::sc-offset-offset sc-offset))) - :invalid-value-for-unescaped-register-storage)) - (2 (error "Local non-descriptor register access?")) - (3 ;; String-char register (w/o tag bits) - (if escaped - (code-char - (stack-ref escaped (+ system:%escape-frame-general-register-start-slot - (c::sc-offset-offset sc-offset)))) - :invalid-value-for-unescaped-register-storage)) - (4 ;; Descriptors on the stack. - (stack-ref fp (c::sc-offset-offset sc-offset))) - (5 ;; String-chars on the stack (w/o tag bits). - (code-char (stack-ref fp (c::sc-offset-offset sc-offset)))))) - -(defun %set-debug-variable-value (debug-var frame value) - (let ((current-value (access-debug-var-slot debug-var frame))) - (if (indirect-value-cell-p current-value) - (system:%primitive header-set current-value - system:%function-value-cell-value-slot - value) - (set-debug-variable-slot debug-var frame value)))) - -(defun set-debug-variable-slot (debug-var frame value) - (let ((escaped (frame-escaped frame))) - (if escaped - (sub-set-debug-var-slot (frame-pointer frame) - (debug-variable-sc-offset debug-var) - value - escaped) - (sub-set-debug-var-slot - (frame-pointer frame) - (or (debug-variable-save-sc-offset debug-var) - (debug-variable-sc-offset debug-var)) - value)))) - -(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) - (ecase (c::sc-offset-scn sc-offset) - ((0 1) ;; Any register or descriptor register. - (if escaped - (setf (stack-ref escaped - (+ system:%escape-frame-general-register-start-slot - (c::sc-offset-offset sc-offset))) - value) - value)) - (2 (error "Local non-descriptor register access?")) - (3 ;; String-char register (w/o tag bits) - (if escaped - (setf (stack-ref escaped - (+ system:%escape-frame-general-register-start-slot - (c::sc-offset-offset sc-offset))) - (char-code value)) - value)) - (4 ;; Descriptors on the stack. - (setf (stack-ref fp (c::sc-offset-offset sc-offset)) value)) - (5 ;; String-chars on the stack (w/o tag bits). - (setf (stack-ref fp (c::sc-offset-offset sc-offset)) - (char-code value))))) -(defsetf debug-variable-value %set-debug-variable-value) - -(defun indirect-value-cell-p (x) - (and (functionp x) - (eql (system:%primitive get-vector-subtype x) - system:%function-value-cell-subtype))) - - -;;; 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." - (cond ((debug-variable-alive-p debug-var) - (let ((debug-fun (code-location-debug-function basic-code-loc))) - (etypecase debug-fun - (compiled-debug-function - (if (>= (code-location-pc basic-code-loc) - (c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun debug-fun))) - :valid - :invalid)) - (interpreted-debug-function - (error "Don't do interpreted debug-variable validity now."))))) - ((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 (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 (nreverse (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)))) diff --git a/code/debug.lisp b/code/debug.lisp deleted file mode 100644 index 059a561ea6c1309a9eb7699cb30bacb8e13a215b..0000000000000000000000000000000000000000 --- a/code/debug.lisp +++ /dev/null @@ -1,856 +0,0 @@ -;;; -*- Mode: Lisp; Package: Debug; Log: code.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). -;;; ********************************************************************** -;;; -;;; CMU Common Lisp Debugger. This is a very basic command-line oriented -;;; debugger. -;;; -;;; 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* - - var arg)) - - -(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)) - "*Print-level* is bound to this value when debug prints a function call.") -;;;; Variables, parameters, and constants. - - "*Print-length* is bound to this value when debug prints a function call.") - 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 - "If this is bound before the debugger is invoked, it is used as the stack -(defvar *stack-top* nil) - -;;;; 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 -;;; -(defvar *breakpoints* nil) -(declaim (type list *breakpoints*)) - -;;; A list of breakpoint-info structures of the made and active step -;;; breakpoints. - PUSH rebinds things in another command level. Good for hide/show. - ABORT returns to the previous abort restart case. -;;; -(defvar *step-breakpoints* nil) -;;; -(defvar *number-of-steps* 1) -(declaim (type integer *number-of-steps*)) - -;;; Used when listing and setting breakpoints. -;;; -(defvar *default-breakpoint-debug-function* nil) - L lists locals in current function. - - -;;;; Code location utilities: - - (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) - (di:do-debug-block-locations (block-code-location debug-block) - (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place))) - (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*))) - (di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info)))) - (let ((*print-length* *debug-print-length*) - (*print-level* *debug-print-level*)) - (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 - (print-frame-call frame)))) - (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 -(defun print-frame-call (frame &optional - (*print-length* *debug-print-length*) - (*print-level* *debug-print-level*) - (verbosity 1)) - (ecase verbosity - (0 (print frame)) - (1 (print-frame-call-1 frame)) - ((2 3 4 5)))) - (t ,other))))) - (format s "#<~A>" - (unprintable-object-string x))))) -;;; This prints frame with verbosity level 1. This pays attention to -;;; *print-length*, and if we hit a rest-arg before the length runs out, 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. -;;; This prints frame with verbosity level 1. If we hit a rest-arg, -(defun print-frame-call-1 (frame) - (handler-case - (let* ((d-fun (di:frame-debug-function frame)) - (loc (di:frame-code-location frame)) - (count (or *print-length* most-positive-fixnum))) - (terpri) - (write-char #\() - (prin1 (di:debug-function-name d-fun)) - (let* ((d-fun (di:frame-debug-function frame)) - (write-char #\space) - (when (zerop count) - ;; We know there are more arguments to print since we haven't - ;; printed ele on this iteration yet. - (write-string "...") - (return)) - (loc (di:frame-code-location frame)) - :required ((print-frame-call-arg ele loc frame)) - :optional ((print-frame-call-arg (second ele) loc frame)) - :keyword ((prin1 (second ele)) - (write-char #\space) - (print-frame-call-arg (third ele) loc frame) - ;; Extra decrement for printing two items. - (decf count)) - :deleted ((print-frame-call-arg ele loc frame)) - :optional ((push (frame-call-arg (second ele) loc frame) results)) - (write-string "<unused-rest-arg> ...") - (let ((values (di:debug-variable-value (second ele) frame))) - (prin1 (car values)) - (dolist (value (cdr values)) - (write-char #\space) - (when (zerop count) - (write-string "...") - (return)) - (prin1 value) - (decf count))) - (write-string "<unavaliable-rest-arg> ...")) - (return))) - (decf count)) - (write-char #\)) - (when (di:debug-function-kind d-fun) - (write-string " [") - (prin1 (di:debug-function-kind d-fun)) - (write-char #\]))) - (di:lambda-list-unavailable () - (let ((d-fun (di:frame-debug-function frame))) - (format t "(~S <lambda-list-unavailable>)) ~S)" - (di:debug-function-name d-fun) - (di:debug-function-kind d-fun)))))) - -(defun print-frame-call-arg (var location frame) - (write-char #\])))) - (write-string "<unused-arg>") - (prin1 (di:debug-variable-value var frame)) - (write-string "<unavailable-arg>"))) - - - -;;;; ROBS-BACKTRACE. - -(defun robs-backtrace (&optional (frames most-positive-fixnum) - (*standard-output* *debug-io*)) - "Show a listing of the call stack going down from the current frame. Frames - is how many frames to show." - (do ((callee (system:%primitive current-fp) - (di::stack-ref callee c::old-fp-save-offset)) - (n 0 (1+ n))) - ((or (not (di::cstack-pointer-valid-p callee)) - (>= n frames)) - (values)) - (let* ((caller (di::stack-ref callee c::old-fp-save-offset)) - (pc (di::stack-ref callee c::return-pc-save-offset))) - (unless (di::cstack-pointer-valid-p caller) - (return (values))) - (let ((env (di::stack-ref caller c::env-save-offset))) - (cond - ((eql env 0) - (let ((env (di::escape-register caller c::env-offset))) - (cond ((eql (system:%primitive get-type env) system:%trap-type) - (format t "~%<undefined> ~S" - (di::escape-register caller c::call-name-offset)) - (setq callee - (check-valid - (di::escape-register caller c::old-fp-offset)))) - ((di::env-valid-p env) - (format t "~%<escape frame> ") - (print-code-and-stuff - env - (di::escape-register caller c::return-pc-offset)) - (setq callee - (check-valid - (di::stack-ref callee c::old-fp-save-offset)))) - (t - (error "Escaping frame ENV invalid?"))))) - ((di::env-valid-p env) - (terpri) - (print-code-and-stuff env pc)) - (t - (format t "~%<invalid frame>"))))))) - -(defun print-code-and-stuff (env pc) - (let* ((code (system:%primitive header-ref env system:%function-code-slot)) - (code-int (system:%primitive make-fixnum code))) - (format t "~A, Code = #x~X, PC = ~D" - (system:%primitive header-ref env system:%function-name-slot) - (logior code-int (ash system:%code-type 27)) - (- (system:%primitive make-fixnum pc) code-int)))) - -(defun check-valid (x) - (unless (di::cstack-pointer-valid-p x) - (error "Invalid control stack pointer.")) - x) - (make-unprintable-object "unused-arg") - (di:debug-variable-value var frame) - (make-unprintable-object "unavailable-arg"))) -;;;; INVOKE-DEBUGGER. -;;; 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*) - (print-level *print-level*) - (verbosity 1) - (number nil)) - (let ((*print-length* (or *debug-print-length* print-length)) -(defvar *debug-abort*) - (*print-level* (or *debug-print-level* print-level))) - (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))) - (when (>= verbosity 2) - (let ((loc (di:frame-code-location frame))) - (*debug-abort* (find-restart 'abort)) - (handler-case - (progn - (*error-output* *debug-io*)) - -;;;; 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.") - (do ((p restarts (cdr p)) - (i 0 (1+ i))) - ((endp p)) - (format s "~& ~D: ~A~%" i (car p))))) - ;; 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) -;;;; DEBUG-LOOP. - (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)) - (let ((*debug-command-level* (1+ *debug-command-level*)) - (*current-frame* (di:top-frame))) - 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. - (throw 'debug-loop-catcher nil)) - (invoke-debugger condition)))) - (funcall *debug-prompt*) - (let* ((exp (read)) - (cmd-fun (debug-command-p exp)) - ;; Must bind level for restart function created by - ;; WITH-SIMPLE-RESTART. - (level *debug-command-level*)) - (clear-input *debug-io*) - (if cmd-fun - (funcall cmd-fun) - (debug-eval-print exp)))))))))) - (when *flush-debug-errors* - ;; WITH-SIMPLE-RESTART. - (let ((level *debug-command-level*) - (let* ((values (multiple-value-list (eval -))) - (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 - -;;; VARS -- Public. - (: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)))) - information." - (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) - (di:debug-variable-value (car vars) *current-frame*)) - (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) - (di:debug-variable-value (car vars) *current-frame*)) - ;; 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))) - (di:debug-variable-value v *current-frame*))) - (t - (error "Specify variable ID to disambiguate ~S. Use one of ~S." - name (mapcar #'di:debug-variable-id vars))))))))) - id (mapcar #'di:debug-variable-id vars))) - '(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 -;;; Interface to *debug-commands*. -;;; -(defmacro def-debug-command (name &rest body) - (dolist (ele args (error "Argument specification out of range -- ~S." n)) - (lambda-list-element-dispatch ele - (defun ,fun-name () ,@body) - (push (cons ,name #',fun-name) *debug-commands*) - (di:frame-code-location *current-frame*) - (error "Unused rest-arg before n'th argument.") -(defun debug-command-p (form) - (and (symbolp form) - (cdr (assoc (symbol-name form) *debug-commands* :test #'string=)))) -(defun debug-command-p (form &optional other-commands) - (let* ((name - (mapc #'match-command other-commands)) - ;; - ;; Return the right value. -(def-debug-command "U" - ((= (length res) 1) - (if next - (print-frame-call (setf *current-frame* next)) - (princ "Top of stack.")))) - -(def-debug-command "D" -;;; Returns a list of debug commands (in the same format as *debug-commands*) - (if next - (print-frame-call (setf *current-frame* next)) - (princ "Bottom of stack.")))) -(defun make-restart-commands (&optional (restarts *debug-restarts*)) -(def-debug-command "T" - (print-frame-call - (setf *current-frame* - (do ((prev *current-frame* lead) - (lead (di:frame-up *current-frame*) (di:frame-up lead))) - ((null lead) prev))))) - (push (cons (format nil "~d" num) restart-fun) commands)))) -(def-debug-command "B" - (print-frame-call - (setf *current-frame* - (do ((prev *current-frame* lead) - (lead (di:frame-down *current-frame*) (di:frame-down lead))) - ((null lead) prev))))) - -(def-debug-command "F" - (let ((n (read-prompting-maybe "Frame number: ")) - (current (di:frame-number *current-frame*))) - -(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 "FRAME" (&optional - (n (read-prompting-maybe "Frame number: "))) - (let ((current (di:frame-number *current-frame*))) -(def-debug-command "Q" - (princ "You are here.")) - ((> n current) -(def-debug-command "GO" - (setf *current-frame* - (do ((prev *current-frame* lead) - -(def-debug-command "PUSH" - (invoke-debugger *debug-condition*)) - -(def-debug-command "ABORT" - ;; There's always at least one abort restart due to the top-level one. - (invoke-restart *debug-abort*)) - (lead (di:frame-down *current-frame*) -(def-debug-command "RESTART" - ((null lead) - (princ "Bottom of stack encountered.") - prev) - (write-string "Restart number: ") - (t - (invoke-restart-interactively (nth num *debug-restarts*)))) -;;; -;;; In and Out commands. -;;; - -(def-debug-command "QUIT" () -(defvar *help-line-scroll-count* 20) - (continue) -(def-debug-command "H" - -(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))))) - (format t "~%Q for quit: ") - (return-from restart-debug-command nil))))) - (if restart - (invoke-restart-interactively restart) - (princ "No such restart."))))) -(def-debug-command "ERROR" -;;; Information commands. -;;; - -(def-debug-command "BACKTRACE" - "This controls how many lines the debugger's help command prints before - printing a prompting line to continue with output.") -(def-debug-command "P" -(def-debug-command "HELP" () - (let* ((end -1) -(def-debug-command "PP" - (print-frame-call *current-frame* nil nil)) - (count *help-line-scroll-count*)) -(def-debug-command "L" - (setf end len) - (return)) - (let ((*print-level* *debug-print-level*) - (*print-length* *debug-print-length*) - (write-string debug-help-string *standard-output* - :start start :end end)) - (format t "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ") - (force-output) - (di:do-debug-function-variables (v d-fun) - - (cond ((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*))) - (t #|(format t "~A has an invalid value currently.~%" - (di:debug-variable-name v))|#))) - (cond ((not any-p) - (write-line "No local variables in function.")) - ((not any-valid-p) - (write-line "All variables currently have invalid values.")))) - -(def-debug-command-alias "PP" "VPRINT") -(def-debug-command "SOURCE" - (print-frame-source-form *current-frame* (read-if-available 0))) - (*print-length* (or *debug-print-length* *print-level*)) -(def-debug-command "VSOURCE" - (print-frame-source-form *current-frame* (read-if-available 0) t)) - d-fun -(defun print-frame-source-form (frame context &optional verbose) - (let* ((location (di:frame-code-location frame)) - (format t "~A~:[#~D~;~*~] = ~S~%" - (di:debug-variable-name v) - (cond ((not (eq :file (di:debug-source-from d-source))) - (format t "~%Source did not come from a file.")) - ((not (probe-file name)) - (format t "~%Source file no longer exists -- ~A." - (namestring name))) - ((<= (di:debug-source-created d-source) - (file-write-date name)) - (let* ((tlf-offset (di:code-location-top-level-form-offset - location)) - (char-offset (aref (di:debug-source-start-positions - d-source) - tlf-offset))) - (with-open-file (f name) - (file-position f char-offset) - (let* ((tlf (read f)) - (translations (di:form-number-translations - tlf tlf-offset)) - (*print-level* (if verbose nil *debug-print-level*)) - (*print-length* (if verbose nil *debug-print-length*))) - (print (di:source-path-context - tlf - (svref translations - (di:code-location-form-number location)) - context)))))) - (t - (format t "~%File has been modified since compilation -- ~A." - (namestring name)))))) - (setf *possible-breakpoints* - (possible-breakpoints - *default-breakpoint-debug-function*)))))) - (setup-function-start () - (let ((code-loc (di:debug-function-start-location place))) -(def-debug-command "FLUSH" - (setf *flush-debug-errors* (not *flush-debug-errors*))) - - (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*)) - (if (not (ext:listen-skip-whitespace in)) - (princ prompt out)) - -;;; 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 b13f4250f03b1d1c7a08364409eecc0f4f491fe6..0000000000000000000000000000000000000000 --- a/code/defmacro.lisp +++ /dev/null @@ -1,413 +0,0 @@ -;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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 DEFMACRO function that is part of the -;;; standard Spice Lisp environment. For the version that runs in -;;; Maclisp, see file DEFMACRO.LSP. -;;; -;;; Written by Scott Fahlman. -;;; -;;; Ugly code, since I can't create macros here and need to stay close to -;;; Maclisp, so that it will be easy to create a derivitive version to use -;;; in the cross compiler. Even without this, there's so much going on -;;; in the arglist that the code has to be hairy. -;;; -(in-package 'lisp) -(export '(defmacro deftype)) - -;;; The following specials are used for communication during argument-list -;;; parsing for a macro or macro-like form. - -(proclaim '(special %arg-count %min-args %restp %let-list - %keyword-tests *keyword-package* - %env-arg-name %env-arg-used)) - -;;; The following is an ugly way of getting an optional arg passed in to -;;; Analyze1. Bootstrapping problems in Maclisp force me to do this. - -(defvar *default-default* nil) -(defvar *key-finder* 'find-keyword) - -;;; Parse-Defmacro -- Semi-Public -;;; -;;; Provides a clean interface to ANALYZE1 -;;; -(defun parse-defmacro (arglist whole code errloc &key (path `(cdr ,whole)) - ((:environment %env-arg-name)) error-string - (doc-string-allowed t) - ((:default-default *default-default*) nil) - ((:key-finder *key-finder*) 'find-keyword)) - "For use by macros and macro-like forms that must parse some form - according to a defmacro-like argument list, ARGLIST. The first value - returned is a LET* form which binds things and then evalutes the - specified CODE. WHOLE is the variable which is bound to the entire - arglist, or NIL if &whole is illegal. ERRLOC is the name of the function - being worked on, for use in error messages. The second value is a list - of ignore declarations for the WHOLE and ENVIRONMENT vars, if appropriate. - - PATH is an access expression for getting to the object to be parsed, - which defaults to the CDR of WHOLE. - - ENVIRONMENT is the place where the macroexpansion environment - may be found. If not supplied, then no &environment arg is allowed. - - ERROR-STRING is used as the argument to error if an incorrect number of - arguments are supplied. The additional error arguments are ERRLOC and - the number of arguments supplied. If not supplied, then no argument count - error checking is done. - - DOC-STRING-ALLOWED indicates whether a doc-string should be parsed out of - the body. If one is found, it is returned as the third value. - - DEFAULT-DEFAULT is the default value for unsupplied arguments, which defaults - to NIL. - - KEY-FINDER the function used to do keyword lookup. It defaults to a function - that does the right thing. - - The fourth and fifth values are the minimum and maximum number of arguments - allowed, in case you care about that kind of thing. The fifth value is NIL - if there is no upper limit." - (multiple-value-bind (body local-decs doc) - (parse-body code nil doc-string-allowed) - - (let ((%arg-count 0) (%min-args 0) - (%restp nil) (%let-list nil) - (%keyword-tests nil) - (%env-arg-used nil)) - (analyze1 arglist path errloc whole) - - (let ((arg-test (if error-string (defmacro-arg-test whole))) - (body - `(let* ,(nreverse %let-list) - ,@ local-decs - (progn - ,@ %keyword-tests - ,@ body)))) - (values - (if arg-test - `(if ,arg-test - (error ,error-string ',errloc (length ,path)) - ,body) - body) - ;; Wrong if no error check and arglist composed entirely of &environment - ;; args, but anyone who does that deserves to lose... - `(,@(unless (or arg-test arglist) `((declare (ignore ,whole)))) - ,@(when (and %env-arg-name (not %env-arg-used)) - `((declare (ignore ,%env-arg-name))))) - doc - %min-args - (if %restp nil %arg-count)))))) - -;;; ANALYZE1 is implemented as a finite-state machine that steps -;;; through the legal parts of an arglist in order: required, optional, -;;; rest, key, and aux. The results are accumulated in a set of special -;;; variables: %let-list, %arg-count, %min-args, %restp, and %keyword-tests. -;;; -;;; ANALYZE1 is called by ANALYZE-ARGLIST to do the work for required and -;;; optional args. It calls other functions if &rest, &key, or &aux are -;;; encountered. - -(defun analyze1 (arglist path errloc whole) - (do ((args arglist (cdr args)) - (optionalp nil) - a temp) - ((atom args) - (cond ((null args) nil) - ;; Varlist is dotted, treat as &rest arg and exit. - (t (push (list args path) %let-list) - (setq %restp t)))) - (setq a (car args)) - (cond ((eq a '&whole) - (cond ((and whole (cdr args) (symbolp (cadr args))) - (push (list (cadr args) whole) %let-list) - (setq %restp t) - (setq args (cdr args))) - (t (error "Illegal or ill-formed &whole arg in ~S." errloc)))) - ((eq a '&environment) - (cond ((and %env-arg-name (cdr args) (symbolp (cadr args))) - (push `(,(cadr args) ,%env-arg-name) %let-list) - (setq %env-arg-used t) - (setq args (cdr args))) - (t (error "Illegal or ill-formed &environment arg in ~S." - errloc)))) - ((eq a '&optional) - (and optionalp - (cerror "Ignore it." - "Redundant &optional flag in varlist of ~S." errloc)) - (setq optionalp t)) - ((or (eq a '&rest) (eq a '&body)) - (return (analyze-rest (cdr args) path errloc whole))) - ((eq a '&key) - ;; Create a rest-arg, then do keyword analysis. - (setq temp (gensym)) - (setq %restp t) - (push (list temp path) %let-list) - (return (analyze-key (cdr args) temp errloc))) - ((eq a '&allow-other-keys) - (cerror "Ignore it." - "Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc)) - ((eq a '&aux) - (return (analyze-aux (cdr args) errloc))) - ((not optionalp) - (setq %min-args (1+ %min-args)) - (setq %arg-count (1+ %arg-count)) - (cond ((symbolp a) - (push `(,a (car ,path)) %let-list)) - ((atom a) - (cerror "Ignore this item." - "Non-symbol variable name in ~S." errloc)) - (t (let ((%min-args 0) (%arg-count 0) (%restp nil) - (new-whole (gensym))) - (push (list new-whole `(car ,path)) %let-list) - (analyze1 a new-whole errloc new-whole)))) - (setq path `(cdr ,path))) - ;; It's an optional arg. - (t (setq %arg-count (1+ %arg-count)) - (cond ((symbolp a) - ;; Just a symbol. Bind to car of path or default. - (push `(,a (cond (,path (car ,path)) - (t ,*default-default*))) - %let-list)) - ((atom a) - (cerror "Ignore this item." - "Non-symbol variable name in ~S." errloc)) - ((symbolp (car a)) - ;; Car of list is a symbol. Bind to car of path or - ;; to default value. - (push `(,(car a) - (cond (,path (car ,path)) - (t ,(cond ((> (length a) 1) (cadr a)) - (t *default-default*))))) - %let-list) - ;; Handle supplied-p variable, if any. - (and (> (length a) 2) - (push `(,(caddr a) (not (null ,path))) %let-list))) - ;; Then destructure arg against contents of this gensym. - (t (setq temp (gensym)) - (push `(,temp - (cond (,path (car ,path)) - (t ,(cond ((cddr a) (cadr a)) - (t *default-default*))))) - %let-list) - (let ((%min-args 0) (%arg-count 0) (%restp nil)) - (analyze1 (car a) temp errloc nil)) - ;; Handle supplied-p variable if any. - (and (> (length a) 2) - (push `(,(caddr a) (not (null ,path))) %let-list)))) - (setq path `(cdr ,path)))))) - - -;;; This deals with the portion of the arglist following any &rest flag. - -(defun analyze-rest (arglist path errloc whole) - (when (atom arglist) - (error "Bad &rest or &body arg in ~S." errloc)) - (prog ((rest-arg (car arglist)) - (more (cdr arglist))) - (cond ((symbolp rest-arg) - (push (list rest-arg path) %let-list)) - ((and (consp rest-arg) (> (length (the list rest-arg)) 1)) - (unless %env-arg-name - (error "Hairy &body not allowed when no environment available.")) - (let ((decls-var (second rest-arg)) - (doc-var (third rest-arg)) - (n-body (gensym)) (n-decls (gensym)) (n-doc (gensym))) - (setq rest-arg (first rest-arg)) - (when doc-var (push doc-var %let-list)) - (push decls-var %let-list) - (push `(,rest-arg - (multiple-value-bind (,n-body ,n-decls ,n-doc) - (parse-body ,path ,%env-arg-name - ,(not (null doc-var))) - (setq ,decls-var ,n-decls) - ,(if doc-var `(setq ,doc-var ,n-doc) n-doc) - ,n-body)) - %let-list))) - (t - (error "Bad &rest or &body arg in ~S." errloc))) - - (setq %restp t) - TRY-AGAIN - (cond ((null more) nil) - ((atom more) - (cerror "Ignore the illegal terminator." - "Dotted arglist terminator after &rest arg in ~S." errloc)) - ((eq (car more) '&key) - (analyze-key (cdr more) rest-arg errloc)) - ((eq (car more) '&aux) - (analyze-aux (cdr more) errloc)) - ((eq (car more) '&allow-other-keys) - (cerror "Ignore it." - "Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc)) - ((eq (cadr arglist) '&whole) - (cond ((and whole (cdr more) (symbolp (cadr more))) - (push (list (cadr more) whole) %let-list) - (setq more (cddr more)) - (go try-again)) - (t (error "Ill-formed or illegal &whole arg in ~S." - errloc)))) - ((eq (cadr arglist) '&environment) - (cond ((and %env-arg-name (cdr more) (symbolp (cadr more))) - (push `(,(cadr more) ,%env-arg-name) %let-list) - (setq %env-arg-used t) - (setq more (cddr more)) - (go try-again)) - (t (error "Ill-formed or illegal &environment arg in ~S." - errloc))))))) - -;;; Analyze stuff following &aux. - -(defun analyze-aux (arglist errloc) - (do ((args arglist (cdr args))) - ((null args)) - (cond ((atom args) - (cerror "Ignore the illegal terminator." - "Dotted arglist after &AUX in ~S." errloc) - (return nil)) - ((atom (car args)) - (push (list (car args) nil) %let-list)) - (t (push (list (caar args) (cadar args)) %let-list))))) - - -;;; Handle analysis of keywords, perhaps with destructuring over the keyword -;;; variable. Assumes the remainder of the calling form has already been -;;; bound to the variable passed in as RESTVAR. - -(defun analyze-key (arglist restvar errloc) - (let ((temp (gensym)) - (check-keywords t) - (keywords-seen nil)) - (push temp %let-list) - (do ((args arglist (cdr args)) - a k sp-var temp1) - ((atom args) - (cond ((null args) nil) - (t (cerror "Ignore the illegal terminator." - "Dotted arglist after &key in ~S." errloc)))) - (setq a (car args)) - (cond ((eq a '&allow-other-keys) - (setq check-keywords nil)) - ((eq a '&aux) - (return (analyze-aux (cdr args) errloc))) - ;; Just a top-level variable. Make matching keyword. - ((symbolp a) - (setq k (make-keyword a)) - (push `(,a (cond ((setq ,temp (,*key-finder* ',k ,restvar)) - (car ,temp)) - (t nil))) - %let-list) - (push k keywords-seen)) - ;; Filter out error that might choke defmacro. - ((atom a) - (cerror "Ignore this item." - "~S -- non-symbol variable name in arglist of ~S." - a errloc)) - ;; Deal with the common case: (var [init [svar]]) - ((symbolp (car a)) - (setq k (make-keyword (car a))) - ;; Deal with supplied-p variable, if any. - (cond ((and (cddr a) (symbolp (caddr a))) - (setq sp-var (caddr a)) - (push (list sp-var nil) %let-list)) - (t (setq sp-var nil))) - (push `(,(car a) - (cond ((setq ,temp (,*key-finder* ',k ,restvar)) - ,@(and sp-var `((setq ,sp-var t))) - (car ,temp)) - (t ,(cadr a)))) - %let-list) - (push k keywords-seen)) - ;; Filter out more error cases that might kill defmacro. - ((or (atom (car a)) (not (keywordp (caar a))) (atom (cdar a))) - (cerror "Ignore this item." - "~S -- ill-formed keyword arg in ~S." (car a) errloc)) - ;; Next case is ((:key var) [init [supplied-p]]). - ((symbolp (cadar a)) - (setq k (caar a)) - ;; Deal with supplied-p variable, if any. - (cond ((and (cddr a) (symbolp (caddr a))) - (setq sp-var (caddr a)) - (push (list sp-var nil) %let-list)) - (t (setq sp-var nil))) - (push `(,(cadar a) - (cond ((setq ,temp (,*key-finder* ',k ,restvar)) - ,@(and sp-var `((setq ,sp-var t))) - (car ,temp)) - (t ,(cadr a)))) - %let-list) - (push k keywords-seen)) - ;; Same case, but must destructure the "variable". - (t (setq k (caar a)) - (setq temp1 (gensym)) - (cond ((and (cddr a) (symbolp (caddr a))) - (setq sp-var (caddr a)) - (push (list sp-var nil) %let-list)) - (t (setq sp-var nil))) - (push `(,temp1 - (cond ((setq ,temp (,*key-finder* ',k ,restvar)) - ,@(and sp-var `((setq ,sp-var t))) - (car ,temp)) - (t ,(cadr a)))) - %let-list) - (push k keywords-seen) - (let ((%min-args 0) (%arg-count 0) (%restp nil)) - (analyze1 (cadar a) temp1 errloc nil))))) - (and check-keywords - (push `(keyword-test ,restvar ',keywords-seen) %keyword-tests)))) - - -;;; Functions that must be around when the macros produced by DEFMACRO are -;;; expanded. - -(defun make-keyword (s) - "Takes a non-keyword symbol S and returns the corresponding keyword." - (intern (symbol-name s) *keyword-package*)) - - -(defun find-keyword (keyword keylist) - "If keyword is present in the keylist, return a list of its argument. - Else, return NIL." - (do ((l keylist (cddr l))) - ((atom l) nil) - (cond ((atom (cdr l)) - (cerror "Stick a NIL on the end and go on." - "Unpaired item in keyword portion of macro call.") - (rplacd l (list nil)) - (return nil)) - ((eq (car l) keyword) (return (list (cadr l))))))) - - -(defun keyword-test (keylist legal) - "Check whether all keywords in a form are legal. KEYLIST is the portion - of the calling form containing keywords. LEGAL is the list of legal - keywords. If the keyword :allow-other-keyws is present in KEYLIST, - just return without complaining about anything." - (cond ((member ':allow-other-keys keylist :test #'eq) nil) - (t (do ((kl keylist (cddr kl))) - ((atom kl) nil) - (cond ((member (car kl) legal :test #'eq)) - (t (cerror "Ignore it." - "~S illegal or unknown keyword." (car kl)))))))) - -;;; Return a form which tests whether an illegal number of arguments -;;; have been supplied. Args is the name of the variable to which -;;; the arglist is bound. -;;; -(defun defmacro-arg-test (args) - (cond ((and (zerop %min-args) %restp) nil) - ((zerop %min-args) - `(> (length ,args) ,(1+ %arg-count))) - (%restp - `(< (length ,args) ,(1+ %min-args))) - ((= %min-args %arg-count) - `(not (= (length ,args) ,(1+ %min-args)))) - (t - `(or (> (length ,args) ,(1+ %arg-count)) - (< (length ,args) ,(1+ %min-args)))))) diff --git a/code/defstruct.lisp b/code/defstruct.lisp deleted file mode 100644 index b8ed70a14728a19edb50877a37cce34462dd33b3..0000000000000000000000000000000000000000 --- a/code/defstruct.lisp +++ /dev/null @@ -1,595 +0,0 @@ -;;; -*- Log: code.log; Package: C -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Defstruct structure definition package (Mark II). -;;; Written by Skef Wholey and Rob MacLachlan. -;;; -(in-package 'c) -(export '(lisp::defstruct) "LISP") - -;;; In Spice Lisp, the default structure representation is a simple-vector with -;;; the subtype field set to 1. The first element is used to hold the name of -;;; the structure. This piece of implementation-dependency resides in the -;;; macros defined here. -;;; -(proclaim '(inline structurify)) -(defun structurify (structure) - "Frobs a vector to turn it into a named structure. Returns the vector." - (%primitive set-vector-subtype structure %g-vector-structure-subtype)) - - -;;; This version of Defstruct is implemented using Defstruct, and is free of -;;; Maclisp compatability nonsense. For bootstrapping, you're on your own. - -(defun print-defstruct-description (structure stream depth) - (declare (ignore depth)) - (format stream "#<Defstruct-Description for ~S>" (dd-name structure))) - -;;; DSD-Name -- Internal -;;; -;;; Return the the name of a defstruct slot as a symbol. We store it -;;; as a string to avoid creating lots of worthless symbols at load time. -;;; -(defun dsd-name (dsd) - (intern (string (dsd-%name dsd)) (symbol-package (dsd-accessor dsd)))) - -(defun print-defstruct-slot-description (structure stream depth) - (declare (ignore depth)) - (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure))) - - - -;;; The legendary macro itself. - -;;; ### Bootstrap hack... -;;; Install this definition only into the new compiler's environment so that we -;;; don't break the bootstrap environment. -;;; -(compiler-let ((lisp::*bootstrap-defmacro* t)) - -(defmacro defstruct (name-and-options &rest slot-descriptions) - "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)} - Define the structure type Name. See the manual for details." - (let* ((defstruct (parse-name-and-options name-and-options)) - (name (dd-name defstruct))) - (parse-slot-descriptions defstruct slot-descriptions) - (if (eq (dd-type defstruct) 'structure) - `(progn - (%compiler-defstruct ',defstruct) - ,@(define-constructor defstruct) - ,@(define-boa-constructors defstruct) - - ;; - ;; So the print function is in the right lexical environment, and - ;; can be compiled... - (let ((new ',defstruct)) - ,@(let ((pf (dd-print-function defstruct))) - (when pf - `((setf (info type printer ',name) - ,(if (symbolp pf) - `',pf - `#',pf))))) - (%defstruct new)) - ',name) - `(progn - (eval-when (compile load eval) - (setf (info type kind ',name) nil) - (setf (info type structure-info ',name) ',defstruct)) - ,@(define-constructor defstruct) - ,@(define-boa-constructors defstruct) - ,@(define-predicate defstruct) - ,@(define-accessors defstruct) - ,@(define-copier defstruct) - ',name)))) - -); Compiler-Let - - -;;;; Parsing: - -(defun parse-name-and-options (name-and-options) - (if (atom name-and-options) - (setq name-and-options (list name-and-options))) - (do* ((options (cdr name-and-options) (cdr options)) - (name (car name-and-options)) - (print-function nil) - (pf-supplied-p) - (conc-name (concat-pnames name '-)) - (constructor (concat-pnames 'make- name)) - (saw-constructor) - (boa-constructors '()) - (copier (concat-pnames 'copy- name)) - (predicate (concat-pnames name '-p)) - (include) - (saw-type) - (type 'structure) - (saw-named) - (offset 0)) - ((null options) - (make-defstruct-description - :name name - :conc-name conc-name - :constructor constructor - :boa-constructors boa-constructors - :copier copier - :predicate predicate - :include include - :print-function print-function - :type type - :lisp-type (cond ((eq type 'structure) 'simple-vector) - ((eq type 'vector) 'simple-vector) - ((eq type 'list) 'list) - ((and (listp type) (eq (car type) 'vector)) - (cons 'simple-array (cdr type))) - (t (error "~S is a bad :TYPE for Defstruct." type))) - :named (if saw-type saw-named t) - :offset offset)) - (if (atom (car options)) - (case (car options) - (:constructor (setq saw-constructor t - constructor (concat-pnames 'make- name))) - (:copier) - (:predicate) - (:named (setq saw-named t)) - (t (error "The Defstruct option ~S cannot be used with 0 arguments." - (car options)))) - (let ((option (caar options)) - (args (cdar options))) - (case option - (:conc-name (setq conc-name (car args))) - (:constructor (cond ((cdr args) - (unless saw-constructor - (setq constructor nil)) - (push args boa-constructors)) - (t - (setq saw-constructor t) - (setq constructor - (or (car args) - (concat-pnames 'make- name)))))) - (:copier (setq copier (car args))) - (:predicate (setq predicate (car args))) - (:include - (setf include args) - (let* ((name (car include)) - (included-structure - (info type structure-info name)) - (included-print-function - (if included-structure - (dd-print-function included-structure)))) - (unless included-structure - (error "Cannot find description of structure ~S to use for ~ - inclusion." - name)) - (unless pf-supplied-p - (setf print-function included-print-function)))) - (:print-function - (setf print-function (car args)) - (setf pf-supplied-p t)) - (:type (setf saw-type t type (car args))) - (:named (error "The Defstruct option :NAMED takes no arguments.")) - (:initial-offset (setf offset (car args))) - (t (error "~S is an unknown Defstruct option." option))))))) - - - -;;;; Stuff to parse slot descriptions. - -;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does -;;; any structure inclusion that needs to be done. -;;; -(defun parse-slot-descriptions (defstruct slots) - ;; First strip off any doc string and stash it in the Defstruct. - (when (stringp (car slots)) - (setf (dd-doc defstruct) (car slots)) - (setq slots (cdr slots))) - ;; Then include stuff. We add unparsed items to the start of the Slots. - (when (dd-include defstruct) - (let* ((included-name (car (dd-include defstruct))) - (included-thing (info type structure-info included-name)) - (modified-slots (cdr (dd-include defstruct)))) - (unless included-thing - (error "Cannot find description of structure ~S to use for inclusion." - included-name)) - (setf (dd-includes defstruct) - (cons (dd-name included-thing) (dd-includes included-thing))) - (setf (dd-offset defstruct) (dd-offset included-thing)) - (do* ((islots (mapcar #'(lambda (slot) - `(,(dsd-name slot) ,(dsd-default slot) - :type ,(dsd-type slot) - :read-only ,(dsd-read-only slot))) - (dd-slots included-thing))) - (islots* islots (cdr islots*))) - ((null islots*) - (setq slots (nconc islots slots))) - (let* ((islot (car islots*)) - (modifiee (find (car islot) modified-slots - :key #'(lambda (x) (if (atom x) x (car x))) - :test #'string=))) - (when modifiee - (cond ((symbolp modifiee) - ;; If it's just a symbol, nilify the default. - (setf (cadr islot) nil)) - ((listp modifiee) - ;; If it's a list, parse new defaults and options. - (setf (cadr islot) (cadr modifiee)) - (when (cddr modifiee) - (do ((options (cddr modifiee) (cddr options))) - ((null options)) - (case (car options) - (:type - (setf (cadddr islot) (cadr options))) - (:read-only - (setf (cadr (cddddr islot)) (cadr options))) - (t - (error "Bad option in included slot spec: ~S." - (car options))))))))))))) - ;; Finally parse the slots into Slot-Description objects. - (do ((slots slots (cdr slots)) - (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0)) - (1+ index)) - (descriptions ())) - ((null slots) - (setf (dd-length defstruct) index) - (setf (dd-slots defstruct) (nreverse descriptions))) - (let* ((slot (car slots)) - (name (if (atom slot) slot (car slot)))) - (when (keywordp name) - (warn "Keyword slot name indicates possible syntax error in DEFSTRUCT ~ - -- ~S." - name)) - (push - (if (atom slot) - (make-defstruct-slot-description - :%name (string name) - :index index - :accessor (concat-pnames (dd-conc-name defstruct) name) - :type t) - (do ((options (cddr slot) (cddr options)) - (default (cadr slot)) - (type t) - (read-only nil)) - ((null options) - (make-defstruct-slot-description - :%name (string name) - :index index - :accessor (concat-pnames (dd-conc-name defstruct) name) - :default default - :type type - :read-only read-only)) - (case (car options) - (:type (setq type (cadr options))) - (:read-only (setq read-only (cadr options)))))) - descriptions)))) - - - -;;;; Default structure access and copiers: -;;; -;;; In the normal case of structures that have a real type (i.e. no :Type -;;; option was specified), we want to optimize things for space as well as -;;; speed, since there can be thousands of defined slot accesors. -;;; -;;; What we do is defined the accessors and copier as closures over -;;; general-case code. Since the compiler will normally open-code accesors, -;;; the (minor) efficiency penalty is not a concern. - -;;; Typep-To-Structure -- Internal -;;; -;;; Return true if Obj is an object of the structure type specified by Info. -;;; This is called by the accessor closures, which have a handle on the type's -;;; Defstruct-Description. -;;; -(proclaim '(inline typep-to-structure)) -(defun typep-to-structure (obj info) - (declare (type defstruct-description info) (inline member)) - (and (structurep obj) - (let ((name (%primitive header-ref obj 0))) - (or (eq name (dd-name info)) - (member name (dd-included-by info) :test #'eq))))) - -#+new-compiler -;;; %Defstruct -- Internal -;;; -;;; Do miscellaneous load-time actions for the structure described by Info. -;;; Define setters, accessors, copier, predicate, documentation, instantiate -;;; definition in load-time env. This is only called for default structures. -;;; -(defun %defstruct (info) - (declare (type defstruct-description info)) - (setf (info type defined-structure-info (dd-name info)) info) - - (dolist (slot (dd-slots info)) - (let ((dsd slot)) - (setf (symbol-function (dsd-accessor slot)) - #'(lambda (structure) - (declare (optimize (speed 3) (safety 0))) - (unless (typep-to-structure structure info) - (error "Structure for accessor ~S is not a ~S:~% ~S" - (dsd-accessor dsd) (dd-name info) structure)) - (%primitive header-ref structure (dsd-index dsd)))) - - (unless (dsd-read-only slot) - (setf (fdefinition `(setf ,(dsd-accessor slot))) - #'(lambda (structure new-value) - (declare (optimize (speed 3) (safety 0))) - (unless (typep-to-structure structure info) - (error "Structure for setter ~S is not a ~S:~% ~S" - `(setf ,(dsd-accessor dsd)) (dd-name info) - structure)) - (unless (typep new-value (dsd-type dsd)) - (error "New-Value for setter ~S is not a ~S:~% ~S." - `(setf ,(dsd-accessor dsd)) (dsd-type dsd) - new-value)) - (%primitive header-set structure (dsd-index dsd) - new-value)))))) - - (when (dd-predicate info) - (setf (symbol-function (dd-predicate info)) - #'(lambda (object) - (declare (optimize (speed 3) (safety 0))) - (if (typep-to-structure object info) t nil)))) - - (when (dd-copier info) - (setf (symbol-function (dd-copier info)) - #'(lambda (structure) - (declare (optimize (speed 3) (safety 0))) - (unless (typep-to-structure structure info) - (error "Structure for copier ~S is not a ~S:~% ~S" - (dd-copier info) (dd-name info) structure)) - - (let ((len (dd-length info))) - (declare (fixnum len)) - (do ((i 1 (1+ i)) - (res (%primitive alloc-g-vector len nil))) - ((= i len) - (%primitive header-set res 0 (dd-name info)) - (structurify res)) - (declare (fixnum i)) - (%primitive header-set res i - (%primitive header-ref structure i))))))) - (when (dd-doc info) - (setf (documentation (dd-name info) 'type) (dd-doc info)))) - - -;;; Define-Accessors returns a list of function definitions for accessing and -;;; setting the slots of the a typed Defstruct. The functions are proclaimed -;;; to be inline, and the types of their arguments and results are declared as -;;; well. We count on the compiler to do clever things with Elt. - -(defun define-accessors (defstruct) - (do ((slots (dd-slots defstruct) (cdr slots)) - (stuff '()) - (type (dd-lisp-type defstruct))) - ((null slots) stuff) - (let* ((slot (car slots)) - (name (dsd-accessor slot)) - (index (dsd-index slot)) - (slot-type (dsd-type slot))) - (push - `(progn - (proclaim '(inline ,name (setf ,name))) - (defun ,name (structure) - (declare (type ,type structure)) - (the ,slot-type (elt structure ,index))) - ,@(unless (dsd-read-only slot) - `((defun (setf ,name) (structure new-value) - (declare (type ,type structure) (type ,slot-type new-value)) - (setf (elt structure ,index) new-value))))) - stuff)))) - - -;;; Define-Constructor returns a definition for the constructor function of the -;;; given Defstruct. If the structure is implemented as a vector and is named, -;;; we structurify it. If the structure is a vector of some specialized type, -;;; we can't use the Vector function. -;;; -;;; If we are defining safe accessors, we also check the types of the values to -;;; make sure that they are legal. -;;; -(defun define-constructor (defstruct) - (let ((name (dd-constructor defstruct))) - (when name - (let* ((initial-cruft - (if (dd-named defstruct) - (make-list (1+ (dd-offset defstruct)) - :initial-element `',(dd-name defstruct)) - (make-list (dd-offset defstruct)))) - (slots (dd-slots defstruct)) - (names (mapcar #'dsd-name slots)) - (args (mapcar #'(lambda (slot) - `(,(dsd-name slot) ,(dsd-default slot))) - slots))) - `((defun ,name ,(if args `(&key ,@args)) - (declare - ,@(mapcar #'(lambda (slot) - `(type ,(dsd-type slot) ,(dsd-name slot))) - slots)) - ,(case (dd-type defstruct) - (list - `(list ,@initial-cruft ,@names)) - (structure - `(truly-the ,(dd-name defstruct) - (structurify - (vector ,@initial-cruft ,@names)))) - (vector - `(vector ,@initial-cruft ,@names)) - (t - (do ((sluts slots (cdr sluts)) - (sets '()) - (temp (gensym))) - ((null sluts) - `(let ((,temp (make-array - ,(dd-length defstruct) - :element-type - ',(cadr (dd-lisp-type defstruct))))) - ,@(when (dd-named defstruct) - `(setf (aref ,temp ,(dd-offset defstruct)) - ',(dd-name defstruct))) - ,@sets - ,temp)) - (let ((slot (car sluts))) - (push `(setf (aref ,temp ,(dsd-index slot)) - ,(dsd-name slot)) - sets))))))))))) - - - -;;;; Support for By-Order-Argument Constructors. - -;;; FIND-LEGAL-SLOT -- Internal -;;; -;;; Given a defstruct description and a slot name, return the corresponding -;;; slot if it exists, or signal an error if not. -;;; -(defun find-legal-slot (defstruct name) - (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=) - (error "~S is not a defined slot name in the ~S structure." - name (dd-name defstruct)))) - - -;;; Define-Boa-Constructors defines positional constructor functions. We -;;; generate code to set each variable not specified in the arglist to the -;;; default given in the Defstruct. We just slap required args in, as with -;;; rest args and aux args. Optionals are treated a little differently. Those -;;; that aren't supplied with a default in the arg list are mashed so that -;;; their default in the arglist is the corresponding default from the -;;; Defstruct. -;;; -(defun define-boa-constructors (defstruct) - (do* ((boas (dd-boa-constructors defstruct) (cdr boas)) - (name (car (car boas)) (car (car boas))) - (args (copy-list (cadr (car boas))) (copy-list (cadr (car boas)))) - (slots (dd-slots defstruct) (dd-slots defstruct)) - (slots-in-arglist '() '()) - (defuns '())) - ((null boas) defuns) - ;; Find the slots in the arglist and hack the defaultless optionals. - (do ((args args (cdr args)) - (arg-kind 'required)) - ((null args)) - (let ((arg (car args))) - (cond ((not (atom arg)) - (push (find-legal-slot defstruct (car arg)) slots-in-arglist)) - ((memq arg '(&optional &rest &aux &key)) - (setq arg-kind arg)) - (t - (case arg-kind - ((required &rest &aux) - (push (find-legal-slot defstruct arg) slots-in-arglist)) - ((&optional &key) - (let ((dsd (find-legal-slot defstruct arg))) - (push dsd slots-in-arglist) - (rplaca args (list arg (dsd-default dsd)))))))))) - - ;; Then make a list that can be used with a (list ...) or (vector...). - (let ((initial-cruft - (if (dd-named defstruct) - (make-list (1+ (dd-offset defstruct)) - :initial-element `',(dd-name defstruct)) - (make-list (dd-offset defstruct)))) - (thing (mapcar #'(lambda (slot) - (if (memq slot slots-in-arglist) - (dsd-name slot) - (dsd-default slot))) - slots))) - (push - `(defun ,name ,args - (declare - ,@(mapcar #'(lambda (slot) - `(type ,(dsd-type slot) ,(dsd-name slot))) - slots-in-arglist)) - ,(case (dd-type defstruct) - (list - `(list ,@initial-cruft ,@thing)) - (structure - `(truly-the ,(dd-name defstruct) - (structurify (vector ,@initial-cruft ,@thing)))) - (vector - `(vector ,@initial-cruft ,@thing)) - (t - (do ((things thing (cdr things)) - (index 0 (1+ index)) - (sets '()) - (temp (gensym))) - ((null things) - `(let ((,temp (make-array - ,(dd-length defstruct) - :element-type - ',(cadr (dd-lisp-type defstruct))))) - ,@(when (dd-named defstruct) - `(setf (aref ,temp ,(dd-offset defstruct)) - ',(dd-name defstruct))) - ,@sets - ,temp)) - (push `(setf (aref ,temp index) ,(car things)) - sets))))) - defuns)))) - -;;; Define-Copier returns the definition for a copier function of a typed -;;; Defstruct if one is desired. - -(defun define-copier (defstruct) - (when (dd-copier defstruct) - `((defun ,(dd-copier defstruct) (structure) - (declare (type ,(dd-lisp-type defstruct) structure)) - (subseq structure 0 ,(dd-length defstruct)))))) - - -;;; Define-Predicate returns a definition for a predicate function if one is -;;; desired. This is only called for typed structures, since the default -;;; structure predicate is implemented as a closure. - -(defun define-predicate (defstruct) - (let ((name (dd-name defstruct)) - (pred (dd-predicate defstruct))) - (when (and pred (dd-named defstruct)) - (let ((ltype (dd-lisp-type defstruct))) - `((defun ,pred (object) - (and (typep object ',ltype) - (eq (elt (the ,ltype object) ,(dd-offset defstruct)) - ',name)))))))) - - -;;; Structure-Predicate -- Internal -;;; -;;; The typep transform in typetran calls this function when it encounters -;;; an unknown symbol type specifier. If the referred-to type is in fact a -;;; structure type that has a predicate, then we open-code the normal case of -;;; an exact match, and otherwise call the predicate. -;;; -(defun structure-predicate (object type) - (let ((def (info type structure-info type))) - (if (and def (eq (dd-type def) 'structure) (dd-predicate def)) - `(and (structurep ,object) - (if (eq (%primitive header-ref ,object 0) ',type) - t - (,(dd-predicate def) ,object))) - `(lisp::structure-typep ,object ',type)))) - - -;;; Random sorts of stuff. - -(defun default-structure-print (structure stream depth) - (declare (ignore depth)) - (write-string "#S(" stream) - (prin1 (svref structure 0) stream) - (do ((index 1 (1+ index)) - (length (length structure)) - (slots (dd-slots (info type defined-structure-info (svref structure 0))) - (cdr slots))) - ((or (= index length) - (and *print-length* - (= index *print-length*))) - (if (= index length) - (write-string ")" stream) - (write-string "...)" stream))) - (write-char #\space stream) - (prin1 (dsd-name (car slots)) stream) - (write-char #\space stream) - (prin1 (svref structure index) stream))) diff --git a/code/describe.lisp b/code/describe.lisp deleted file mode 100644 index f63e49bed0fce1528253923d9a3c3ef8e584d9fe..0000000000000000000000000000000000000000 --- a/code/describe.lisp +++ /dev/null @@ -1,321 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 (Scott.Fahlman@cs.cmu.edu). -;;; ********************************************************************** -;;; -;;; This is the describe mechanism for Common Lisp. -;;; -;;; Written by Skef Wholey or Rob MacLachlan originally. -;;; Cleaned up, reorganized, and enhanced by Blaine Burks. -;;; -;;; This should be done better using CLOS more effectively once CMU Common -;;; Lisp is brought up to the new standard. The TYPECASE in DESCRIBE-AUX -;;; should be unnecessary. -- Bill Chiles -;;; - -(in-package "LISP") - -(export '(describe *describe-level* *describe-verbose* - *describe-implementation-details* *describe-print-level* - *describe-print-length* *describe-indentation*)) - - -;;;; DESCRIBE public switches. - -(defvar *describe-level* 2 - "Depth of recursive descriptions allowed.") - -(defvar *describe-verbose* nil - "If non-nil, descriptions may provide interpretations of information and - pointers to additional information. Normally nil.") - -(defvar *describe-implementation-details* nil - "If non-null, normally concealed implementation information won't be.") - -(defvar *describe-print-level* 2 - "*print-level* gets bound to this inside describe.") - -(defvar *describe-print-length* 5 - "*print-length gets bound to this inside describe.") - -(defvar *describe-indentation* 3 - "Number of spaces that sets off each line of a recursive description.") - -(defvar *in-describe* nil - "Used to tell whether we are doing a recursive describe.") -(defvar *current-describe-level* 0 - "Used to implement recursive description cutoff. Don't touch.") -(defvar *describe-output* nil - "An output stream used by Describe for indenting and stuff.") -(defvar *used-documentation* nil "Documentation already described.") -(defvar *described-objects* nil - "List of all objects describe within the current top-level call to describe.") -(defvar *current-describe-object* nil - "The last object passed to describe.") - -;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the -;;; hard stuff. -;;; -(defun describe (x &optional (stream *standard-output*)) - "Prints a description of the object X. - See also *describe-level*, defdescribe, *describe-verbose*, - *describe-implementation-details*, *describe-print-level*, - *describe-print-length*, and *describe-indentation*." - (unless *describe-output* - (setq *describe-output* (make-indenting-stream *standard-output*))) - (cond (*in-describe* - (unless (or (eq x nil) (eq x t)) - (let ((*current-describe-level* (1+ *current-describe-level*)) - (*current-describe-object* x)) - (indenting-further *describe-output* *describe-indentation* - (describe-aux x))))) - (t - (setf (indenting-stream-stream *describe-output*) stream) - (let ((*standard-output* *describe-output*) - (*print-level* *describe-print-level*) - (*print-length* *describe-print-length*) - (*used-documentation* ()) - (*described-objects* ()) - (*in-describe* t) - (*current-describe-object* x)) - (describe-aux x)) - (values)))) - -;;; DESCRIBE-AUX does different things for each type. The order of the -;;; TYPECASE branches matters with respect to: -;;; - symbols and functions until the new standard makes them disjoint. -;;; - packages and structure since packages are structures. -;;; We punt a given call if the current level is greater than *describe-level*, -;;; or if we detect an object into which we have already descended. -;;; -(defun describe-aux (x) - (when (or (not (integerp *describe-level*)) - (minusp *describe-level*)) - (error "*describe-level* should be a nonnegative integer - ~A." - *describe-level*)) - (when (or (>= *current-describe-level* *describe-level*) - (member x *described-objects*)) - (return-from describe-aux x)) - (push x *described-objects*) - (typecase x - (symbol (describe-symbol x)) - (function (describe-function x)) - (package (describe-package x)) - (hash-table (describe-hash-table x)) - (structure (describe-structure x)) - (array (describe-array x)) - (fixnum (describe-fixnum x)) - (t (default-describe x))) - x) - - - -;;;; Implementation properties. - -;;; This supresses random garbage that users probably don't want to see. -;;; -(defparameter *implementation-properties* - '(%loaded-address - ;; - ;; Documentation properties: - %var-documentation %fun-documentation %struct-documentation - %type-documentation %setf-documentation %documentation)) - - -;;;; DESCRIBE methods. - -;;; DESC-DOC prints the specified kind of documentation about the given Symbol. -;;; -(defun desc-doc (symbol name string) - (let ((doc (documentation symbol name))) - (when (and doc (not (member doc *used-documentation*))) - (push doc *used-documentation*) - (format t "~&~A~& ~A" string doc)))) - - -(defun default-describe (x) - (format t "~&~S is a ~S." x (type-of x))) - -(defun describe-symbol (x) - (let ((package (symbol-package x))) - (if package - (multiple-value-bind (symbol status) - (find-symbol (symbol-name x) package) - (declare (ignore symbol)) - (format t "~&~A is an ~A symbol in the ~A package." x - (string-downcase (symbol-name status)) - (package-name (symbol-package x)))) - (format t "~&~A is an uninterned symbol." x))) - ;; - ;; Describe the value cell. - (when (boundp x) - (let ((value (symbol-value x)) - (constantp (constantp x))) - (cond ((get x 'globally-special) - (if constantp - (format t "~&It is a constant; its value is ~S." value) - (format t "~&It is a special variable; ~ - its current binding is ~S." - value))) - (t - (fresh-line) - (write-string "Its value is ") - (print-for-describe value nil))) - (desc-doc x 'variable - (format nil "~:[Variable~;Constant~] Documentation:" - constantp)) - (describe value))) - ;; - ;; Describe the function cell. - (cond ((macro-function x) - (let ((fun (macro-function x))) - (format t "~&Its macroexpansion function is ~A." fun) - (describe-function fun) - (desc-doc x 'function "Macro Documentation:"))) - ((fboundp x) - (describe-function (symbol-function x)))) - ;; - ;; Print other documentation. - (desc-doc x 'structure "Documentation on the structure:") - (desc-doc x 'type "Documentation on the type:") - (desc-doc x 'setf "Documentation on the SETF form:") - (dolist (assoc (get x '%documentation)) - (unless (member (cdr assoc) *used-documentation*) - (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc)))) - ;; - ;; Print out properties, possibly ignoring implementation details. - (do ((plist (symbol-plist X) (cddr plist)) - (properties-to-ignore (if *describe-implementation-details* - nil - *implementation-properties*))) - ((null plist) ()) - (unless (member (car plist) properties-to-ignore) - (format t "~&Its ~S property is ~S." (car plist) (cadr plist)) - (describe (cadr plist))))) - -(defun describe-structure (x) - (format t "~&~S is a structure of type ~A." x (svref x 0)) - (dolist (slot (cddr (inspect::describe-parts x))) - (format t "~%~A: ~S." (car slot) (cdr slot)))) - -(defun describe-array (x) - (let ((rank (array-rank x))) - (cond ((> rank 1) - (format t "~&~S is " x) - (write-string (if (%displacedp x) "a displaced" "an")) - (format t " array of rank ~A." rank) - (format t "~%Its dimensions are ~S." (array-dimensions x))) - (t - (format t "~&~S is a ~:[~;displaced ~]vector of length ~D." x - (%displacedp x) (length x)) - (if (array-has-fill-pointer-p x) - (format t "~&It has a fill pointer, currently ~d" - (fill-pointer x)) - (format t "~&It has no fill pointer.")))) - (format t "~&Its element type is ~S." (array-element-type x)))) - -(defmacro describe-function-arg-list (object test output) - `(progn - (print-for-describe ,object) - (if ,test - (write-string " is called with zero arguments.") - (indenting-further *standard-output* 2 - (format t " can be called with these arguments:~%") - ,output)))) - -(defun describe-function (x) - (case (%primitive get-vector-subtype x) - (#.%function-entry-subtype - (describe-function-compiled x)) - (#.%function-closure-subtype - (describe-function-lex-closure x)) - (t - (format t "~&It is an unknown type of function.")))) - -(defun describe-function-compiled (x) - (let ((args (%primitive header-ref x %function-entry-arglist-slot))) - (describe-function-arg-list - *current-describe-object* (string= args "()") (write-string args))) - (let ((*print-level* nil) - (*print-length* nil) - (type (%primitive header-ref x %function-entry-type-slot))) - (format t "~&Its argument types are:~% ~S" (second type)) - (format t "~&Its result type is:~% ~S" (third type))) - - (let ((name (%primitive header-ref x %function-name-slot))) - (when (symbolp name) - (desc-doc name 'function "Function Documention:"))) - - (let ((info (%primitive header-ref - (%primitive header-ref x - %function-entry-constants-slot) - %function-constants-debug-info-slot))) - (when info - (let ((sources (c::compiled-debug-info-source info))) - (format t "~&On ~A it was compiled from:" - (format-universal-time nil - (c::debug-source-compiled - (first sources)))) - (dolist (source sources) - (let ((name (c::debug-source-name source))) - (ecase (c::debug-source-from source) - (:file - (format t "~&~A~% Created: " (namestring name)) - (ext:format-universal-time t (c::debug-source-created source)) - (let ((comment (c::debug-source-comment source))) - (when comment - (format t "~& Comment: ~A" comment)))) - (:stream (format t "~&~S" name)) - (:lisp (format t "~&~S" name))))))))) - -(defun describe-function-lex-closure (x) - (print-for-describe x) - (format t " is a lexical closure.~%") - (format t "~&Its lexical environment is:") - (indenting-further *standard-output* 8 - (do ((i %function-closure-variables-offset (1+ i))) - ((= i (%primitive header-length x))) - (format t "~&~D: ~S" - (- i %function-closure-variables-offset) - (%primitive header-ref x i)))) - (describe-function-compiled (%primitive header-ref x %function-name-slot))) - - -(defun print-for-describe (x &optional (freshp t)) - (when freshp (fresh-line)) - (cond ((symbolp x) - (write-string (symbol-name x))) - (t - (princ x)))) - -(defun describe-fixnum (x) - (cond ((not (or *describe-verbose* (zerop *current-describe-level*)))) - ((primep x) - (format t "~&It is a prime number.")) - (t - (format t "~&It is a composite number.")))) - -(defun describe-hash-table (x) - (format t "~&~S is an ~a hash table." x (hash-table-kind x)) - (format t "~&Its size is ~d buckets." (hash-table-size x)) - (format t "~&Its rehash-size is ~d." (hash-table-rehash-size x)) - (format t "~&Its rehash-threshold is ~d." - (hash-table-rehash-threshold x)) - (format t "~&It currently holds ~d entries." - (hash-table-number-entries x))) - -(defun describe-package (x) - (describe-structure x) - (let* ((internal (package-internal-symbols x)) - (internal-count (- (package-hashtable-size internal) - (package-hashtable-free internal))) - (external (package-external-symbols x)) - (external-count (- (package-hashtable-size external) - (package-hashtable-free external)))) - (format t "~&~d symbols total: ~d internal and ~d external." - (+ internal-count external-count) internal-count external-count))) - diff --git a/code/error.lisp b/code/error.lisp deleted file mode 100644 index 6ded6274011af510499bd9dc32c94d940b523171..0000000000000000000000000000000000000000 --- a/code/error.lisp +++ /dev/null @@ -1,1238 +0,0 @@ -;;; -*- Package: conditions; Log: code.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 is a condition system for CMU Common Lisp. -;;; It was originally taken from some prototyping code written by KMP@Symbolics -;;; and massaged for our uses. -;;; - -(in-package "CONDITIONS") - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* t)) - -(in-package "LISP") -(export '(break error warn cerror - ;; - ;; The following are found in Macros.Lisp: - check-type assert etypecase ctypecase ecase ccase - ;; - ;; These are all the new things to export from "LISP" now that this - ;; proposal has been accepted. - *break-on-signals* *debugger-hook* signal handler-case handler-bind - ignore-errors define-condition make-condition with-simple-restart - restart-case restart-bind restart-name restart-name find-restart - compute-restarts invoke-restart invoke-restart-interactively abort - continue muffle-warning store-value use-value invoke-debugger restart - condition warning serious-condition simple-condition simple-warning - simple-error simple-condition-format-string - simple-condition-format-arguments storage-condition stack-overflow - storage-exhausted type-error type-error-datum - type-error-expected-type simple-type-error program-error - control-error stream-error stream-error-stream end-of-file file-error - file-error-pathname cell-error unbound-variable undefined-function - arithmetic-error arithmetic-error-operation arithmetic-error-operands - package-error package-error-package division-by-zero - floating-point-overflow floating-point-underflow)) - - -(in-package "CONDITIONS") - -;;;; Keyword utilities. - -(eval-when (eval compile load) - -(defun parse-keyword-pairs (list keys) - (do ((l list (cddr l)) - (k '() (list* (cadr l) (car l) k))) - ((or (null l) (not (member (car l) keys))) - (values (nreverse k) l)))) - -(defmacro with-keyword-pairs ((names expression &optional keywords-var) - &body forms) - (let ((temp (member '&rest names))) - (unless (= (length temp) 2) - (error "&rest keyword is ~:[missing~;misplaced~]." temp)) - (let ((key-vars (ldiff names temp)) - (key-var (or keywords-var (gensym))) - (rest-var (cadr temp))) - (let ((keywords (mapcar #'(lambda (x) - (intern (string x) ext:*keyword-package*)) - key-vars))) - `(multiple-value-bind (,key-var ,rest-var) - (parse-keyword-pairs ,expression ',keywords) - (let ,(mapcar #'(lambda (var keyword) - `(,var (getf ,key-var ,keyword))) - key-vars keywords) - ,@forms)))))) - -) ;eval-when - - - -;;;; Restarts. - -(defvar *restart-clusters* '()) - -(defun compute-restarts () - "Return a list of all the currently active restarts ordered from most - recently established to less recently established." - (copy-list (apply #'append *restart-clusters*))) - -(defun restart-print (restart stream depth) - (declare (ignore depth)) - (if *print-escape* - (format stream "#<~S.~X>" - (type-of restart) (system:%primitive lisp::make-fixnum restart)) - (restart-report restart stream))) - -(defstruct (restart (:print-function restart-print)) - name - function - report-function - interactive-function) - -(setf (documentation 'restart-name 'function) - "Returns the name of the given restart object.") - -(defun restart-report (restart stream) - (funcall (or (restart-report-function restart) - (let ((name (restart-name restart))) - #'(lambda (stream) - (if name (format stream "~S" name) - (format stream "~S" restart))))) - stream)) - -(defmacro restart-bind (bindings &body forms) - "Executes forms in a dynamic context where the given restart bindings are - in effect. Users probably want to use RESTART-CASE. When clauses contain - the same restart name, FIND-RESTART will find the first such clause." - `(let ((*restart-clusters* - (cons (list - ,@(mapcar #'(lambda (binding) - (unless (or (car binding) - (member :report-function - binding :test #'eq)) - (warn "Unnamed restart does not have a ~ - report function -- ~S" - binding)) - `(make-restart - :name ',(car binding) - :function ,(cadr binding) - ,@(cddr binding))) - bindings)) - *restart-clusters*))) - ,@forms)) - -(defun find-restart (name) - "Returns the first restart named name. If name is a restart, it is returned - if it is currently active. If no such restart is found, nil is returned. - It is an error to supply nil as a name." - (dolist (restart-cluster *restart-clusters*) - (dolist (restart restart-cluster) - (when (or (eq restart name) (eq (restart-name restart) name)) - (return-from find-restart restart))))) - - -(defun invoke-restart (restart &rest values) - "Calls the function associated with the given restart, passing any given - arguments. If the argument restart is not a restart or a currently active - non-nil restart name, then a control-error is signalled." - (let ((real-restart (find-restart restart))) - (unless real-restart - (error 'control-error - :format-string "Restart ~S is not active." - :format-arguments (list restart))) - (apply (restart-function real-restart) values))) - -(defun invoke-restart-interactively (restart) - "Calls the function associated with the given restart, prompting for any - necessary arguments. If the argument restart is not a restart or a - currently active non-nil restart name, then a control-error is signalled." - (let ((real-restart (find-restart restart))) - (unless real-restart - (error 'control-error - :format-string "Restart ~S is not active." - :format-arguments (list restart))) - (apply (restart-function real-restart) - (let ((interactive-function - (restart-interactive-function real-restart))) - (if interactive-function - (funcall interactive-function) - '()))))) - - -(defmacro restart-case (expression &body clauses) - "(RESTART-CASE form - {(case-name arg-list {keyword value}* body)}*) - The form is evaluated in a dynamic context where the clauses have special - meanings as points to which control may be transferred (see INVOKE-RESTART). - When clauses contain the same case-name, FIND-RESTART will find the first - such clause." - (flet ((transform-keywords (&key report interactive) - (let ((result '())) - (when report - (setq result (list* (if (stringp report) - `#'(lambda (stream) - (write-string ,report stream)) - `#',report) - :report-function - result))) - (when interactive - (setq result (list* `#',interactive - :interactive-function - result))) - (nreverse result)))) - (let ((temp-var (gensym)) - (outer-tag (gensym)) - (inner-tag (gensym)) - (tag-var (gensym)) - (data - (mapcar #'(lambda (clause) - (with-keyword-pairs ((report interactive &rest forms) - (cddr clause)) - (list (car clause) ;name=0 - (gensym) ;tag=1 - (transform-keywords :report report ;keywords=2 - :interactive interactive) - (cadr clause) ;bvl=3 - forms))) ;body=4 - clauses))) - `(let ((,outer-tag (cons nil nil)) - (,inner-tag (cons nil nil)) - ,temp-var ,tag-var) - (catch ,outer-tag - (catch ,inner-tag - (throw ,outer-tag - (restart-bind - ,(mapcar #'(lambda (datum) - (let ((name (nth 0 datum)) - (tag (nth 1 datum)) - (keys (nth 2 datum))) - `(,name #'(lambda (&rest temp) - (setf ,temp-var temp) - (setf ,tag-var ',tag) - (throw ,inner-tag nil)) - ,@keys))) - data) - ,expression))) - (case ,tag-var - ,@(mapcar #'(lambda (datum) - (let ((tag (nth 1 datum)) - (bvl (nth 3 datum)) - (body (nth 4 datum))) - `(,tag - (apply #'(lambda ,bvl ,@body) ,temp-var)))) - data))))))) -#| -This macro doesn't work in our system due to lossage in closing over tags. -The previous version is uglier, but it sets up unique run-time tags. - -(defmacro restart-case (expression &body clauses) - "(RESTART-CASE form - {(case-name arg-list {keyword value}* body)}*) - The form is evaluated in a dynamic context where the clauses have special - meanings as points to which control may be transferred (see INVOKE-RESTART). - When clauses contain the same case-name, FIND-RESTART will find the first - such clause." - (flet ((transform-keywords (&key report interactive) - (let ((result '())) - (when report - (setq result (list* (if (stringp report) - `#'(lambda (stream) - (write-string ,report stream)) - `#',report) - :report-function - result))) - (when interactive - (setq result (list* `#',interactive - :interactive-function - result))) - (nreverse result)))) - (let ((block-tag (gensym)) - (temp-var (gensym)) - (data - (mapcar #'(lambda (clause) - (with-keyword-pairs ((report interactive &rest forms) - (cddr clause)) - (list (car clause) ;name=0 - (gensym) ;tag=1 - (transform-keywords :report report ;keywords=2 - :interactive interactive) - (cadr clause) ;bvl=3 - forms))) ;body=4 - clauses))) - `(block ,block-tag - (let ((,temp-var nil)) - (tagbody - (restart-bind - ,(mapcar #'(lambda (datum) - (let ((name (nth 0 datum)) - (tag (nth 1 datum)) - (keys (nth 2 datum))) - `(,name #'(lambda (&rest temp) - (setq ,temp-var temp) - (go ,tag)) - ,@keys))) - data) - (return-from ,block-tag ,expression)) - ,@(mapcan #'(lambda (datum) - (let ((tag (nth 1 datum)) - (bvl (nth 3 datum)) - (body (nth 4 datum))) - (list tag - `(return-from ,block-tag - (apply #'(lambda ,bvl ,@body) - ,temp-var))))) - data))))))) -|# - -(defmacro with-simple-restart ((restart-name format-string - &rest format-arguments) - &body forms) - "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) - body) - If restart-name is not invoked, then all values returned by forms are - returned. If control is transferred to this restart, it immediately - returns the values nil and t." - `(restart-case (progn ,@forms) - (,restart-name () - :report (lambda (stream) - (format stream ,format-string ,@format-arguments)) - (values nil t)))) - - - -;;;; Conditions. - -(defun condition-print (condition stream depth) - (declare (ignore depth)) - (if *print-escape* - (format stream "#<~S.~X>" - (type-of condition) - (system:%primitive lisp::make-fixnum condition)) - (condition-report condition stream))) - - -(eval-when (eval compile load) - -(defmacro parent-type (condition-type) `(get ,condition-type 'parent-type)) -(defmacro slots (condition-type) `(get ,condition-type 'slots)) -(defmacro conc-name (condition-type) `(get ,condition-type 'conc-name)) -(defmacro report-function (condition-type) - `(get ,condition-type 'report-function)) -(defmacro make-function (condition-type) `(get ,condition-type 'make-function)) - -) ;eval-when - -(defun condition-report (condition stream) - (do ((type (type-of condition) (parent-type type))) - ((not type) - (format stream "The condition ~A occurred." (type-of condition))) - (let ((reporter (report-function type))) - (when reporter - (funcall reporter condition stream) - (return nil))))) - -(setf (make-function 'condition) '|constructor for condition|) - -(defun make-condition (type &rest slot-initializations) - "Makes a condition of type type using slot-initializations as initial values - for the slots." - (let ((fn (make-function type))) - (cond ((not fn) (error 'simple-type-error - :datum type - :expected-type '(satisfies make-function) - :format-string "Not a condition type: ~S" - :format-arguments (list type))) - (t (apply fn slot-initializations))))) - - -;;; Some utilities used at macro expansion time. -;;; -(eval-when (eval compile load) - -(defmacro resolve-function (function expression resolver) - `(cond ((and ,function ,expression) - (cerror "Use only the :~A information." - "Only one of :~A and :~A is allowed." - ',function ',expression)) - (,expression (setq ,function ,resolver)))) - -(defun parse-new-and-used-slots (slots parent-type) - (let ((new '()) (used '())) - (dolist (slot slots) - (if (slot-used-p (car slot) parent-type) - (push slot used) - (push slot new))) - (values new used))) - -(defun slot-used-p (slot-name type) - (cond ((eq type 'condition) nil) - ((not type) (error "The type ~S does not inherit from condition." type)) - ((assoc slot-name (slots type))) - (t (slot-used-p slot-name (parent-type type))))) - -) ;eval-when - -(defmacro define-condition (name (parent-type) &optional slot-specs - &rest options) - "(DEFINE-CONDITION name (parent-type) - ( {slot-name | (slot-name) | (slot-name default-value)}*) - options)" - (let ((constructor (let ((*package* (find-package "CONDITIONS"))) - ;; Bind for the INTERN and the FORMAT. - (intern (format nil "Constructor for ~S" name))))) - (let ((slots (mapcar #'(lambda (slot-spec) - (if (atom slot-spec) (list slot-spec) slot-spec)) - slot-specs))) - (multiple-value-bind (new-slots used-slots) - (parse-new-and-used-slots slots parent-type) - (let ((conc-name-p nil) - (conc-name nil) - (report-function nil) - (documentation nil)) - (do ((o options (cdr o))) - ((null o)) - (let ((option (car o))) - (case (car option) ;should be ecase - (:conc-name - (setq conc-name-p t) - (setq conc-name (cadr option))) - (:report - (setq report-function - (if (stringp (cadr option)) - `(lambda (stream) - (write-string ,(cadr option) stream)) - (cadr option)))) - (:documentation (setq documentation (cadr option))) - (otherwise - (cerror "Ignore this DEFINE-CONDITION option." - "Invalid DEFINE-CONDITION option: ~S" option))))) - (unless conc-name-p - (setq conc-name - (intern (concatenate 'simple-string (symbol-name name) - "-") - *package*))) - ;; The following three forms are compile-time side-effects. For now, - ;; they affect the global environment, but with modified abstractions - ;; for parent-type, slots, and conc-name, the compiler could easily - ;; make them local. - (setf (parent-type name) parent-type) - (setf (slots name) slots) - (setf (conc-name name) conc-name) - ;; finally, the expansion ... - `(progn - (defstruct (,name - (:constructor ,constructor) - (:predicate nil) - (:copier nil) - (:print-function condition-print) - (:include ,parent-type ,@used-slots) - (:conc-name ,conc-name)) - ,@new-slots) - (setf (documentation ',name 'type) ',documentation) - (setf (parent-type ',name) ',parent-type) - (setf (slots ',name) ',slots) - (setf (conc-name ',name) ',conc-name) - (setf (report-function ',name) - ,(if report-function `#',report-function)) - (setf (make-function ',name) ',constructor) - ',name)))))) - - - -;;;; HANDLER-BIND and SIGNAL. - -(defvar *handler-clusters* nil) - -(defmacro handler-bind (bindings &body forms) - "(HANDLER-BIND ( {(type handler)}* ) body) - Executes body in a dynamic context where the given handler bindings are - in effect. Each handler must take the condition being signalled as an - argument. The bindings are searched first to last in the event of a - signalled condition." - (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings) - (error "Ill-formed handler bindings.")) - `(let ((*handler-clusters* - (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) - bindings)) - *handler-clusters*))) - ,@forms)) - -(defvar *break-on-signals* nil - "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will - enter the debugger prior to signalling that condition.") - -(defun signal (datum &rest arguments) - "Invokes the signal facility on a condition formed from datum and arguments. - If the condition is not handled, nil is returned. If - (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before - any signalling is done." - (let ((condition (coerce-to-condition datum arguments - 'simple-condition 'signal)) - (*handler-clusters* *handler-clusters*)) - (when (typep condition *break-on-signals*) - (break "~A~%Break entered because of *break-on-signals*." - condition)) - (loop - (unless *handler-clusters* (return)) - (let ((cluster (pop *handler-clusters*))) - (dolist (handler cluster) - (when (typep condition (car handler)) - (funcall (cdr handler) condition))))) - nil)) - -;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and -;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single -;;; argument that's directly usable by all the other routines. -;;; -(defun coerce-to-condition (datum arguments default-type function-name) - (cond ((typep datum 'condition) - (if arguments - (cerror "Ignore the additional arguments." - 'simple-type-error - :datum arguments - :expected-type 'null - :format-string "You may not supply additional arguments ~ - when giving ~S to ~S." - :format-arguments (list datum function-name))) - datum) - ((symbolp datum) ;Roughly, (subtypep datum 'condition). - (apply #'make-condition datum arguments)) - ((stringp datum) - (make-condition default-type - :format-string datum - :format-arguments arguments)) - (t - (error 'simple-type-error - :datum datum - :expected-type '(or symbol string) - :format-string "Bad argument to ~S: ~S" - :format-arguments (list function-name datum))))) - - - -;;;; INFINITE-ERROR-PROTECT. - -(defvar *error-system-initialized*) -(defvar *max-error-depth* 10 "The maximum number of nested errors allowed.") -(defvar *current-error-depth* 0 "The current number of nested errors.") - -;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of -;;; hyperspace. -;;; -(defmacro infinite-error-protect (form) - `(if (and (boundp '*error-system-initialized*) (numberp *current-error-depth*)) - (let ((*current-error-depth* (1+ *current-error-depth*))) - (if (> *current-error-depth* *max-error-depth*) - (error-error "Help! " *current-error-depth* " nested errors.") - ,form)) - (system:%primitive lisp::halt))) - -;;; These are used in ERROR-ERROR. -;;; -(defvar %error-error-depth% 0) -(defvar *error-throw-up-count* 0) - -(proclaim '(special lisp::*real-terminal-io*)) - -;;; ERROR-ERROR can be called when the error system is in trouble and needs -;;; to punt fast. Prints a message without using format. If we get into -;;; this recursively, then halt. -;;; -(defun error-error (&rest messages) - (let ((%error-error-depth% (1+ %error-error-depth%))) - (when (> *error-throw-up-count* 50) - (system:%primitive lisp::halt) - (throw 'lisp::top-level-catcher nil)) - (case %error-error-depth% - (1) - (2 - (setq *terminal-io* lisp::*real-terminal-io*)) - (3 - (incf *error-throw-up-count*) - (throw 'lisp::top-level-catcher nil)) - (t - (system:%primitive lisp::halt) - (throw 'lisp::top-level-catcher nil))) - - (dolist (item messages) (princ item *terminal-io*)) - (debug:internal-debug))) - - - -;;;; Fetching errorful function name. - -;;; Used to prevent infinite recursive lossage when we can't find the caller -;;; for some reason. -;;; -(defvar *finding-caller* nil) - -#+new-compiler -;;; FIND-CALLER-NAME -- Internal -;;; -(defun find-caller-name () - (if *finding-caller* - "<error finding name>" - (handler-case - (let ((*finding-caller* t)) - (di:debug-function-name - (di:frame-debug-function - (di:frame-down (di:frame-down (di:top-frame)))))) - (error () "<error finding name>") - (di:debug-condition () "<error finding name>")))) - - -;;;; ERROR, CERROR, BREAK, WARN. - -(define-condition serious-condition (condition) ()) - -(define-condition error (serious-condition) - ((function-name nil))) - -#+new-compiler -(defun error (datum &rest arguments) - "Invokes the signal facility on a condition formed from datum and arguments. - If the condition is not handled, the debugger is invoked." - (infinite-error-protect - (let ((condition (coerce-to-condition datum arguments 'simple-error 'error))) - (unless (error-function-name condition) - (setf (error-function-name condition) (find-caller-name))) - (signal condition) - (invoke-debugger condition)))) - -#+new-compiler -;;; CERROR must take care to no use arguments when datum is already a condition -;;; object. Furthermore, we must set ERROR-FUNCTION-NAME here instead of -;;; letting ERROR do it, so we get the correct function name. -;;; -(defun cerror (continue-string datum &rest arguments) - (with-simple-restart - (continue "~A" (apply #'format nil continue-string arguments)) - (let ((condition (if (typep datum 'condition) - datum - (coerce-to-condition datum arguments - 'simple-error 'error)))) - (unless (error-function-name condition) - (setf (error-function-name condition) (find-caller-name))) - (error condition))) - nil) - -#+new-compiler -(defun break (&optional (format-string "Break") &rest format-arguments) - "Prints a message and invokes the debugger without allowing any possibility - of condition handling occurring." - (with-simple-restart (continue "Return from BREAK.") - (invoke-debugger - (make-condition 'simple-condition - :format-string format-string - :format-arguments format-arguments))) - nil) - -(define-condition warning (condition) ()) - -(defvar *break-on-warnings* () - "If non-NIL, then WARN will enter a break loop before returning.") - -#+new-compiler -(defun warn (datum &rest arguments) - "Warns about a situation by signalling a condition formed by datum and - arguments. Before signalling, if *break-on-warnings* is set, then BREAK - is called. While the condition is being signaled, a muffle-warning restart - exists that causes WARN to immediately return nil." - (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn))) - (check-type condition warning "a warning condition") - (if *break-on-warnings* - (break "~A~%Break entered because of *break-on-warnings*." - condition)) - (restart-case (signal condition) - (muffle-warning () - :report "Skip warning." - (return-from warn nil))) - (format *error-output* "~&Warning:~%~A~%" condition) - nil)) - - - -;;;; Condition definitions. - -;;; Serious-condition and error are defined on the previous page, so ERROR and -;;; CERROR can SETF a slot in the error condition object. -;;; - - -(defun simple-condition-printer (condition stream) - (apply #'format stream (simple-condition-format-string condition) - (simple-condition-format-arguments condition))) - -;;; The simple-condition type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING -;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the -;;; simple-condition, simple-warning, simple-type-error, and simple-error types. -;;; This seems to create some kind of bogus multiple inheritance that the user -;;; sees. -;;; -(define-condition simple-condition (condition) - (format-string - (format-arguments '())) - (:conc-name internal-simple-condition-) - (:report simple-condition-printer)) - -;;; The simple-warning type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING -;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the -;;; simple-condition, simple-warning, simple-type-error, and simple-error types. -;;; This seems to create some kind of bogus multiple inheritance that the user -;;; sees. -;;; -(define-condition simple-warning (warning) - (format-string - (format-arguments '())) - (:conc-name internal-simple-warning-) - (:report simple-condition-printer)) - - -(defun print-simple-error (condition stream) - (format stream "~&Error in function ~S.~%~?" - (internal-simple-error-function-name condition) - (internal-simple-error-format-string condition) - (internal-simple-error-format-arguments condition))) - -;;; The simple-error type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING -;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the -;;; simple-condition, simple-warning, simple-type-error, and simple-error types. -;;; This seems to create some kind of bogus multiple inheritance that the user -;;; sees. -;;; -(define-condition simple-error (error) - (format-string - (format-arguments '())) - (:conc-name internal-simple-error-) - (:report print-simple-error)) - - -(define-condition storage-condition (serious-condition) ()) - -(define-condition stack-overflow (storage-condition) ()) -(define-condition storage-exhausted (storage-condition) ()) - -(define-condition type-error (error) - (datum - expected-type)) - -;;; The simple-type-error type has a conc-name, so -;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS could -;;; be written to handle the simple-condition, simple-warning, -;;; simple-type-error, and simple-error types. This seems to create some kind -;;; of bogus multiple inheritance that the user sees. -;;; -(define-condition simple-type-error (type-error) - (format-string - (format-arguments '())) - (:conc-name internal-simple-type-error-) - (:report simple-condition-printer)) - -(define-condition case-failure (type-error) - (name - possibilities) - (:report - (lambda (condition stream) - (format stream "~S fell through ~S expression.~%Wanted one of ~:S." - (type-error-datum condition) - (case-failure-name condition) - (case-failure-possibilities condition))))) - - -;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS. -;;; These exist for the obvious types to seemingly give the impression of -;;; multiple inheritance. That is, the last three types inherit from warning, -;;; type-error, and error while inheriting from simple-condition also. -;;; -(defun simple-condition-format-string (condition) - (etypecase condition - (simple-condition (internal-simple-condition-format-string condition)) - (simple-warning (internal-simple-warning-format-string condition)) - (simple-type-error (internal-simple-type-error-format-string condition)) - (simple-error (internal-simple-error-format-string condition)))) -;;; -(defun simple-condition-format-arguments (condition) - (etypecase condition - (simple-condition (internal-simple-condition-format-arguments condition)) - (simple-warning (internal-simple-warning-format-arguments condition)) - (simple-type-error (internal-simple-type-error-format-arguments condition)) - (simple-error (internal-simple-error-format-arguments condition)))) - - -(define-condition program-error (error) ()) - - -(defun print-control-error (condition stream) - (format stream "~&Error in function ~S.~%~?" - (control-error-function-name condition) - (control-error-format-string condition) - (control-error-format-arguments condition))) - -(define-condition control-error (error) - (format-string - (format-arguments nil)) - (:report print-control-error)) - - -(define-condition stream-error (error) (stream)) - -(define-condition end-of-file (stream-error) ()) - -(define-condition file-error (error) (pathname)) - -(define-condition package-error (error) (pathname)) - -(define-condition cell-error (error) (name)) - -(define-condition unbound-variable (cell-error) () - (:report (lambda (condition stream) - (format stream "The variable ~S is unbound." - (cell-error-name condition))))) - -(define-condition undefined-function (cell-error) () - (:report (lambda (condition stream) - (format stream "The function ~S is undefined." - (cell-error-name condition))))) - -(define-condition arithmetic-error (error) (operation operands)) - -(define-condition division-by-zero (arithmetic-error) ()) -(define-condition floating-point-overflow (arithmetic-error) ()) -(define-condition floating-point-underflow (arithmetic-error) ()) - - - -;;;; HANDLER-CASE and IGNORE-ERRORS. - -(defmacro handler-case (form &rest cases) - "(HANDLER-CASE form - { (type ([var]) body) }* ) - Executes form in a context with handlers established for the condition - types. A peculiar property allows type to be :no-error. If such a clause - occurs, and form returns normally, all its values are passed to this clause - as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one - var specification." - (let ((no-error-clause (assoc ':no-error cases))) - (if no-error-clause - (let ((normal-return (make-symbol "normal-return")) - (error-return (make-symbol "error-return"))) - `(block ,error-return - (multiple-value-call #'(lambda ,@(cdr no-error-clause)) - (block ,normal-return - (return-from ,error-return - (handler-case (return-from ,normal-return ,form) - ,@(remove no-error-clause cases))))))) - (let ((var (gensym)) - (outer-tag (gensym)) - (inner-tag (gensym)) - (tag-var (gensym)) - (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case)) - cases))) - `(let ((,outer-tag (cons nil nil)) - (,inner-tag (cons nil nil)) - ,var ,tag-var) - ,var ;ignoreable - (catch ,outer-tag - (catch ,inner-tag - (throw ,outer-tag - (handler-bind - ,(mapcar #'(lambda (annotated-case) - `(,(cadr annotated-case) - #'(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (setf ,tag-var - ',(car annotated-case)) - (throw ,inner-tag nil)))) - annotated-cases) - ,form))) - (case ,tag-var - ,@(mapcar #'(lambda (annotated-case) - (let ((body (cdddr annotated-case)) - (varp (caddr annotated-case))) - `(,(car annotated-case) - ,@(if varp - `((let ((,(car varp) ,var)) - ,@body)) - body)))) - annotated-cases)))))))) -#| -This macro doesn't work in our system due to lossage in closing over tags. -The previous version sets up unique run-time tags. - -(defmacro handler-case (form &rest cases) - "(HANDLER-CASE form - { (type ([var]) body) }* ) - Executes form in a context with handlers established for the condition - types. A peculiar property allows type to be :no-error. If such a clause - occurs, and form returns normally, all its values are passed to this clause - as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one - var specification." - (let ((no-error-clause (assoc ':no-error cases))) - (if no-error-clause - (let ((normal-return (make-symbol "normal-return")) - (error-return (make-symbol "error-return"))) - `(block ,error-return - (multiple-value-call #'(lambda ,@(cdr no-error-clause)) - (block ,normal-return - (return-from ,error-return - (handler-case (return-from ,normal-return ,form) - ,@(remove no-error-clause cases))))))) - (let ((tag (gensym)) - (var (gensym)) - (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case)) - cases))) - `(block ,tag - (let ((,var nil)) - ,var ;ignorable - (tagbody - (handler-bind - ,(mapcar #'(lambda (annotated-case) - (list (cadr annotated-case) - `#'(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (go ,(car annotated-case))))) - annotated-cases) - (return-from ,tag ,form)) - ,@(mapcan - #'(lambda (annotated-case) - (list (car annotated-case) - (let ((body (cdddr annotated-case))) - `(return-from - ,tag - ,(cond ((caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body)) - ((not (cdr body)) - (car body)) - (t - `(progn ,@body))))))) - annotated-cases)))))))) -|# - -(defmacro ignore-errors (&rest forms) - "Executes forms after establishing a handler for all error conditions that - returns from this form nil and the condition signalled." - `(handler-case (progn ,@forms) - (error (condition) (values nil condition)))) - - - -;;;; Restart definitions. - -(define-condition abort-failure (control-error) () - (:report - "Found an \"abort\" restart that failed to transfer control dynamically.")) - -;;; ABORT signals an error in case there was a restart named abort that did -;;; not tranfer control dynamically. This could happen with RESTART-BIND. -;;; -(defun abort () - "Transfers control to a restart named abort, signalling a control-error if - none exists." - (invoke-restart 'abort) - (error 'abort-failure)) - - -(defun muffle-warning () - "Transfers control to a restart named muffle-warning, signalling a - control-error if none exists." - (invoke-restart 'muffle-warning)) - - -;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep -;;; INVOKE-RESTART from signalling a control-error condition. -;;; -(defmacro define-nil-returning-restart (name args doc) - `(defun ,name ,args - ,doc - (if (find-restart ',name) (invoke-restart ',name ,@args)))) - -(define-nil-returning-restart continue () - "Transfer control to a restart named continue, returning nil if none exists.") - -(define-nil-returning-restart store-value (value) - "Transfer control and value to a restart named store-value, returning nil if - none exists.") - -(define-nil-returning-restart use-value (value) - "Transfer control and value to a restart named use-value, returning nil if - none exists.") - - - - -;;;; Internal Error Codes. - -;;; *Internal-error-table* contains a vector, by error code, of functions. -;;; This is used in %SP-INTERNAL-ERROR, and initialized MAKE-ERROR-TABLE. -;;; -(defvar *internal-error-table*) - -#+new-compiler -;;; %SP-INTERNAL-ERROR is called by the microcode when an internal error -;;; occurrs. It is simply a dispatch routine which looks up a specialized -;;; function to call in the special variable, *internal-error-table*. -;;; -;;; ERR-CODE -- a fixnum which identifies the specific error. -;;; PC -- the relative offset of the NEXT macro instruction to be -;;; executed in the code vector of the errorful function. -;;; ARG3 & ARG4 -- arbitrary meaning determined by ERR-CODE. -;;; -(defun lisp::%sp-internal-error (err-code arg3 arg4) - (infinite-error-protect - (funcall (svref *internal-error-table* err-code) - (find-caller-name) - 0 - arg3 - arg4))) - -;;; DEF-INTERNAL-ERROR defines a form which can be put into the system init -;;; file (spinit, or vaxinit) to define the errors which the microcode may -;;; signal. The form looks like -;;; -;;; (def-internal-error err-code condition flag control-string &rest args) -;;; ERR-CODE -- the internal code for this error. less than or equal to -;;; max-internal-error which is declared in the init file. -;;; CONDITION -- the name of the error to signal -;;; FLAG -- one of CORRECTABLE, FATAL or SYSTEM-ERROR. (not evaluated) -;;; if CORRECTABLE, %sp-internal-error may return correction values -;;; if SYSTEM-ERROR, the CONDITION arg is ignored. -;;; CONTROL-STRING -- the error message as a format control string. -;;; ARGS -- The args to the control string. The 3rd & 4th args to -;;; %sp-internal-error are available as the variables ARG3 & ARG4. -;;; -;;; NOTE: system-error is never supplied, and condition is never used. Maybe -;;; it will be when we signal appropriate conditions for certain -;;; situations. -;;; - -;example -; (def-internal-error 6 :unbound-symbol correctable -; "Unbound symbol: ~s." arg3) - - -(defmacro def-internal-error (number condition flag control-string &rest args) - (declare (ignore condition)) - `(setf (svref *internal-error-table* ,number) - #'(lambda (callers-name PC arg3 arg4) - (declare (ignore ,@(unless (eq flag 'system-error) '(PC)) - ,@(unless (member 'arg3 args) '(arg3)) - ,@(unless (member 'arg4 args) '(arg4)))) - ,(case flag - ((fatal) `(error 'simple-error - :function-name callers-name - :format-string ,control-string - :format-arguments (list ,@args))) - ((correctable) `(cerror 'simple-error - :function-name callers-name - :format-string ,control-string - :format-arguments (list ,@args))))))) - - -(defconstant max-internal-error 100 - "The largest internal error number for Spice Lisp.") - -(proclaim '(special allocation-space)) - - -(defun make-error-table () - (setq *internal-error-table* - (make-array (1+ max-internal-error) - :initial-element - #'(lambda (&rest ignore) - (declare (ignore ignore)) - (break "Undefined Error.")))) - - (def-internal-error 1 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'List) - (def-internal-error 2 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'Symbol) - (def-internal-error 3 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'Number) - (def-internal-error 4 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'Integer) - (def-internal-error 5 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'Ratio) - (def-internal-error 6 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'Complex) - (def-internal-error 7 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'Vector-like) - (def-internal-error 8 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector) - (def-internal-error 9 :invalid-function fatal - "Invalid function: ~s." arg3) - (def-internal-error 10 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been a function or an array." arg3) - (def-internal-error 11 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'U-vector-like) - (def-internal-error 12 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." - arg3 'simple-bit-vector) - (def-internal-error 13 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 - 'simple-string) - (def-internal-error 14 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'character) - (def-internal-error 15 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." - arg3 'Control-Stack-Pointer) - (def-internal-error 16 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." - arg3 'Binding-Stack-Pointer) - (def-internal-error 17 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'Array) - (def-internal-error 18 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." - arg3 'Positive-Fixnum) - (def-internal-error 19 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'SAP-pointer) - (def-internal-error 20 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of tyep ~s." arg3 'system-pointer) - (def-internal-error 21 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'float) - (def-internal-error 22 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'rational) - (def-internal-error 23 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been a non-complex number." arg3) - - (def-internal-error 25 :unbound-variable fatal - "Unbound variable: ~s." arg3) - (def-internal-error 26 :undefined-function fatal - "Undefined function: ~s." arg3) - (def-internal-error 27 :error fatal - "Attempt to alter NIL.") - (def-internal-error 28 :error fatal - "Attempt to alter NIL.") - (def-internal-error 29 :error fatal - "Circularity detected in chain of symbols from definition cell of symbol ~S." - arg3) - - ;;Special because handlers won't work while allocation-space is wrong. - (setf (svref *internal-error-table* 24) - #'(lambda (callers-name ignore0 ignore1 ignore2) - (declare (ignore ignore0 ignore1 ignore2)) - (let ((bazfaz allocation-space)) - (setq allocation-space 0) - (error 'simple-error - :function-name callers-name - :format-string "Illegal allocation-space value: ~S." - :format-arguments (list bazfaz))))) - - (def-internal-error 30 :error fatal - "Illegal u-vector access type: ~s." arg3) - (def-internal-error 31 :error fatal - "Illegal vector length: ~s." arg3) - (def-internal-error 32 :error fatal - "Vector index, ~s, out of bounds." arg3) - (def-internal-error 33 :error fatal - "Illegal index: ~s." arg3) - (def-internal-error 34 :error fatal - "Illegal shrink value: ~s." arg3) - (def-internal-error 35 :error fatal - "Shrink value, ~s, is greater than current length of ~s." arg3 arg4) - (def-internal-error 36 :error fatal - "Illegal data vector, ~S, in an array." arg3) - (def-internal-error 37 :error fatal - "Too few arguments passed to two or three dimension array access miscop.") - (def-internal-error 38 :error fatal - "Too many arguments passed to two or three dimension array access miscop.") - (def-internal-error 39 :error fatal - "Illegal to allocate vector of size: ~s." arg3) - - (def-internal-error 40 :error fatal - "Illegal byte pointer: (byte ~s ~s)." arg3 arg4) - (def-internal-error 41 :error fatal - "Illegal position, ~s, in byte spec." arg3) - (def-internal-error 42 :error fatal - "Illegal size, ~s, in byte spec." arg3) - (def-internal-error 43 :error fatal - "Illegal shift count: ~s." arg3) - (def-internal-error 44 :error fatal - "Illegal boole operation: ~s." arg3) - - (def-internal-error 50 :error fatal "Wrong number of arguments: ~D." arg3) - - (def-internal-error 55 :error fatal - "~s is not <= to ~s (Alien index out of bounds.)" arg3 arg4) - - (def-internal-error 60 :error fatal - "Attempt to divide ~s by ~s." arg3 arg4) - (def-internal-error 61 :unseen-throw-tag fatal - "No catcher for throw tag ~s." arg3) - (def-internal-error 62 :error fatal - "Something using ~S and ~S lead to a short-float underflow." arg3 arg4) - (def-internal-error 63 :error fatal - "Something using ~S and ~S lead to a short-float overflow." arg3 arg4) -#| - (def-internal-error 64 :error fatal - "Something using ~S and ~S lead to a single-float underflow." arg3 arg4) - (def-internal-error 65 :error fatal - "Something using ~S and ~S lead to a single-float overflow." arg3 arg4) -|# - (def-internal-error 66 :error fatal - "Something using ~S and ~S lead to a long-float underflow." arg3 arg4) - (def-internal-error 67 :error fatal - "Something using ~S and ~S lead to a long-float overflow." arg3 arg4) - (def-internal-error 68 :error fatal - "Something using ~S caused a short-float underflow." arg3) - (def-internal-error 69 :error fatal - "Something using ~S caused a short-float overflow." arg3) - (def-internal-error 70 :error fatal - "Something using ~S caused a long-float underflow." arg3) - (def-internal-error 71 :error fatal - "Something using ~S caused a long-float overflow." arg3) - (def-internal-error 72 :error fatal - "~S is not a legal argument to log, it should be non-zero." arg3) - (def-internal-error 73 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'string-char) - (def-internal-error 74 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'short-float) - (def-internal-error 75 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'long-float) - (def-internal-error 76 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'fixnum) - (def-internal-error 77 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 'cons) - (def-internal-error 78 :error fatal - "Invalid exit.") - (def-internal-error 79 :error fatal - "Odd number of arguments in keyword part of argument list.") - (def-internal-error 80 :error fatal - "~S is not a known keyword argument specifier." arg3) - (def-internal-error 81 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 arg4) - (def-internal-error 82 :wrong-type-argument fatal - "Wrong type argument, ~s, should have been of type ~s." arg3 - '(or function symbol)) - (def-internal-error 83 :error fatal - "~S is not = to ~S (Alien index out of bounds.)" arg3 arg4) - - ) - - - -;;; ERROR-INIT is called at init time to initialize the error system. -;;; It initializes the internal error table, and sets a variable. -;;; -(defun error-init () - (make-error-table) - (setq *error-system-initialized* t)) - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* nil)) diff --git a/code/eval.lisp b/code/eval.lisp deleted file mode 100644 index 2ef7d869173072eed0d46877405929a3ba311cab..0000000000000000000000000000000000000000 --- a/code/eval.lisp +++ /dev/null @@ -1,356 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; -(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 - 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 "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) - -;;; 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 (exp) - "Evaluates its single arg in a null lexical environment, returns the - result or results." - (let ((exp (macroexpand exp))) - (typecase exp - (symbol (symbol-value 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)) - (set (first args) (eval (second args)))) - (set (first args) (eval (second args))))) - (unless (eq (info variable kind (first name)) :special) - (return (eval:internal-eval exp)))))) - ((progn) - (when (> args 0) - (dolist (x (butlast (rest exp)) (eval (car (last exp)))) - (eval x)))) - (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 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) - (= (%primitive get-vector-subtype x) %function-closure-subtype) - (fboundp 'eval::leaf-value) - (let ((const (%primitive header-ref - (%primitive header-ref x %function-name-slot) - %function-entry-constants-slot))) - (or (eq (%primitive header-ref #'eval::leaf-value - %function-entry-constants-slot) - const) - (eq (%primitive header-ref #'eval:make-interpreted-function - %function-entry-constants-slot) - const))))) - - -;;; 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) - (case (%primitive get-vector-subtype fun) - (#.%function-closure-subtype - (function-lambda-expression - (%primitive header-ref fun %function-name-slot))) - ((#.%function-entry-subtype #.%function-closure-entry-subtype) - (let ((name (%primitive header-ref fun %function-name-slot)) - (info (%primitive header-ref - (%primitive header-ref fun - %function-entry-constants-slot) - %function-constants-debug-info-slot))) - (if info - (let ((source (first (c::compiled-debug-info-source info)))) - (cond ((eq (c::debug-source-from source) :lisp) - (values (c::debug-source-name source) - 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) - (do ((i %function-closure-variables-offset (1+ i)) - (len (%primitive header-length fun))) - ((= i len) nil) - (let ((elt (%primitive header-ref fun i))) - (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.") - - -;;; Macroexpand-1 -- Public -;;; -;;; The Env arg may actually be the compiler *fenv* alist. -;;; -(defun macroexpand-1 (form &optional env) - "If form is a 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." - (let ((fenv #|(if (listp env) env - (lexical-environment-fenv env))|# - env)) - (if (and (consp form) (symbolp (car form))) - (let ((local-def (cdr (assoc (car form) fenv)))) - (if local-def - (if (and (consp local-def) (eq (car local-def) 'MACRO)) - (values (funcall *macroexpand-hook* (cdr local-def) - form fenv) - t) - (values form nil)) - (let ((global-def (macro-function (car form)))) - (if global-def - (values (funcall *macroexpand-hook* global-def form fenv) - t) - (values form nil))))) - (values form nil)))) - - -(defun macroexpand (form &optional env) - "If Form is a macro call, then the form is expanded until the result is not - a macro. Returns as multiple values, the form after any expansion has - been done and T if expansion was done, or NIL otherwise. Env is the - lexical environment to expand in, which defaults to the null environment." - (prog (flag) - (multiple-value-setq (form flag) (macroexpand-1 form env)) - (unless flag (return (values form nil))) - loop - (multiple-value-setq (form flag) (macroexpand-1 form env)) - (if flag (go loop) (return (values form t))))) - - -(defun macro-function (symbol) - "If the symbol globally names a macro, returns the expansion function, - else returns NIL." - (declare (symbol symbol)) - (if (eq (info function kind symbol) :macro) - (info function macro-function symbol) - nil)) - - -(defun (setf macro-function) (symbol function) - (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) - (fmakunbound symbol) - function) - - -(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)))) - - -;;; Type-Expand -- Interface -;;; -;;; Similar to Macroexpand, but expands deftypes. We don't bother returning -;;; a second value. -;;; -(defun type-expand (form) - (let ((def (cond ((symbolp form) - (info type expander form)) - ((and (consp form) (symbolp (car form))) - (info type expander (car form))) - (t nil)))) - (if def - (type-expand (funcall def (if (consp form) form (list form)))) - form))) - - -;;; 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/exports.lisp b/code/exports.lisp deleted file mode 100644 index caf2622b51cf0dc690c0ba0588ab607738f371e5..0000000000000000000000000000000000000000 --- a/code/exports.lisp +++ /dev/null @@ -1,549 +0,0 @@ -;;; -*- 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/code/exports.lisp,v 1.25 1990/05/18 22:34:46 ch Exp $ -;;; -;;; All the stuff necessary to export various symbols from various packages. -;;; -;;; Written by William Lott. -;;; - - -;;; Old compiler cleanup. - -#-new-compiler -(progn - -(labels - ((nuke (name package) - (let* ((package (find-package package)) - (symbol (find-symbol name package))) - (when symbol - (unintern symbol package))))) - (nuke "REAL" "XLIB") - (nuke "FORM" "LISP") - (nuke "INDEX" "LISP") - (nuke "LEXICAL-ENVIRONMENT" "LISP") - (nuke "NEGATE" "LISP") - (nuke "TYPE-EXPAND" "LISP") - (nuke "STRUCTURE-TYPE" "XP") - (nuke "CONCAT-PNAMES" "LISP") - (nuke "ONCE-ONLY" "COMPILER") - (nuke "CONSTANT" "COMPILER") - (nuke "SAP+" "COMPILER") - (nuke "SAP+" "LISP")) - -(labels - ((lisp->system (name) - (let ((symbol (find-symbol name (find-package "LISP")))) - (when symbol - (import symbol (find-package "SYSTEM")))))) - (lisp->system "%SET-ALIEN-ACCESS") - (lisp->system "CHECK<=") - (lisp->system "CT-A-VAL") - (lisp->system "CT-A-VAL-ALIEN") - (lisp->system "CT-A-VAL-OFFSET") - (lisp->system "CT-A-VAL-P") - (lisp->system "CT-A-VAL-SAP") - (lisp->system "CT-A-VAL-SIZE") - (lisp->system "CT-A-VAL-TYPE") - (lisp->system "DEPORT-BOOLEAN") - (lisp->system "DEPORT-INTEGER") - (lisp->system "MAKE-CT-A-VAL") - (lisp->system "NATURALIZE-BOOLEAN") - (lisp->system "NATURALIZE-INTEGER") - (lisp->system "SAP-REF-SAP")) - -(let ((symbol (find-symbol "CHECK=" (find-package "COMPILER")))) - (when symbol (import symbol (find-package "SYSTEM")))) - -); #-new-compiler progn - - - -;;; Create the packages - -(in-package "LISP") -(in-package "KERNEL") -(in-package "SYSTEM" :nicknames '("SYS")) -(in-package "EXTENSIONS" :nicknames '("EXT")) -(in-package "USER") -(in-package "VM") -(in-package "C") -(in-package "ASSEMBLER" :nicknames '("ASSEM")) -(in-package "BIGNUM") - - -(in-package "LISP") - -(use-package "KERNEL") -(use-package "EXT") -(use-package "SYSTEM") -(use-package "BIGNUM") - -(export '(&allow-other-keys &aux &body &environment &key &optional &rest - &whole * ** *** *applyhook* *break-on-signals* - *break-on-warnings* *debug-io* *debugger-hook* - *default-pathname-defaults* *error-output* *evalhook* *features* - *gensym-counter* *load-verbose* *macroexpand-hook* *modules* - *package* *print-array* *print-base* *print-case* *print-circle* - *print-escape* *print-gensym* *print-length* *print-level* - *print-pretty* *print-radix* *query-io* *random-state* - *read-base* *read-default-float-format* *read-suppress* - *readtable* *standard-input* *standard-output* *terminal-io* - *trace-output* + ++ +++ - / // /// /= 1+ 1- < <= = > >= abort abs - acons acos acosh adjoin adjust-array adjustable-array-p - alpha-char-p alphanumericp and append apply applyhook apropos - apropos-list aref arithmetic-error arithmetic-error-operands - arithmetic-error-operation array array-dimension - array-dimension-limit array-dimensions array-element-type - array-has-fill-pointer-p array-in-bounds-p array-rank - array-rank-limit array-row-major-index array-total-size - array-total-size-limit arrayp ash asin asinh assert assoc - assoc-if assoc-if-not atan atanh atom base-character base-string - bignum bit bit-and bit-andc1 bit-andc2 bit-eqv bit-ior bit-nand - bit-nor bit-not bit-orc1 bit-orc2 bit-vector bit-vector-p bit-xor - block boole boole-1 boole-2 boole-and boole-andc1 boole-andc2 - boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand - boole-nor boole-orc1 boole-orc2 boole-set boole-xor both-case-p - boundp break butlast byte byte-position byte-size caaaar caaadr - caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr - caddr cadr call-arguments-limit car case catch ccase cdaaar - cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar - cddddr cdddr cddr cdr ceiling cell-error cerror char char-bit - char-bits char-bits-limit char-code char-code-limit - char-control-bit char-downcase char-equal char-font - char-font-limit char-greaterp char-hyper-bit char-int char-lessp - char-meta-bit char-name char-not-equal char-not-greaterp - char-not-lessp char-super-bit char-upcase char/= char< char<= - char= char> char>= character characterp check-type cis - clear-input clear-output close clrhash code-char coerce common - commonp compilation-speed compile compile-file compiled-function - compiled-function-p compiler-let complex complexp - compute-restarts concatenate cond condition conjugate cons consp - constantp continue control-error copy-alist copy-list - copy-readtable copy-seq copy-symbol copy-tree cos cosh count - count-if count-if-not ctypecase debug-info decf declaration - declare decode-float decode-universal-time defconstant - define-condition define-modify-macro define-setf-method defmacro - defparameter defsetf defstruct deftype defun defvar delete - delete-duplicates delete-file delete-if delete-if-not denominator - deposit-field describe digit-char digit-char-p directory - directory-namestring disassemble division-by-zero do do* - do-all-symbols do-external-symbols do-symbols documentation - dolist dotimes double-float double-float-epsilon - double-float-negative-epsilon dpb dribble ecase ed eighth elt - encode-universal-time end-of-file endp enough-namestring eq eql - equal equalp error etypecase eval eval-when evalhook evenp every - exp export expt extended-character fboundp fceiling fdefinition - ffloor fifth file-author file-error file-error-pathname - file-length file-namestring file-position file-write-date fill - fill-pointer find find-all-symbols find-if find-if-not - find-package find-restart find-symbol finish-output first fixnum - flet float float-digits float-precision float-radix float-sign - floating-point-overflow floating-point-underflow floatp floor - fmakunbound force-output format fourth fresh-line fround - ftruncate ftype funcall function function-lambda-expression - functionp gcd gensym gentemp get get-decoded-time - get-dispatch-macro-character get-internal-real-time - get-internal-run-time get-macro-character - get-output-stream-string get-properties get-setf-method - get-setf-method-multiple-value get-universal-time getf gethash go - graphic-char-p handler-bind handler-case hash-table - hash-table-count hash-table-p host-namestring identity if ignore - ignore-errors imagpart import in-package incf inline - input-stream-p inspect int-char integer integer-decode-float - integer-length integerp intern internal-time-units-per-second - intersection invoke-debugger invoke-restart - invoke-restart-interactively isqrt keyword keywordp labels lambda - lambda-list-keywords lambda-parameters-limit last lcm ldb - ldb-test ldiff least-negative-double-float - least-negative-long-float least-negative-short-float - least-negative-single-float least-positive-double-float - least-positive-long-float least-positive-short-float - least-positive-single-float length let let* - lisp-implementation-type lisp-implementation-version list list* - list-all-packages list-length listen listp load locally log - logand logandc1 logandc2 logbitp logcount logeqv logior lognand - lognor lognot logorc1 logorc2 logtest logxor long-float - long-float-epsilon long-float-negative-epsilon long-site-name - loop lower-case-p machine-instance machine-type machine-version - macro-function macroexpand macroexpand-1 macrolet make-array - make-broadcast-stream make-char make-concatenated-stream - make-condition make-dispatch-macro-character make-echo-stream - make-hash-table make-list make-package make-pathname - make-random-state make-sequence make-string - make-string-input-stream make-string-output-stream make-symbol - make-synonym-stream make-two-way-stream makunbound map mapc - mapcan mapcar mapcon maphash mapl maplist mask-field max member - member-if member-if-not merge merge-pathnames min minusp mismatch - mod most-negative-double-float most-negative-fixnum - most-negative-long-float most-negative-short-float - most-negative-single-float most-positive-double-float - most-positive-fixnum most-positive-long-float - most-positive-short-float most-positive-single-float - muffle-warning multiple-value-bind multiple-value-call - multiple-value-list multiple-value-prog1 multiple-value-setq - multiple-values-limit name-char namestring nbutlast nconc nil - nintersection ninth not notany notevery notinline nreconc - nreverse nset-difference nset-exclusive-or nstring-capitalize - nstring-downcase nstring-upcase nsublis nsubst nsubst-if - nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not nth - nthcdr null number numberp numerator nunion oddp open optimize or - otherwise output-stream-p package package-error - package-error-package package-name package-nicknames - package-shadowing-symbols package-use-list package-used-by-list - packagep pairlis parse-integer parse-namestring pathname - pathname-device pathname-directory pathname-host pathname-name - pathname-type pathname-version pathnamep peek-char phase pi plusp - pop position position-if position-if-not pprint prin1 - prin1-to-string princ princ-to-string print probe-file proclaim - prog prog* prog1 prog2 progn program-error progv provide psetf - psetq push pushnew quote random random-state random-state-p - rassoc rassoc-if rassoc-if-not ratio rational rationalize - rationalp read read-byte read-char read-char-no-hang - read-delimited-list read-from-string read-line - read-preserving-whitespace readtable readtablep real realpart - reduce rem remf remhash remove remove-duplicates remove-if - remove-if-not remprop rename-file rename-package replace require - rest restart restart-bind restart-case restart-name return - return-from revappend reverse room rotatef round row-major-aref - rplaca rplacd safety satisfies sbit scale-float schar search - second sequence serious-condition set set-char-bit set-difference - set-dispatch-macro-character set-exclusive-or set-macro-character - set-syntax-from-char setf setq seventh shadow shadowing-import - shiftf short-float short-float-epsilon - short-float-negative-epsilon short-site-name signal signed-byte - signum simple-array simple-base-string simple-bit-vector - simple-bit-vector-p simple-condition - simple-condition-format-arguments simple-condition-format-string - simple-error simple-string simple-string-p simple-type-error - simple-vector simple-vector-p simple-warning sin single-float - single-float-epsilon single-float-negative-epsilon sinh sixth - sleep software-type software-version some sort space special - special-form-p speed sqrt stable-sort stack-overflow - standard-char standard-char-p step storage-condition - storage-exhausted store-value stream stream-element-type - stream-error stream-error-stream streamp string string-capitalize - string-char string-char-p string-downcase string-equal - string-greaterp string-left-trim string-lessp string-not-equal - string-not-greaterp string-not-lessp string-right-trim - string-trim string-upcase string/= string< string<= string= - string> string>= stringp structure sublis subseq subsetp subst - subst-if subst-if-not substitute substitute-if substitute-if-not - subtypep svref sxhash symbol symbol-function symbol-name - symbol-package symbol-plist symbol-value symbolp t tagbody tailp - tan tanh tenth terpri the third throw time trace tree-equal - truename truncate type type-error type-error-datum - type-error-expected-type type-of typecase typep unbound-variable - undefined-function unexport unintern union unless unread-char - unsigned-byte untrace unuse-package unwind-protect upper-case-p - use-package use-value user-homedir-pathname values values-list - variable vector vector-pop vector-push vector-push-extend vectorp - warn warning when with-compilation-unit with-input-from-string - with-open-file with-open-stream with-output-to-string - with-simple-restart write write-byte write-char write-line - write-string write-to-string y-or-n-p yes-or-no-p zerop)) - - -(in-package "KERNEL") - -(use-package "EXT") -(use-package "SYSTEM") -(use-package "BIGNUM") - -(export '(%array-fill-pointer %array-available-elements %array-data-vector - %array-displacement %array-displaced-p %array-dimension - %check-bound %dpb %ldb %negate *empty-type* *eval-stack-top* - *null-type* *universal-type* *wild-type* 32bit-logical-not - 32bit-logical-nor 32bit-logical-and 32bit-logical-or - 32bit-logical-xor always-subtypep args-type args-type-allowp - args-type-keyp args-type-keywords args-type-optional args-type-p - args-type-required args-type-rest array-rank array-total-size - array-type array-type-complexp array-type-dimensions - array-type-element-type array-type-p - array-type-specialized-element-type ash-index bit-bash-clear - bit-bash-set bit-bash-not bit-bash-copy bit-bash-and bit-bash-ior - bit-bash-xor bit-bash-eqv bit-bash-lognand bit-bash-lognor - bit-bash-andc1 bit-bash-andc2 bit-bash-orc1 bit-bash-orc2 - bit-index boole-code boolean byte-specifier callable char-int - consed-sequence constant-type constant-type-p constant-type-type - containing-integer-type copy-from-system-area copy-to-system-area - csubtypep ctype ctype-of ctype-p ctypep data-vector-ref - data-vector-set filename float-digits float-exponent - float-format-max float-radix form function-type - function-type-allowp function-type-keyp function-type-keywords - function-type-optional function-type-p function-type-required - function-type-rest function-type-returns function-type-wild-args - hairy-type hairy-type-check-template hairy-type-specifier index - internal-time irrational key-info key-info-name key-info-p - key-info-type lexical-environment make-args-type - make-function-type make-key-info make-member-type make-named-type - make-numeric-type make-structure-type make-union-type - make-values-type member-type member-type-members member-type-p - merge-bits named-type named-type-name named-type-p - native-byte-order negate never-subtypep numeric-contagion - numeric-type numeric-type-class numeric-type-complexp - numeric-type-format numeric-type-high numeric-type-low - numeric-type-p parse-unknown-type parse-unknown-type-specifier - pathname-device pathname-directory pathname-host pathname-name - pathname-type pathname-version pathnamelike sequence-end - simple-unboxed-array single-value-type specifier-type streamlike - stringable stringlike structure-type structure-type-name - structure-type-p system-area-clear system-area-copy truth - type-expand type-init two-arg-* two-arg-+ two-arg-- two-arg-/ - two-arg-/= two-arg-< two-arg-<= two-arg-= two-arg-> two-arg->= - two-arg-and two-arg-gcd two-arg-ior two-arg-lcm two-arg-xor - type-difference type-intersect type-intersection type-specifier - type-specifier-symbols type-union type/= type= types-intersect - unboxed-array union-type union-type-p union-type-types - unknown-type unknown-type-p unknown-type-specifier - values-subtypep values-type values-type-allowp - values-type-intersect values-type-intersection values-type-keyp - values-type-keywords values-type-optional values-type-p - values-type-required values-type-rest values-type-union - values-types values-types-intersect void)) - - -(in-package "EXTENSIONS") - -(export '(*after-gc-hooks* *after-save-initializations* *backup-extension* - *before-gc-hooks* *before-save-initializations* - *bytes-consed-between-gcs* *clx-fds-to-displays* - *command-line-strings* *command-line-switches* - *command-line-utility-name* *command-line-words* - *command-switch-demons* *compatibility-warnings* - *describe-implementation-details* *describe-indentation* - *describe-level* *describe-print-length* *describe-print-level* - *describe-verbose* *display-event-handlers* *editor-lisp-p* - *environment-list* *gc-inhibit-hook* *gc-notify-after* - *gc-notify-before* *gc-verbose* *hemlock-version* - *ignore-floating-point-underflow* *info-environment* - *intexp-maximum-exponenent* *keyword-package* *lisp-package* - *load-if-source-newer* *max-step-indentation* - *max-trace-indentation* *module-file-translations* *prompt* - *require-verbose* *safe-defstruct-accessors* *step-print-length* - *step-print-level* *terminal-line-mode* *trace-print-length* - *trace-print-level* *traced-function-list* abort - accept-tcp-connection add-oob-handler ambiguous-files - argument-list assq basic-definition bignump bitp c-sizeof - call-user-miscop careful-symbol-function carefully-add-font-paths - char clean-up-compiler clear-info close-socket cmd-switch-arg - cmd-switch-name cmd-switch-value cmd-switch-words collect - command-line-switch command-line-switch-p - compact-info-environment compile-from-stream compiledp - complete-file concat-pnames connect-to-inet-socket constant - constant-argument create-inet-listener create-inet-socket debug - def-c-array def-c-pointer def-c-procedure def-c-record - def-c-routine def-c-type def-c-variable default-clx-event-handler - default-directory define-info-class define-info-type - define-keyboard-modifier define-keysym define-mouse-code - defmodule defswitch deletef delq disable-clx-event-handling - do-anonymous do-info double-floatp dovector e - enable-clx-event-handling encapsulate encapsulated-p - file-writable fixnump flush-display-events format-decoded-time - format-universal-time gc gc-off gc-on get-bytes-consed - get-code-pointer get-command-line-switch get-data-pointer grindef - host-entry host-entry-addr host-entry-addr-list - host-entry-aliases host-entry-name htonl htons ignorable - ignore-errors inaddr-any indenting-further info int - interactive-eval ipproto-tcp ipproto-udp iterate letf letf* - listen-skip-whitespace load-foreign long long-floatp - lookup-host-entry make-info-environment maybe-inline memq ntohl - ntohs object-set-event-handler once-only open-clx-display - parse-time print-directory print-herald process-alive-p - process-close process-core-dumped process-error process-exit-code - process-input process-kill process-output process-p process-pid - process-plist process-pty process-status process-status-hook - process-wait putf quit ratiop read-char-no-edit realp - remove-all-oob-handlers remove-oob-handler reset-foreign-pointers - run-program save save-all-buffers save-lisp search-list - send-character-out-of-band serve-button-press - serve-button-release serve-circulate-notify - serve-circulate-request serve-client-message - serve-colormap-notify serve-configure-notify - serve-configure-request serve-create-notify serve-destroy-notify - serve-enter-notify serve-exposure serve-focus-in serve-focus-out - serve-graphics-exposure serve-gravity-notify serve-key-press - serve-key-release serve-leave-notify serve-map-notify - serve-map-request serve-motion-notify serve-no-exposure - serve-property-notify serve-reparent-notify serve-resize-request - serve-selection-clear serve-selection-notify - serve-selection-request serve-unmap-notify - serve-visibility-notify set-symbol-function-carefully short - short-floatp signal single-floatp structurep translate-character - translate-mouse-character truly-the uncompile undefined-value - unencapsulate unsigned-char unsigned-int unsigned-long - unsigned-short void with-clx-event-handling)) - - -(in-package "SYSTEM") - -(export '(%alien-indirect %assembler-code-type %bind-aligned-sap - %set-alien-access %standard-char-p %static-alien-area - %string-char-p *alien-eval-when* *beep-function* *gr-messages* - *in-the-compiler* *maximum-interpreter-error-checking* - *nameserverport* *pornography-of-death* - *port-ownership-rights-handlers* *port-receive-rights-handlers* - *stderr* *stdin* *stdout* *task-data* *task-notify* *task-self* - *tty* *typescriptport* *usertypescript* *userwindow* - *xwindow-table* add-fd-handler add-port-death-handler - add-port-object add-xwindow-object alien alien-access - alien-address alien-assign alien-bind alien-index alien-indirect - alien-sap alien-size alien-type alien-value - allocate-system-memory beep bits boolean bytes c-procedure - check<= check= compiler-version copy-alien ct-a-val - ct-a-val-alien ct-a-val-offset ct-a-val-p ct-a-val-sap - ct-a-val-size ct-a-val-type deallocate-system-memory defalien - default-interrupt defenumeration define-alien-stack defoperator - defrecord deport-boolean deport-integer dispose-alien - double-float-radix enable-interrupt enumeration fd-stream - fd-stream-fd fd-stream-p fexpr find-if-in-closure gr-bind gr-call - gr-call* gr-error ignore-interrupt int-sap invalidate-descriptor - long-float-radix long-words macro make-alien make-ct-a-val - make-fd-stream make-indenting-stream make-object-set map-port - map-xwindow naturalize-boolean naturalize-integer - null-terminated-string object-set-operation output-raw-bytes - parse-body perq-string pointer port primep read-n-bytes - record-size remove-fd-handler remove-port-death-handler - remove-port-object remove-xwindow-object - resolve-loaded-assembler-references sap+ sap- sap-int sap-ref-16 - sap-ref-32 sap-ref-8 sap-ref-sap serve-all-events serve-event - server server-message short-float-radix signed-sap-ref-16 - signed-sap-ref-32 signed-sap-ref-8 single-float-radix - symbol-macro-let system-area-pointer system-area-pointer-p - unproclaim unstructured wait-until-fd-usable - with-enabled-interrupts with-fd-handler with-interrupts - with-reply-port with-stack-alien without-gcing without-hemlock - without-interrupts words)) - - -(in-package "USER") - -(use-package "EXT") - - - -(in-package "VM") - -(use-package "KERNEL") -(use-package "EXT") - -(export '(*assembly-unit-length* *primitive-objects* array-data-slot - array-dimensions-offset array-displaced-p-slot - array-displacement-slot array-elements-slot - array-fill-pointer-slot atomic-flag base-character-type - bignum-digits-offset bignum-type binding-size binding-symbol-slot - binding-value-slot byte-bits catch-block-current-code-slot - catch-block-current-cont-slot catch-block-current-uwp-slot - catch-block-entry-pc-slot catch-block-previous-catch-slot - catch-block-size catch-block-size-slot catch-block-tag-slot - cerror-trap closure-function-header-type closure-function-slot - closure-header-type closure-info-offset code-code-size-slot - code-constants-offset code-debug-info-slot code-entry-points-slot - code-header-type complex-array-type complex-bit-vector-type - complex-imag-slot complex-real-slot complex-size - complex-string-type complex-type complex-vector-type - cons-car-slot cons-cdr-slot cons-size - define-for-each-primitive-object double-float-size - double-float-type double-float-value-slot error-trap - even-fixnum-type exported-static-symbols fixnum - function-header-arglist-slot function-header-code-offset - function-header-name-slot function-header-next-slot - function-header-self-slot function-header-type - function-header-type-slot function-pointer-type genesis halt-trap - interrupted-flag list-pointer-type lowtag-bits lowtag-limit - lowtag-mask most-positive-cost odd-fixnum-type - offset-static-symbol other-immediate-0-type - other-immediate-1-type other-pointer-type pad-data-block - pending-interrupt-trap primitive-object-header - primitive-object-lowtag primitive-object-name - primitive-object-options primitive-object-size - primitive-object-slots primitive-object-variable-length - ratio-denominator-slot ratio-numerator-slot ratio-size ratio-type - return-pc-header-type return-pc-return-point-offset - sap-pointer-slot sap-size sap-type sc-number-limit - simple-array-double-float-type simple-array-single-float-type - simple-array-type simple-array-unsigned-byte-16-type - simple-array-unsigned-byte-2-type - simple-array-unsigned-byte-32-type - simple-array-unsigned-byte-4-type - simple-array-unsigned-byte-8-type simple-bit-vector-type - simple-string-type simple-vector-type single-float-size - single-float-type single-float-value-slot slot-docs slot-length - slot-name slot-offset slot-options slot-rest-p - static-symbol-offset static-symbol-p static-symbols - structure-pointer-type symbol-function-slot symbol-header-type - symbol-name-slot symbol-package-slot symbol-plist-slot - symbol-size symbol-value-slot target-binding-stack-start - target-byte-order target-control-stack-start - target-dynamic-space-start target-fasl-code-format - target-fasl-file-type target-heap-address-space - target-most-negative-fixnum target-most-positive-fixnum - target-read-only-space-start target-static-space-start type-bits - type-mask unbound-marker-type unwind-block-current-code-slot - unwind-block-current-cont-slot unwind-block-current-uwp-slot - unwind-block-entry-pc-slot unwind-block-size - value-cell-header-type value-cell-size value-cell-value-slot - vector-data-offset vector-length-slot vector-normal-subtype - vector-structure-subtype vector-valid-hashing-subtype - vector-must-rehash-subtype vm-version word-bits word-bytes - word-shift weak-pointer-type weak-pointer-size - weak-pointer-value-slot weak-pointer-next-slot)) - - -(in-package "C") - -(use-package "EXT") -(use-package "KERNEL") -(use-package "SYSTEM") -(use-package "VM") -(use-package "ASSEM") -(use-package "BIGNUM") - -(export '(*compile-time-define-macros* *compiling-for-interpreter* - compile-for-eval entry-node-info-nlx-tag entry-node-info-st-top - lambda-eval-info-args-passed lambda-eval-info-entries - lambda-eval-info-frame-size)) - - -(in-package "ASSEM") - -(export '(*current-position* align assemble define-argument-type - define-fixup-type define-format define-instruction - define-pseudo-instruction define-random-resources - define-register-file dump-segment emit-code-vector emit-label - finalize-segment fixup fixup-flavor fixup-name fixup-offset - fixup-p gen-label insert-segment inst label label-id label-position - make-fixup make-segment nuke-segment)) - - -(in-package "EVAL") - -(use-package "KERNEL") - -(export '(internal-eval interpreted-function-arglist - interpreted-function-closure - interpreted-function-lambda-expression interpreted-function-name - interpreted-function-p make-interpreted-function)) - - -(in-package "BIGNUM") - -(use-package "KERNEL") - -(import 'vm:bignum-type) - -(export '(add-bignums bignum-ashift-left bignum-ashift-right bignum-compare - bignum-deposit-byte bignum-element-type bignum-gcd bignum-index - bignum-integer-length bignum-load-byte bignum-logcount - bignum-logical-and bignum-logical-ior bignum-logical-not - bignum-logical-xor bignum-plus-p bignum-to-double-float - bignum-to-single-float bignum-truncate bignum-type make-small-bignum - multiply-bignums negate-bignum subtract-bignum)) diff --git a/code/extensions.lisp b/code/extensions.lisp deleted file mode 100644 index 126b07505b1e7e1ec178e48d916d1a753ff1fc8c..0000000000000000000000000000000000000000 --- a/code/extensions.lisp +++ /dev/null @@ -1,553 +0,0 @@ -;;; -*- Log: code.log; Package: Extensions -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Spice Lisp extensions to the language. -;;; -;;; Letf written by Steven Handerson. -;;; -;;; ********************************************************************** -(in-package "EXTENSIONS") - -(export '(letf* letf dovector deletef indenting-further file-comment - read-char-no-edit listen-skip-whitespace concat-pnames - iterate once-only collect do-anonymous undefined-value - define-hash-cache defun-cached cache-hash-eq)) - -(import 'lisp::whitespace-char-p) - - - -;;; Undefined-Value -- Public -;;; -;;; This is here until we figure out what to do with it. -;;; -(proclaim '(inline undefined-value)) -(defun undefined-value () - '%undefined%) - - -;;; FILE-COMMENT -- Public -;;; -(defmacro file-comment (string) - "FILE-COMMENT String - When COMPILE-FILE sees this form at top-level, it places the constant string - in the run-time source location information. DESCRIBE will print the file - comment for the file that a function was defined in. The string is also - textually present in the FASL, so the RCS \"ident\" command can find it, - etc." - (declare (ignore string)) - '(undefined-value)) - - -(defun skip-whitespace (&optional (stream *standard-input*)) - (loop (let ((char (read-char stream))) - (if (not (lisp::whitespacep char)) - (return (unread-char char stream)))))) - - -(defun listen-skip-whitespace (&optional (stream *standard-input*)) - "See listen. Any whitespace in the input stream will be flushed." - (do ((char (read-char-no-hang stream nil nil nil) - (read-char-no-hang stream nil nil nil))) - ((null char) nil) - (cond ((not (whitespace-char-p char)) - (unread-char char stream) - (return T))))) - -;;; These macros waste time as opposed to space. - -(defmacro letf* (bindings &body body &environment env) - "Does what one might expect, saving the old values and setting the generalized - variables to the new values in sequence. Unwind-protects and get-setf-method - are used to preserve the semantics one might expect in analogy to let*, - and the once-only evaluation of subforms." - (labels ((do-bindings - (bindings) - (cond ((null bindings) body) - (t (multiple-value-bind (dummies vals newval setter getter) - (lisp::foo-get-setf-method (caar bindings) env) - (let ((save (gensym))) - `((let* (,@(mapcar #'list dummies vals) - (,(car newval) ,(cadar bindings)) - (,save ,getter)) - (unwind-protect - (progn ,setter - ,@(do-bindings (cdr bindings))) - (setq ,(car newval) ,save) - ,setter))))))))) - (car (do-bindings bindings)))) - - -(defmacro letf (bindings &body body &environment env) - "Like letf*, but evaluates all the implicit subforms and new values of all - the implied setfs before altering any values. However, the store forms - (see get-setf-method) must still be evaluated in sequence. Uses unwind- - protects to protect the environment." - (let (temps) - (labels - ((do-bindings - (bindings) - (cond ((null bindings) body) - (t (let ((binding (car bindings))) - (multiple-value-bind (dummies vals newval setter getter) - (lisp::foo-get-setf-method (car binding) env) - (let ((save (gensym))) - (mapcar #'(lambda (a b) (push (list a b) temps)) - dummies vals) - (push (list save getter) temps) - (push (list (car newval) (cadr binding)) temps) - `((unwind-protect - (progn ,setter - ,@(do-bindings (cdr bindings))) - (setq ,(car newval) ,save) - ,setter))))))))) - (let ((form (car (do-bindings bindings)))) - `(let* ,(nreverse temps) - ,form))))) - - -(define-setf-method logbitp (index int &environment env) - (multiple-value-bind (temps vals stores store-form access-form) - (lisp::foo-get-setf-method int env) - (let ((ind (gensym)) - (store (gensym)) - (stemp (first stores))) - (values `(,ind ,@temps) - `(,index - ,@vals) - (list store) - `(let ((,stemp - (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))) - ,store-form - ,store) - `(logbitp ,ind ,access-form))))) - - -;;; Indenting-Further is a user-level macro which may be used to locally increment -;;; the indentation of a stream. - -(defmacro indenting-further (stream more &rest body) - "Causes the output of the indenting Stream to indent More spaces. More is - evaluated twice." - `(unwind-protect - (progn - (incf (lisp::indenting-stream-indentation ,stream) ,more) - ,@body) - (decf (lisp::indenting-stream-indentation ,stream) ,more))) - - -;;; Deletef - -(defmacro deletef (elt list &rest keys &environment env) - (multiple-value-bind (dummies vals newval setter getter) - (lisp::foo-get-setf-method list env) - (let ((eltsym (gensym)) - (listsym (gensym))) - `(let* ((,eltsym ,elt) - ,@(mapcar #'list dummies vals) - (,listsym ,getter) - (,(car newval) (delete ,eltsym ,listsym ,@keys))) - ,setter)))) - - -(defmacro dovector ((elt vector) &rest forms) - "Just like dolist, but with one-dimensional arrays." - (let ((index (gensym)) - (length (gensym)) - (vec (gensym))) - `(let ((,vec ,vector)) - (do ((,index 0 (1+ ,index)) - (,length (length ,vec))) - ((>= ,index ,length) nil) - (let ((,elt (aref ,vec ,index))) - ,@forms))))) - - -(eval-when (compile load eval) - (defun concat-pnames (name1 name2) - (if name1 - (intern (concatenate 'simple-string (symbol-name name1) - (symbol-name name2))) - name2))) - - -;;; Iterate -- Public -;;; -;;; The ultimate iteration macro... -;;; -(defmacro iterate (name binds &body body) - "Iterate Name ({(Var Initial-Value)}*) Declaration* Form* - This is syntactic sugar for Labels. It creates a local function Name with - the specified Vars as its arguments and the Declarations and Forms as its - body. This function is then called with the Initial-Values, and the result - of the call is return from the macro." - (dolist (x binds) - (unless (and (listp x) - (= (length x) 2)) - (error "Malformed iterate variable spec: ~S." x))) - - `(labels ((,name ,(mapcar #'first binds) ,@body)) - (,name ,@(mapcar #'second binds)))) - - -;;;; The Collect macro: - -;;; Collect-Normal-Expander -- Internal -;;; -;;; This function does the real work of macroexpansion for normal collection -;;; macros. N-Value is the name of the variable which holds the current -;;; value. Fun is the function which does collection. Forms is the list of -;;; forms whose values we are supposed to collect. -;;; -(defun collect-normal-expander (n-value fun forms) - `(progn - ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) - ,n-value)) - -;;; Collect-List-Expander -- Internal -;;; -;;; This function deals with the list collection case. N-Tail is the pointer -;;; to the current tail of the list, which is NIL if the list is empty. -;;; -(defun collect-list-expander (n-value n-tail forms) - (let ((n-res (gensym))) - `(progn - ,@(mapcar #'(lambda (form) - `(let ((,n-res (cons ,form nil))) - (cond (,n-tail - (setf (cdr ,n-tail) ,n-res) - (setq ,n-tail ,n-res)) - (t - (setq ,n-tail ,n-res ,n-value ,n-res))))) - forms) - ,n-value))) - - -;;; Collect -- Public -;;; -;;; The ultimate collection macro... -;;; -(defmacro collect (collections &body body) - "Collect ({(Name [Initial-Value] [Function])}*) {Form}* - Collect some values somehow. Each of the collections specifies a bunch of - things which collected during the evaluation of the body of the form. The - name of the collection is used to define a local macro, a la MACROLET. - Within the body, this macro will evaluate each of its arguments and collect - the result, returning the current value after the collection is done. The - body is evaluated as a PROGN; to get the final values when you are done, just - call the collection macro with no arguments. - - Initial-Value is the value that the collection starts out with, which - defaults to NIL. Function is the function which does the collection. It is - a function which will accept two arguments: the value to be collected and the - current collection. The result of the function is made the new value for the - collection. As a totally magical special-case, the Function may be Collect, - which tells us to build a list in forward order; this is the default. If an - Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the - end. Note that Function may be anything that can appear in the functional - position, including macros and lambdas." - - (let ((macros ()) - (binds ())) - (dolist (spec collections) - (unless (<= 1 (length spec) 3) - (error "Malformed collection specifier: ~S." spec)) - (let ((n-value (gensym)) - (name (first spec)) - (default (second spec)) - (kind (or (third spec) 'collect))) - (push `(,n-value ,default) binds) - (if (eq kind 'collect) - (let ((n-tail (gensym))) - (if default - (push `(,n-tail (last ,n-value)) binds) - (push n-tail binds)) - (push `(,name (&rest args) - (collect-list-expander ',n-value ',n-tail args)) - macros)) - (push `(,name (&rest args) - (collect-normal-expander ',n-value ',kind args)) - macros)))) - `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) - - -;;;; The Once-Only macro: - -;;; Once-Only -- Interface -;;; -;;; Once-Only is a utility useful in writing source transforms and macros. -;;; It provides an easy way to wrap a let around some code to ensure that some -;;; forms are only evaluated once. -;;; -(defmacro once-only (specs &body body) - "Once-Only ({(Var Value-Expression)}*) Form* - Create Let which evaluates each Value-Expression, binding a temporary - variable to the result, and wrapping the Let around the result of the - evaluation of Body. Within the body, each Var is bound to the corresponding - temporary variable. If the Value-Expression is a constant, then we just pass - it through." - (let ((n-binds (gensym)) - (n-temp (gensym))) - (collect ((names) - (temp-binds)) - (dolist (spec specs) - (when (/= (length spec) 2) - (error "Malformed Once-Only binding spec: ~S." spec)) - (let ((name (first spec)) - (exp (second spec))) - (names `(,name ,exp)) - (temp-binds - `(let ((,n-temp (gensym))) - (,n-binds `(,,n-temp ,,name)) - (setq ,name ,n-temp))))) - `(let ,(names) - (collect ((,n-binds)) - ,@(temp-binds) - (list 'let (,n-binds) (progn ,@body))))))) - - -;;;; DO-ANONYMOUS: - -;;; ### Bootstrap hack... Renamed to avoid clobbering function in bootstrap -;;; environment. -;;; -(defun lisp::do-do-body (varlist endlist code decl bind step name block) - (let* ((inits ()) - (steps ()) - (l1 (gensym)) - (l2 (gensym))) - ;; Check for illegal old-style do. - (when (or (not (listp varlist)) (atom endlist)) - (error "Ill-formed ~S -- possibly illegal old style DO?" name)) - ;; Parse the varlist to get inits and steps. - (dolist (v varlist) - (cond ((symbolp v) (push v inits)) - ((listp v) - (unless (symbolp (first v)) - (error "~S step variable is not a symbol: ~S" name (first v))) - (case (length v) - (1 (push (first v) inits)) - (2 (push v inits)) - (3 (push (list (first v) (second v)) inits) - (setq steps (list* (third v) (first v) steps))) - (t (error "~S is an illegal form for a ~S varlist." v name)))) - (t (error "~S is an illegal form for a ~S varlist." v name)))) - ;; And finally construct the new form. - `(block ,BLOCK - (,bind ,(nreverse inits) - ,@decl - (tagbody - (go ,L2) - ,L1 - ,@code - (,step ,@(nreverse steps)) - ,L2 - (unless ,(car endlist) (go ,L1)) - (return-from ,BLOCK (progn ,@(cdr endlist)))))))) - - -(defmacro do-anonymous (varlist endlist &body (body decls)) - "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* - Like DO, but has no implicit NIL block. Each Var is initialized in parallel - to the value of the specified Init form. On subsequent iterations, the Vars - are assigned the value of the Step form (if any) in paralell. The Test is - evaluated before each evaluation of the body Forms. When the Test is true, - the the Exit-Forms are evaluated as a PROGN, with the result being the value - of the DO." - (lisp::do-do-body varlist endlist body decls 'let 'psetq - 'do-anonymous (gensym))) - - -;;;; Hash cache utility: - -;;; DEFINE-HASH-CACHE -- Public -;;; -(defmacro define-hash-cache (name args &key hash-function hash-bits default - (values 1)) - "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}* - Define a hash cache that associates some number of argument values to a - result value. The Test-Function paired with each Arg-Name is used to compare - the value for that arg in a cache entry with a supplied arg. The - Test-Function must not error when passed NIL as its first arg, but need not - return any particular value. Test-Function may be any thing that can be - place in CAR position. - - Name is used to define functions these functions: - - <name>-CACHE-LOOKUP Arg* - See if there is an entry for the specified Args in the cache. The if not - present, the :DEFAULT keyword (default NIL) determines the result(s). - - <name>-CACHE-ENTER Arg* Value* - Encache the association of the specified args with Value. - - <name>-CACHE-FLUSH-<arg-name> Arg - Flush all entries from the cache that have the value Arg for the named - arg. - - <name>-CACHE-CLEAR - Reinitialize the cache, invalidating all entries and allowing the - arguments and result values to be GC'd. - - These other keywords are defined: - - :HASH-BITS <n> - The size of the cache as a power of 2. - - :HASH-FUNCTION function - Some thing that can be placed in CAR position which will compute a value - between 0 and (1- (expt 2 <hash-bits>)). - - :VALUES <n> - The number of values cached." - - (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) - (nargs (length args)) - (entry-size (+ nargs values)) - (size (ash 1 hash-bits)) - (total-size (* entry-size size)) - (default-values (if (and (consp default) (eq (car default) 'values)) - (cdr default) - (list default))) - (n-index (gensym)) - (n-cache (gensym))) - - (unless (= (length default-values) values) - (error "Number of default values ~S differs from :VALUES ~D." - default values)) - - (collect ((inlines) - (forms) - (tests) - (sets) - (arg-vars) - (values-indices) - (values-names)) - (dotimes (i values) - (values-indices `(+ ,n-index ,(+ nargs i))) - (values-names (gensym))) - - (let ((n 0)) - (dolist (arg args) - (unless (= (length arg) 2) - (error "Bad arg spec: ~S." arg)) - (let ((arg-name (first arg)) - (test (second arg))) - (arg-vars arg-name) - (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name)) - (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)) - - (let ((fun-name (symbolicate name "-CACHE-FLUSH-" arg-name))) - (forms - `(defun ,fun-name (,arg-name) - (do ((,n-index ,(+ (- total-size entry-size) n) - (- ,n-index ,entry-size)) - (,n-cache ,var-name)) - ((minusp ,n-index)) - (when (,test (svref ,n-cache ,n-index) ,arg-name) - (let ((,n-index (- ,n-index ,n))) - ,@(mapcar #'(lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) - (values-indices) - default-values)))) - (undefined-value))))) - (incf n))) - - (let ((fun-name (symbolicate name "-CACHE-LOOKUP"))) - (inlines fun-name) - (forms - `(defun ,fun-name ,(arg-vars) - (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) - (,n-cache ,var-name)) - (if (and ,@(tests)) - (values ,@(mapcar #'(lambda (x) `(svref ,n-cache ,x)) - (values-indices))) - ,default))))) - - (let ((fun-name (symbolicate name "-CACHE-ENTER"))) - (inlines fun-name) - (forms - `(defun ,fun-name (,@(arg-vars) ,@(values-names)) - (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) - (,n-cache ,var-name)) - ,@(sets) - ,@(mapcar #'(lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) - (values-indices) - (values-names)) - (undefined-value))))) - - (let ((fun-name (symbolicate name "-CACHE-CLEAR"))) - (forms - `(defun ,fun-name () - (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size)) - (,n-cache ,var-name)) - ((minusp ,n-index)) - ,@(collect ((arg-sets)) - (dotimes (i nargs) - (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil))) - (arg-sets)) - ,@(mapcar #'(lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) - (values-indices) - default-values)) - (undefined-value))) - (forms `(,fun-name))) - - `(progn - (defvar ,var-name (make-array ,total-size)) - (proclaim '(type (simple-vector ,total-size) ,var-name)) - (proclaim '(inline ,@(inlines))) - ,@(forms) - ',name)))) - - -;;; DEFUN-CACHED -- Public -;;; -(defmacro defun-cached ((name &rest options &key (values 1) default - &allow-other-keys) - args &body (body decls doc)) - "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form* - Some syntactic sugar for defining a function whose values are cached by - DEFINE-HASH-CACHE." - (let ((default-values (if (and (consp default) (eq (car default) 'values)) - (cdr default) - (list default))) - (arg-names (mapcar #'car args))) - (collect ((values-names)) - (dotimes (i values) - (values-names (gensym))) - `(progn - (define-hash-cache ,name ,args ,@options) - (defun ,name ,arg-names - ,@decls - ,doc - (multiple-value-bind - ,(values-names) - (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) - (if (and ,@(mapcar #'(lambda (val def) - `(eq ,val ,def)) - (values-names) default-values)) - (multiple-value-bind ,(values-names) - (progn ,@body) - (,(symbolicate name "-CACHE-ENTER") ,@arg-names - ,@(values-names)) - (values ,@(values-names))) - (values ,@(values-names))))))))) - - -;;; CACHE-HASH-EQ -- Public -;;; -(proclaim '(inline cache-hash-eq)) -(defun cache-hash-eq (x) - "Return an EQ hash of X. The value of this hash for any given object can (of - course) change at arbitary times." - (the fixnum (ash (the fixnum (%primitive make-fixnum x)) - -3))) - diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp deleted file mode 100644 index 24215c3d3c74007a72b7adf87679df46766d3a28..0000000000000000000000000000000000000000 --- a/code/fd-stream.lisp +++ /dev/null @@ -1,1294 +0,0 @@ -;;; -*- Log: code.log; Package: LISP -*- - -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Streams for UNIX file descriptors. -;;; -;;; Written by William Lott, July 1989 - January 1990. -;;; -;;; ********************************************************************** - - -(in-package "SYSTEM") - -(export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream - beep *beep-function* - output-raw-bytes - *tty* *stdin* *stdout* *stderr*)) - - -(in-package "EXTENSIONS") - -(export '(*backup-extension*)) - - -(in-package "LISP") - -(defmacro byte-blt (src-string src-start dst-string dst-start dst-end) - "Move the bytes from src-string to dst-string." - `(system:%primitive byte-blt - ,src-string - ,src-start - ,dst-string - ,dst-start - ,dst-end)) - - -;;;; Buffer manipulation routines. - -(defvar *available-buffers* () - "List of available buffers. Each buffer is an dynamic alien.") - -(defconstant bytes-per-buffer (* 4 1024) - "Number of bytes per buffer.") - -;;; NEXT-AVAILABLE-BUFFER -- Internal. -;;; -;;; Returns the next available alien buffer, creating one if necessary. -;;; -(proclaim '(inline next-available-buffer)) -;;; -(defun next-available-buffer () - (if *available-buffers* - (pop *available-buffers*) - (system:make-alien 'alien (* bytes-per-buffer 8)))) - - - -;;;; 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 - (element-size 1) ; Number of bytes per element. - (element-type 'string-char) ; The type of element being transfered. - (fd -1 :type fixnum) ; The file descriptor - (buffering :full) ; One of :none, :line, or :full - (char-pos nil) ; Character position if known. - (listen nil) ; T if we don't need to listen - - ;; The input buffer. - (unread nil) - (ibuf nil) - (ibuf-sap nil) - (ibuf-length nil) - (ibuf-head 0 :type fixnum) - (ibuf-tail 0 :type fixnum) - - ;; The output buffer. - (obuf nil) - (obuf-sap nil) - (obuf-length nil) - (obuf-tail 0 :type fixnum) - - ;; Output flushed, but not written due to non-blocking io. - (output-later nil) - (handler nil)) - -(defun %print-fd-stream (fd-stream stream depth) - (declare (ignore depth)) - (format stream "#<Stream for ~A>" - (fd-stream-name fd-stream))) - - - -;;;; 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)) - (buffer (cadddr stuff)) - (length (- end start))) - (multiple-value-bind - (count errno) - (mach:unix-write (fd-stream-fd stream) - base - start - length) - (cond ((eql count length) ; Hot damn, it workded. - (when buffer - (push buffer *available-buffers*))) - ((not (null count)) ; Sorta worked. - (push (list base - (+ start count) - end - buffer) - (fd-stream-output-later stream))) - ((= errno mach:ewouldblock) - (error "Write would have blocked, but SERVER told us to go.")) - (t - (error "While writing ~S: ~A" - stream - (mach:get-unix-error-msg errno)))))) - (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 buffer) - (cond ((null (fd-stream-output-later stream)) - (setf (fd-stream-output-later stream) - (list (list base start end buffer))) - (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 buffer))))) - (when buffer - (let ((new-buffer (next-available-buffer))) - (setf (fd-stream-obuf stream) new-buffer) - (setf (fd-stream-obuf-sap stream) - (system:alien-sap new-buffer)) - (setf (fd-stream-obuf-length stream) - (/ (system:alien-size new-buffer) 8))))) - -;;; 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 buffer) - (if (not (null (fd-stream-output-later stream))) ; something buffered. - (progn - (output-later stream base start end buffer) - ;; XXX check to see if any of this noise can be output - ) - (let ((length (- end start))) - (multiple-value-bind - (count errno) - (mach:unix-write (fd-stream-fd stream) base start length) - (cond ((eql count length)) ; Hot damn, it worked. - ((not (null count)) - (output-later stream base (+ start count) end buffer)) - ((= errno mach:ewouldblock) - (output-later stream base start end buffer)) - (t - (error "While writing ~S: ~A" - stream - (mach:get-unix-error-msg errno)))))))) - -;;; 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 - (fd-stream-obuf stream)) - (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-BYTE-~A-BUFFERED" - 1 - (:none (signed-byte 8) (unsigned-byte 8) string-char) - (:line string-char) - (:full (signed-byte 8) (unsigned-byte 8) string-char)) - (when (characterp byte) - (if (eq (char-code byte) - (char-code #\Newline)) - (setf (fd-stream-char-pos stream) 0) - (incf (fd-stream-char-pos stream)))) - (system:%primitive 8bit-system-set - (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))) - (system:%primitive 16bit-system-set - (fd-stream-obuf-sap stream) - (/ (fd-stream-obuf-tail stream) 2) - byte)) -(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED" - 4 - (:none (signed-byte 32)) - (:full (signed-byte 32))) - (system:%primitive signed-32bit-system-set - (fd-stream-obuf-sap stream) - (/ (fd-stream-obuf-tail stream) 2) - byte)) -; XXX What? no unsigned-32bit-system-set? -(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED" - 4 - (:none (unsigned-byte 31)) - (:full (unsigned-byte 31))) - (system:%primitive signed-32bit-system-set - (fd-stream-obuf-sap stream) - (/ (fd-stream-obuf-tail stream) 2) - 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 thing)))) - (declare (fixnum 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) - (byte-blt thing start (fd-stream-obuf-sap stream) tail newtail) - (setf (fd-stream-obuf-tail stream) newtail)) - ((<= bytes len) - (flush-output-buffer stream) - (byte-blt thing start (fd-stream-obuf-sap stream) 0 bytes) - (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 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))) - (unless (zerop head) - (cond ((eq 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) - (byte-blt ibuf-sap head ibuf-sap 0 tail) - (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) - (mach:unix-select (1+ fd) (ash 1 fd) 0 0 0) - (case count - (1) - (0 - (system:wait-until-fd-usable fd :input)) - (t - (error "Problem checking to see if ~S is readable: ~A" - stream - (mach:get-unix-error-msg errno))))) - (multiple-value-bind - (count errno) - (mach:unix-read fd - (system:int-sap (+ (system:sap-int ibuf-sap) tail)) - (- buflen tail)) - (cond ((null count) - (if (eql errno mach:ewouldblock) - (progn - (system:wait-until-fd-usable fd :input) - (do-input stream)) - (error "Error reading ~S: ~A" - stream - (mach:get-unix-error-msg errno)))) - ((zerop count) - (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)) - (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-STRING-CHAR -- internal -;;; -;;; Routine to use in stream-in slot for reading string chars. -;;; -(def-input-routine input-string-char - (string-char 1 sap head) - (code-char (system:%primitive 8bit-system-ref 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) - (system:%primitive 8bit-system-ref 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) - (let ((byte (system:%primitive 8bit-system-ref sap head))) - (if (logand byte #x80) - (- byte #x100) - byte))) - -;;; 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) - (system:%primitive 16bit-system-ref - sap - (/ head 2))) - -;;; 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) - (system:%primitive signed-16bit-system-ref - sap - (/ head 2))) - -;;; 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) - (system:%primitive unsigned-32bit-system-ref - sap - (/ head 2))) - -;;; 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) - (system:%primitive signed-32bit-system-ref - sap - (/ head 2))) - -;;; 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) - (let* ((length (- end start)) - (string (make-string length))) - (byte-blt sap start string 0 length) - 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 (if (fd-stream-unread stream) - (prog1 - (list (string (fd-stream-unread stream))) - (setf (fd-stream-unread 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 (system:%primitive find-character - sap - head - tail - #\Newline)) - (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))) - - -;;; 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))) - (byte-blt sap head buffer offset (+ offset copy)) - (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))))) - - -;;;; 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 stream) - (push (fd-stream-obuf stream) *available-buffers*) - (setf (fd-stream-obuf stream) nil)) - (when (fd-stream-ibuf stream) - (push (fd-stream-ibuf stream) *available-buffers*) - (setf (fd-stream-ibuf 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 stream) - (next-available-buffer)) - (setf (fd-stream-ibuf-sap stream) - (system:alien-sap (fd-stream-ibuf stream))) - (setf (fd-stream-ibuf-length stream) - (/ (system:alien-size (fd-stream-ibuf stream)) 8)) - (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 stream) (next-available-buffer)) - (setf (fd-stream-obuf-sap stream) - (system:alien-sap (fd-stream-obuf stream))) - (setf (fd-stream-obuf-length stream) - (/ (system:alien-size (fd-stream-obuf stream)) 8)) - (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 'string-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) - ((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) - (not (zerop (mach:unix-select (1+ (fd-stream-fd stream)) - (ash 1 (fd-stream-fd stream)) - 0 - 0 - 0)))))) - (:unread - (setf (fd-stream-unread stream) arg1)) - (:close - (cond (arg1 - ;; We got us an abort on our hands. - (when (and (fd-stream-file stream) - (fd-stream-obuf 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) - (mach: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) - (mach:get-unix-error-msg err)))) - ;; Can't restore the orignal, so nuke that puppy. - (multiple-value-bind - (okay err) - (mach: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) - (mach: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) - (mach: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 - (mach:get-unix-error-msg err))))))) - (mach:unix-close (fd-stream-fd stream)) - (when (fd-stream-obuf stream) - (push (fd-stream-obuf stream) *available-buffers*) - (setf (fd-stream-obuf stream) nil)) - (when (fd-stream-ibuf stream) - (push (fd-stream-ibuf stream) *available-buffers*) - (setf (fd-stream-ibuf stream) nil)) - (lisp::set-closed-flame stream)) - (:clear-input) - (: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)) - (: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) - (mach: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 - (mach:get-unix-error-msg dev))) - (if (zerop mode) - nil - (/ 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) - (if (null newpos) - (system:without-interrupts - ;; First, find the position of the UNIX file descriptor in the - ;; file. - (multiple-value-bind - (posn errno) - (mach:unix-lseek (fd-stream-fd stream) 0 mach:l_incr) - (cond ((numberp 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 (- (caddr later) (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. - (/ posn (fd-stream-element-size stream))) - ((eq errno mach:espipe) - nil) - (t - (system:with-interrupts - (error "Error lseek'ing ~S: ~A" - stream - (mach: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) - ;; Now move it. - (cond ((eq newpos :start) - (setf offset 0 origin mach:l_set)) - ((eq newpos :end) - (setf offset 0 origin mach:l_xtnd)) - ((numberp newpos) - (setf offset (* newpos (fd-stream-element-size stream)) - origin mach:l_set)) - (t - (error "Invalid position given to file-position: ~S" newpos))) - (multiple-value-bind - (posn errno) - (mach:unix-lseek (fd-stream-fd stream) offset origin) - (cond ((numberp posn) - t) - ((eq errno mach:espipe) - nil) - (t - (error "Error lseek'ing ~S: ~A" - stream - (mach: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 'string-char) - (buffering :full) - file - original - delete-original - (name (if file - (format nil "file ~S" file) - (format nil "descriptor ~D" fd)))) - "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 (one of :none, :line, or :full). If - file is spesified, it should be the name of the file. 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))) - (set-routines stream element-type input output) - 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) - (etypecase *backup-extension* - (string (concatenate 'simple-string name *backup-extension*)) - (function (funcall *backup-extension* 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 *query-io* "Enter new value for ~S: " what) - (force-output *query-io*) - (setf item (read *query-io*)) - (when (member item list) - (return)))) - item) - -;;; OPEN -- public -;;; -;;; Open the given file. -;;; -(defun open (filename - &key - (direction :input) - (element-type 'string-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 STRING-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 mach:o_rdonly)) - (:output (values nil t mach:o_wronly)) - (:io (values t t mach:o_rdwr)) - (:probe (values nil nil mach:o_rdonly))) - (let* ((pathname (pathname filename)) - (namestring (predict-name 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 mach:o_excl))) - ((:rename :rename-and-delete) - (setf mask (logior mask mach:o_creat))) - ((:new-version :supersede) - (setf mask (logior mask mach:o_trunc))) - (:append - (setf mask (logior mask mach: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 mach: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 - (multiple-value-bind - (okay err/dev inode orig-mode) - (mach:unix-stat namestring) - (declare (ignore inode)) - (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 mach:enoent) - nil) - (t - (error "Cannot find ~S: ~A" - namestring - (mach:get-unix-error-msg err/dev))))))) - (when (or (not exists) - ;; Do the rename. - (multiple-value-bind - (okay err) - (mach:unix-rename namestring original) - (unless okay - (cerror "Use :SUPERSEDE instead." - "Could not rename ~S to ~S: ~A." - namestring - original - (mach:get-unix-error-msg err)) - t))) - (setf original nil) - (setf delete-original nil) - ;; In order to use SUPERSEDE instead, we have - ;; to make sure mach:o_creat corresponds to - ;; if-does-not-exist. mach:o_creat was set - ;; before because of if-exists being :rename. - (unless (eq if-does-not-exist :create) - (setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc))) - (setf if-exists :supersede)))) - - ;; Okay, now we can try the actual open. - (multiple-value-bind - (fd errno) - (mach:unix-open namestring mask mode) - (cond ((numberp fd) - (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)) - (:probe - (let ((stream (%make-fd-stream :name namestring - :fd fd - :element-type element-type))) - (close stream) - stream)))) - ((eql errno mach:enoent) - (case if-does-not-exist - (:error - (cerror "Return NIL." - "Error opening ~S, ~A." - pathname - (mach:get-unix-error-msg errno))) - (:create - (cerror "Return NIL." - "Error creating ~S, path does not exist." - pathname))) - nil) - ((eql errno mach:eexist) - (unless (eq nil if-exists) - (cerror "Return NIL." - "Error opening ~S, ~A." - pathname - (mach:get-unix-error-msg errno))) - nil) - (t - (cerror "Return NIL." - "Error opening ~S, ~A." - pathname - (mach:get-unix-error-msg errno)) - 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-input* (make-synonym-stream '*stdin*)) - (setf *standard-output* (make-synonym-stream '*stdout*)) - (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 (mach:unix-open "/dev/tty" mach:o_rdwr #o666))) - (if tty - (setf *tty* - (make-fd-stream tty :name "the Terminal" :input t :output t - :buffering :line)) - (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 8f08bb5141d797c53aeb681239d183f999ce7b5b..0000000000000000000000000000000000000000 --- a/code/fdefinition.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*- Package: Lisp; Log: code.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/code/fdefinition.lisp,v 1.1.1.2 1990/04/20 00:36:19 wlott Exp $ -;;; -;;; Functions that hack on the global function namespace (primarily -;;; concerned with SETF functions here.) -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "LISP") -(export '(fdefinition fboundp fmakunbound)) - -(defvar *setf-functions* (make-hash-table :test #'equal)) - -(eval-when (compile eval) - -;;; With-Function-Name -- Internal -;;; -(defmacro with-function-name (name symbol-form setf-form) - `(typecase ,name - (symbol ,symbol-form) - (cons - (unless (and (eq (car ,name) 'setf) - (consp (cdr ,name)) - (symbolp (cadr ,name))) - (error "Malformed function name: ~S." ,name)) - ,setf-form) - (t - (error "Malformed function name: ~S." ,name)))) - -); Eval-When (Compile Eval) - -#+new-compiler -(defun careful-symbol-function (name) - (symbol-function name)) - -#+new-compiler -(defun set-symbol-function-carefully (name value) - (setf (symbol-function name) value)) - -(defun fdefinition (name) - "Return Name's global function definition." - (with-function-name name - (careful-symbol-function name) - (or (gethash (cadr name) *setf-functions*) - (error "Undefined function: ~S." name)))) - -(defsetf fdefinition %set-fdefinition) - -(defun %set-fdefinition (name new-value) - "Set Name's global function definition." - (declare (type function new-value)) - (with-function-name name - (set-symbol-function-carefully name new-value) - (setf (gethash (cadr name) *setf-functions*) new-value))) - -#+new-compiler -(defun fboundp (name) - "Return true if Name has a global function definition." - (with-function-name name - (functionp (%primitive fast-symbol-function name)) - (functionp (gethash (cadr name) *setf-functions*)))) - -#+new-compiler -(defvar *the-undefined-function*) - -#+new-compiler -(defun fmakunbound (name) - "Make Name have no global function definition." - (with-function-name name - (%primitive set-symbol-function name *the-undefined-function*) - (remhash (cadr name) *setf-functions*)) - t) diff --git a/code/filesys.lisp b/code/filesys.lisp deleted file mode 100644 index 49e97c122ec125e9c250d415bb74d6189465897e..0000000000000000000000000000000000000000 --- a/code/filesys.lisp +++ /dev/null @@ -1,1113 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; ### Some day fix to accept :wild in any pathname component. -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Ugly pathname functions for Spice Lisp. -;;; these functions are part of the standard Spice Lisp environment. -;;; -;;; Written by Jim Large and Rob MacLachlan -;;; -;;; ********************************************************************** - -(in-package "LISP") - -(export '(pathname pathnamep *default-pathname-defaults* truename - 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 user-homedir-pathname - probe-file rename-file delete-file file-write-date - file-author directory)) - -(use-package "EXTENSIONS") - -(in-package "EXTENSIONS") -(export '(print-directory complete-file ambiguous-files default-directory - file-writable)) -(in-package "LISP") - - -;;; Pathname structure - - -;;; *Default-Pathname-defaults* has all values unspecified except for the -;;; host. All pathnames must have a host. -(defvar *default-pathname-defaults* () - "Set to the default pathname-defaults pathname (Got that?)") - -(defun filesys-init () - (setq *default-pathname-defaults* - (%make-pathname "Mach" nil nil nil nil nil))) - - -;;; The pathname type is defined with a defstruct. -;;; This declaration implicitly defines the common lisp function Pathnamep -(defstruct (pathname - (:conc-name %pathname-) - (:print-function %print-pathname) - (:constructor - %make-pathname (host device directory name type version)) - (:predicate pathnamep)) - "Pathname is the structure of the file pathname. It consists of a - host, a device, a directory, a name, and a type." - (host nil :type (or simple-string null)) - (device nil :type (or simple-string (member nil :absolute))) - (directory nil :type (or simple-vector null)) - (name nil :type (or simple-string null)) - (type nil :type (or simple-string null)) - (version nil :type (or integer (member nil :newest)))) - -(defun %print-pathname (s stream d) - (declare (ignore d)) - (format stream "#.(pathname ~S)" (namestring s))) - -(defun make-pathname (&key defaults (host nil hostp) (device nil devicep) - (directory nil directoryp) (name nil namep) - (type nil typep) (version nil versionp)) - "Create a pathname from :host, :device, :directory, :name, :type and :version. - If any field is ommitted, it is obtained from :defaults as though by - merge-pathnames." - (if defaults - (let ((defaults (pathname defaults))) - (unless hostp - (setq host (%pathname-host defaults))) - (unless devicep - (setq device (%pathname-device defaults))) - (unless directoryp - (setq directory (%pathname-directory defaults))) - (unless namep - (setq name (%pathname-name defaults))) - (unless typep - (setq type (%pathname-type defaults))) - (unless versionp - (setq version (%pathname-version defaults)))) - (unless hostp - (setq host (%pathname-host *default-pathname-defaults*)))) - - (when (stringp directory) - (setq directory (%pathname-directory (parse-namestring directory)))) - (%make-pathname - (if (stringp host) (coerce host 'simple-string) host) - (if (stringp device) (coerce device 'simple-string) device) - directory - (if (stringp name) (coerce name 'simple-string) name) - (if (stringp type) (coerce type 'simple-string) type) - version)) - - -;;; These can not be done by the accessors because the pathname arg may be -;;; a string or a symbol or etc. - -(defun pathname-host (pathname) - "Returns the host slot of pathname. Pathname may be a string, symbol, - or stream." - (%pathname-host (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-device (pathname) - "Returns the device slot of pathname. Pathname may be a string, symbol, - or stream." - (%pathname-device (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-directory (pathname) - "Returns the directory slot of pathname. Pathname may be a string, - symbol, or stream." - (%pathname-directory (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-name (pathname) - "Returns the name slot of pathname. Pathname may be a string, - symbol, or stream." - (%pathname-name (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-type (pathname) - "Returns the type slot of pathname. Pathname may be a string, - symbol, or stream." - (%pathname-type (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-version (pathname) - "Returns the version slot of pathname. Pathname may be a string, - symbol, or stream." - (%pathname-version (if (pathnamep pathname) pathname (pathname pathname)))) - - - -;;;; PARSE-NAMESTRING and PATHNAME. - -;;; SPLIT-FILENAME -- internal -;;; -;;; Splits the filename into the name and type. If someone wants to change -;;; this yet again, just change this. -;;; -(defun split-filename (filename) - (declare (simple-string filename)) - (let ((posn (position #\. filename :from-end t))) - (cond ((null posn) - (values filename nil)) - ((or (zerop posn) (= posn (1- (length filename)))) - (values filename "")) - (t - (values (subseq filename 0 posn) - (subseq filename (1+ posn))))))) - -;;; DO-FILENAME-PARSE -- internal -;;; -;;; Split string into a logical name, a vector of directories, a file name and -;;; a file type. -;;; -(defun do-filename-parse (string &optional (start 0) end) - (declare (simple-string string)) - (let ((end (or end (length string)))) - (let* ((directories nil) - (filename nil) - (absolutep (and (> end start) (eql (schar string start) #\/))) - (logical-name - (cond (absolutep - (setf start (position #\/ string :start start :end end - :test-not #'char=)) - :absolute) - ((find #\: string - :start start - :end (or (position #\/ string :start start :end end) - end)) - (let ((posn (position #\: string :start start))) - (prog1 - (subseq string start posn) - (setf start (1+ posn)))))))) - (loop - (unless (and start (> end start)) - (return)) - (let ((next-slash (position #\/ string :start start :end end))) - (cond (next-slash - (push (subseq string start next-slash) directories) - (setf start - (position #\/ string :start next-slash :end end - :test-not #'char=))) - (t - (setf filename (subseq string start end)) - (return))))) - (multiple-value-bind (name type) - (if filename (split-filename filename)) - (values (cond (logical-name logical-name) - (directories "Default")) - (if (or logical-name directories) - (coerce (nreverse directories) 'vector)) - name - type))))) - -(defun parse-namestring (thing &optional host - (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) - "Convert THING (string, symbol, pathname, or stream) into a pathname." - (declare (ignore junk-allowed)) - (let* ((host (or host (pathname-host defaults))) - (pathname - (etypecase thing - ((or string symbol) - (let ((string (coerce (string thing) 'simple-string))) - (multiple-value-bind (device directories name type) - (do-filename-parse string start end) - (unless end (setf end (length string))) - (make-pathname :host host - :device device - :directory directories - :name name - :type type)))) - (pathname - (setf end start) - thing) - (stream - (setf end start) - (pathname (file-name thing)))))) - (unless (or (null host) - (null (pathname-host pathname)) - (string-equal host (pathname-host pathname))) - (cerror "Ignore it." - "Host mismatch in ~S: ~S isn't ~S" - 'parse-namestring - (pathname-host pathname) - host)) - (values pathname end))) - - -(defun pathname (thing) - "Turns thing into a pathname. Thing may be a string, symbol, stream, or - pathname." - (values (parse-namestring thing))) - - - -;;; Merge-Pathnames -- Public -;;; -;;; Returns a new pathname whose fields are the same as the fields in PATHNAME -;;; except that () fields are filled in from defaults. Type and Version field -;;; are only done if name field has to be done (see manual for explanation). -;;; -(defun merge-pathnames (pathname &optional - (defaults *default-pathname-defaults*) - default-version) - "Fills in unspecified slots of Pathname from Defaults (defaults to - *default-pathname-defaults*). If the version remains unspecified, - gets it from Default-Version." - ;; - ;; finish hairy argument defaulting - (setq pathname (pathname pathname)) - (setq defaults (pathname defaults)) - ;; - ;; make a new pathname - (let ((name (%pathname-name pathname)) - (device (%pathname-device pathname))) - (%make-pathname - (or (%pathname-host pathname) (%pathname-host defaults)) - (or device (%pathname-device defaults)) - (or (%pathname-directory pathname) (%pathname-directory defaults)) - (or name (%pathname-name defaults)) - (or (%pathname-type pathname) (%pathname-type defaults)) - (or (%pathname-version pathname) - (if name - default-version - (or (%pathname-version defaults) default-version)))))) - - -;;;; NAMESTRING and other stringification stuff. - -;;; %Dirstring -- Internal -;;; -;;; %Dirstring converts a vector of the form #("foo" "bar" ... "baz") into a -;;; string of the form "foo/bar/ ... /baz/" - -(defun %dirstring (dirlist) - (declare (simple-vector dirlist)) - (let* ((numdirs (length dirlist)) - (length numdirs)) - (declare (fixnum numdirs length)) - (dotimes (i numdirs) - (incf length (the fixnum (length (svref dirlist i))))) - (do ((result (make-string length)) - (index 0 (1+ index)) - (position 0)) - ((= index numdirs) result) - (declare (simple-string result)) - (let* ((string (svref dirlist index)) - (len (length string)) - (end (+ position len))) - (declare (simple-string string) - (fixnum len end)) - (replace result string :start1 position :end1 end :end2 len) - (setf (schar result end) #\/) - (setq position (+ end 1)))))) - -(defun quick-integer-to-string (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) - (%primitive 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)))))) - -(defun %device-string (device) - (cond ((eq device :absolute) "/") - (device - (if (string-equal device "Default") - "" - (concatenate 'simple-string (the simple-string device) ":"))) - (T ""))) - -(defun namestring (pathname) - "Returns the full form of PATHNAME as a string." - (setq pathname (pathname pathname)) - (let* ((directory (%pathname-directory pathname)) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (result (%device-string (%pathname-device pathname)))) - (declare (simple-string result)) - (when directory - (setq result (concatenate 'simple-string result - (the simple-string (%dirstring directory))))) - (when name - (setq result (concatenate 'simple-string result - (the simple-string name)))) - (when (and type (not (zerop (length type)))) - (setq result (concatenate 'simple-string result "." - (the simple-string type)))) - result)) - -(defun %ses-get-useful-name (pathname) - "NAMESTRING of pathname ignoring the device slot." - (setq pathname (pathname pathname)) - (let* ((directory (%pathname-directory pathname)) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (result "")) - (declare (simple-string result)) - (when directory - (setq result (concatenate 'simple-string result - (the simple-string (%dirstring directory))))) - (when name - (setq result (concatenate 'simple-string result - (the simple-string name)))) - (when (and type (not (zerop (length type)))) - (setq result (concatenate 'simple-string result "." - (the simple-string type)))) - result)) - -;;; This function is somewhat bummed to make the Hemlock directory command -;;; is fast. -;;; -(defun file-namestring (pathname) - "Returns the name, type, and version of PATHNAME as a string." - (unless (pathnamep pathname) (setq pathname (pathname pathname))) - (let* ((name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (result (or name ""))) - (declare (simple-string result)) - (if (and type (not (zerop (length type)))) - (concatenate 'simple-string result "." type) - result))) - -(defun directory-namestring (pathname) - "Returns the device & directory parts of PATHNAME as a string." - (setq pathname (pathname pathname)) - (let* ((directory (%pathname-directory pathname)) - (result (%device-string (%pathname-device pathname)))) - (declare (simple-string result)) - (when directory - (setq result (concatenate 'simple-string result - (the simple-string (%dirstring directory))))) - result)) - -(defun host-namestring (pathname) - "Returns the host part of PATHNAME as a string." - (setq pathname (pathname pathname)) - (%pathname-host pathname)) - - - -;;;; ENOUGH-NAMESTRING - -(defun enough-namestring (pathname &optional - (defaults *default-pathname-defaults*)) - "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS." - (setq pathname (pathname pathname)) - (setq defaults (pathname defaults)) - (let* ((device (%pathname-device pathname)) - (directory (%pathname-directory pathname)) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (result "") - (need-name nil)) - (declare (simple-string result)) - (when (and device (string-not-equal device (%pathname-device defaults))) - (setq result (%device-string device))) - (when (and directory - (not (equalp directory (%pathname-directory defaults)))) - (setq result (concatenate 'simple-string result - (the simple-string (%dirstring directory))))) - (when (and name (string-not-equal name (%pathname-name defaults))) - (setq result (concatenate 'simple-string result - (the simple-string name)) - need-name t)) - (when (and type (or need-name - (string-not-equal type (%pathname-type defaults)))) - (setq result (concatenate 'simple-string result "." - (the simple-string type)))) - result)) - - - -;;;; TRUENAME and other stuff probing stuff. - -;;; 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)) - -;;; Do-Search-List -- Internal -;;; -;;; Bind var in turn to each element of search list with the specifed -;;; name. -;;; -(defmacro do-search-list ((var name &optional exit-form) . body) - "Do-Search-List (Var Name [Exit-Form]) {Form}*" - `(dolist (,var (resolve-search-list ,name nil) ,exit-form) - (declare (simple-string ,var)) - ,@body)) - - -;;; Sub-Probe-File -- Internal -;;; -;;; Does the work of Probe-File, returning an additional value which -;;; indicates whether the name is really a file. -;;; -(defun sub-probe-file (pathname) - (setq pathname (pathname pathname)) - (flet ((pathnamify (ns etype) - (declare (simple-string ns)) - (case etype - (:entry_remote - (values (parse-namestring (concatenate 'simple-string ns "/")) - :entry_directory)) - (t - (values (parse-namestring ns) etype))))) - (let ((log-name (or (%pathname-device pathname) "default"))) - (if (eq log-name :absolute) - (let ((namestring (namestring pathname))) - (multiple-value-bind (name etype) - (mach:unix-subtestname namestring) - (if (null name) NIL - (pathnamify name etype)))) - (if (null (%pathname-device pathname)) - (multiple-value-bind (name etype) - (mach:unix-subtestname - (%ses-get-useful-name pathname)) - (if (null name) NIL (pathnamify name etype))) - (let ((namestring (%ses-get-useful-name pathname))) - (do-search-list (entry log-name) - (let ((str (concatenate 'simple-string entry namestring))) - (declare (simple-string str)) - (multiple-value-bind (name etype) - (mach:unix-subtestname str) - (when name - (return (pathnamify name etype)))))))))))) - - -;;; Probe-File -- Public -;;; -;;; Just call Sub-Probe-File and return nil when it isn't a file. -;;; -(defun probe-file (pathname) - "Return a pathname which is the truename of the file if it exists, NIL - otherwise. Returns NIL for directories and other non-file entries." - (multiple-value-bind (pn f) - (sub-probe-file pathname) - (if (eq f :entry_file) pn))) - - - -;;; Predict-Name -- Internal -;;; -;;; Predict-Name is a function used by Open to get an absolute pathname -;;; for a file being opened. Returns the truename of the file and -;;; whether it really exists or not. -;;; -(defun predict-name (file-name for-input) - (let* ((pathname (pathname file-name)) - (device (%pathname-device pathname)) - (truename (probe-file pathname))) - (cond ((eq device :absolute) - (if truename - (values (namestring truename) t) - ;; Try again in case file-name is a directory. - (predict-name-with-subtest (namestring pathname)))) - ((and for-input truename) - (values (namestring truename) t)) - (t - (let ((expansion (resolve-search-list (or device "default") t))) - (let ((name (concatenate 'simple-string (car expansion) - (%ses-get-useful-name pathname)))) - (declare (simple-string name)) - (predict-name-with-subtest name))))))) - -(defun predict-name-with-subtest (name) - (let ((gr (mach:unix-subtestname name))) - (if gr - (values gr t) - (values (mach::simplify-file-name name) nil)))) - - - -;;; Rename-File -- Public -;;; -;;; If File is a File-Stream, then rename the associated file if it exists, -;;; otherwise just change the name in the stream. If not a file stream, then -;;; just rename the file. -;;; -(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." - (if (streamp file) - (let* ((name (file-name file)) - (pn (parse-namestring name)) - (npn (merge-pathnames new-name pn)) - (new (predict-name npn nil))) - (when (mach:quick-subtestname name) - (multiple-value-bind (res err) (mach:Unix-rename name new) - (if (null res) (error "Failed to rename ~A to ~A, unix error: ~A." - name new (mach:get-unix-error-msg err))))) - (file-name file new) - (values npn pn (parse-namestring new))) - (let* ((pn (or (sub-probe-file file) - (error "File to rename does not exist: ~S" file))) - (npn (merge-pathnames new-name pn)) - (new (predict-name npn nil))) - (multiple-value-bind (res err) (mach:unix-rename (namestring pn) new) - (if res (values npn pn (parse-namestring new)) - (error "Failed to rename ~A to ~A, unix error: ~A." - (namestring pn) new (mach:get-unix-error-msg err))))))) - -;;; Delete-File -- Public -;;; -;;; Delete the file, Man. -;;; -(defun delete-file (file) - "Delete the specified file." - (let ((tn (sub-probe-file file))) - (when (streamp file) - (close file :abort t)) - (if tn - (let ((ns (namestring tn))) - (multiple-value-bind (res err) (mach:unix-unlink ns) - (if (null res) - (error "Failed to delete ~A, unix error: ~A." - ns (mach:get-unix-error-msg err))))) - (unless (streamp file) - (error "File to be deleted does not exist: ~S" file)))) - t) - -;;; User-Homedir-Pathname -- Public -;;; -;;; If the user wants a meaningful homedir, she has to define Home:. -;;; Someday, login may do this for us. Since we must always return something, -;;; we just return Default: if it isn't defined. -;;; -(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:\". If this is not defined, - then we return \"default:\"" - (declare (ignore host)) - (let ((home (cdr (assoc :home *environment-list* :test #'eq)))) - (if home - (pathname (if (string-equal home "/") "/" - (concatenate 'simple-string home "/"))) - (let ((expansion (if (search-list "home:") - (resolve-search-list "home" t)))) - (if expansion - (car expansion) - (make-pathname :device "default")))))) - -;;; File-Write-Date -- Public -;;; -(defun file-write-date (file) - "Return file's creation date, or NIL if it doesn't exist." - (let ((tn (sub-probe-file file))) - (when tn - (multiple-value-bind (res dev ino mode nlink uid gid - rdev size atime mtime) - (mach:unix-stat (namestring tn)) - (declare (ignore dev ino mode nlink uid gid rdev size atime)) - (if (null res) 0 - (+ 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 ((filename (truename file))) - (multiple-value-bind (winp dev ino mode nlink uid) - (mach:unix-stat (namestring filename)) - (declare (ignore dev ino mode nlink)) - (if winp (lookup-login-name uid))))) - - - -;;;; DIRECTORY. - -;;; DO-DIRECTORY searches a directory, binding the vars to the name and entry -;;; type. Pattern and All are used in MACH:UNIX-SEARCH-DIRECTORY. -;;; -(defmacro do-directory ((name-var etype-var pattern &optional (all t) result) - . body) - "Do-Directory (Name Entry-Type Pattern [All] [Result]) {Form}*. - If All is non-nil (the default), then Unix dot files to be processed. - Unix dot and dot-dot are never processed." - (let ((file (gensym)) - (res (gensym)) - (type (gensym)) - (p (gensym))) - `(dolist (,file (mach:unix-search-directory ,pattern ,all) - ,result) - (declare (simple-string ,file)) - (let* ((,p (position #\/ ,file :from-end t)) - (,name-var - (if ,p - (subseq ,file (the fixnum (1+ (the fixnum ,p)))) - ,file))) - (declare (simple-string ,name-var)) - (unless (or (string= "." ,name-var) (string= ".." ,name-var)) - (let ((,etype-var (multiple-value-bind (,res ,type) - (mach:quick-subtestname ,file) - (declare (ignore ,res)) - ,type))) - ,@body)))))) - -(defun directory (pathname &key (all 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." - (setq pathname (pathname pathname)) - (multiple-value-bind (dir pattern) (find-directory pathname) - (let ((res ())) - (do-directory (name etype pattern all) - (if (eq etype :entry_file) - (let ((last-dot (position #\. name :from-end t))) - (push - (%make-pathname - "Mach" :absolute dir - (if last-dot (subseq name 0 last-dot) name) - (if last-dot (subseq name (1+ last-dot))) - nil) - res)) - (push - (%make-pathname - "Mach" :absolute - (concatenate 'simple-vector dir (vector name)) - nil nil nil) - res))) - (nreverse res)))) - -;;; FIND-DIRECTORY returns an absolute directory vector for pathname as a -;;; first argument and an absolute namestring. The namestring includes a -;;; trailing asterisk, wildcard, when the given pathname is immediately -;;; probe-able as a directory. -;;; -(defun find-directory (pathname) - (multiple-value-bind (pn type) - (sub-probe-file pathname) - (if pn - (let ((ns (namestring pn))) - (declare (simple-string ns)) - (case type - (:entry_directory - (when (char/= (schar ns (the fixnum (1- (length ns)))) #\/) - (setq ns (concatenate 'simple-string ns "/"))) - (values (%pathname-directory (pathname ns)) - (concatenate 'simple-string ns "*"))) - (t (values (%pathname-directory pn) ns)))) - (multiple-value-bind (pn type) - (sub-probe-file - (make-pathname - :directory (%pathname-directory pathname) - :device (%pathname-device pathname))) - (unless pn - (error "Directory does not exist: ~S" pathname)) - (let ((ns (namestring pn))) - (case type - (:entry_directory - (values - (%pathname-directory pn) - (concatenate 'simple-string ns (file-namestring pathname)))) - (t - (error "~S is not a directory." pathname)))))))) - - - -;;;; Printing directories and determining file owner names. - -;;; 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." - (setf pathname (pathname pathname)) - (let ((*standard-output* (out-synonym-of stream))) - (if verbose - (print-directory-verbose pathname all return-list) - (print-directory-formatted pathname all return-list)))) - -(defun print-directory-verbose (pathname all return-list) - (multiple-value-bind (dir pattern) (find-directory pathname) - (declare (ignore dir)) - (format t "Directory of ~A :~%" pattern) - (let ((dir-name (directory-namestring pattern)) - (result ())) - (do-directory (name etype pattern all (nreverse result)) - (let ((slash-name (if (eq etype :entry_file) - name - (concatenate 'simple-string name "/")))) - (declare (simple-string slash-name)) - (when return-list - (push (pathname (concatenate 'simple-string dir-name slash-name)) - result)) - (multiple-value-bind - (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime) - (mach:unix-stat (concatenate 'simple-string dir-name name)) - (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) - slash-name))) - (t (format t "Couldn't stat ~A -- ~A.~%" - slash-name - (mach:get-unix-error-msg dev-or-err)))))))))) - -(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 ())) - (declare (list names) (fixnum max-len cnt)) - ;; - ;; Get the data. - (multiple-value-bind (dir pattern) (find-directory pathname) - (declare (ignore dir)) - (do-directory (name etype pattern all) - (let* ((slash-name (if (eql etype :entry_file) - name - (concatenate 'simple-string name "/"))) - (len (length slash-name))) - (declare (simple-string slash-name) - (fixnum len)) - (when return-list - (push (pathname (concatenate 'simple-string - (directory-namestring pattern) - slash-name)) - result)) - - (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 :~%" pattern) - (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)) - (tab-over - (- col-width (length (the simple-string name)))))))) - (terpri)))) - (when return-list (nreverse 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)))))))))))) - - - -;;; Complete-One-File -- Internal -;;; -;;; Return as values a string and the greatest common prefix of all -;;; the files corresponding to pattern. -;;; -(defun complete-one-file (pattern default-type ignore-types) - (let ((first nil) - (length nil)) - (do-directory (name etype pattern nil) - (declare (ignore etype)) - (let* ((last-dot (position #\. name :from-end t)) - (type (if last-dot (subseq name (1+ last-dot))))) - (cond ((and (not (string= type default-type)) - (member type ignore-types :test #'string=))) - (first - (let ((msm (string-not-equal name first :end2 length))) - (when (and msm (< msm length)) - (setq length msm)))) - (t - (setq first name) - (setq length (length name)))))) - (values first length))) - - -;;; Complete-File -- Public -;;; -;;; If the pathname is absolute, just call Complete-One-File on and test -;;; whether the result is a file. If a relative pathname, do it on each -;;; directory, accumulating the result. -;;; -(defun complete-file (pathname &key defaults ignore-types) - "Attempt to complete Pathname as the name of a file. If the resulting - completion is unique, return T as the second value. If there is no - possible completion, return both values NIL." - (setq pathname (pathname pathname)) - (setq defaults (if defaults (pathname defaults) *default-pathname-defaults*)) - (flet ((pathnamify (res len ambiguous pathname) - (values - (make-pathname :device (%pathname-device pathname) - :directory (%pathname-directory pathname) - :defaults (parse-namestring (subseq res 0 len))) - (not ambiguous)))) - (let ((dev (or (%pathname-device pathname) "default")) - (default-type (%pathname-type defaults))) - (if (eq dev :absolute) - (multiple-value-bind - (res len) - (complete-one-file (concatenate 'simple-string - (namestring pathname) - "*") - default-type ignore-types) - (declare (fixnum len)) - (if res - (pathnamify res len - (/= (the fixnum (length res)) len) - pathname) - (values nil nil))) - (let ((namestring (%ses-get-useful-name pathname)) - (dirs (if (and (%pathname-directory defaults) - (string-equal dev "default")) - (list (directory-namestring defaults)) - ())) - (max most-positive-fixnum) - (max-str nil) - (ambiguous nil)) - (declare (simple-string namestring)) - (do-search-list (entry dev) - (pushnew entry dirs :test #'string-equal)) - (dolist (entry dirs) - (let ((str (concatenate 'simple-string entry namestring "*"))) - (declare (simple-string str)) - (multiple-value-bind - (res len) - (complete-one-file str default-type ignore-types) - (when res - (unless ambiguous - (setq ambiguous (or max-str (/= (length res) len)))) - (if max-str - (setq max (or (string-not-equal res max-str :end1 len - :end2 max) - max)) - (setq max len max-str res)))))) - (if max-str - (pathnamify max-str max ambiguous pathname) - (values nil 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." - (multiple-value-bind (tn exists) (predict-name name nil) - (if exists - (values (mach:unix-access tn mach:w_ok)) - (values (mach:unix-access (directory-namestring tn) - (logior mach:w_ok mach: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))) - -;;; Ambiguous-Files -- Public -;;; -;;; If the pathname is absolute, just do a directory. If it is relative, -;;; do a directory on each directory in the search-list and merge the results. -;;; -(defun ambiguous-files (pathname &optional 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." - (setq pathname (pathname pathname) - defaults (if defaults (pathname defaults) *default-pathname-defaults*)) - (let ((dev (or (%pathname-device pathname) "default"))) - (if (eq dev :absolute) - (directory (concatenate 'simple-string (namestring pathname) "*")) - (let ((namestring (%ses-get-useful-name pathname)) - (dirs (if (and (%pathname-directory defaults) - (string-equal dev "default")) - (list (directory-namestring defaults)) - ())) - (res ())) - (declare (simple-string namestring)) - (do-search-list (entry dev) (pushnew entry dirs :test #'string-equal)) - (dolist (entry dirs) - (let ((str (concatenate 'simple-string entry namestring "*"))) - (declare (simple-string str)) - (setq res (merge 'list res (directory str) - #'pathname-order)))) - res)))) - -;;; Default-Directory -- Public -;;; -;;; This fills in a hole in Common Lisp. We return the first thing we -;;; find by doing a ResolveSearchList on Default. -;;; -(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) - (mach:unix-current-directory) - (if gr - dir-or-error - (error (mach:get-unix-error-msg dir-or-error))))) - -;;; -;;; Maybe this shouldn't go here... -(defsetf default-directory %set-default-directory) - -;;; %Set-Default-Directory -- Internal -;;; -;;; The setf method for Default-Directory. We actually set the environment -;;; variable Current which is by convention the head of the search list. -;;; -(defun %set-default-directory (new-val) - (multiple-value-bind (gr error) - (mach:unix-chdir (predict-name new-val nil)) - (if gr - (car (setf (search-list "default:") - (cdr (multiple-value-list (mach:unix-current-directory))))) - (error (mach:get-unix-error-msg error))))) diff --git a/code/foreign.lisp b/code/foreign.lisp deleted file mode 100644 index da62b5a32ca81b6b479783a2da7bb7102862e301..0000000000000000000000000000000000000000 --- a/code/foreign.lisp +++ /dev/null @@ -1,281 +0,0 @@ -;;; -*- Log: code.log; Package: Extensions -*- - -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** - -;;; Functions for dealing with foreign function calls in Common Lisp. - -;;; Written by David B. McDonald, January 1987. - -;;; ******************************************************************* -(in-package "EXTENSIONS" :nicknames '("EXT") :use '("LISP" "SYSTEM")) - -(export '(load-foreign get-code-pointer get-data-pointer)) - -(defconstant Unix-OMagic #x107) -(defconstant Unix-NMagic #x108) -(defconstant Unix-ZMagic #x10b) - -(defconstant Unix-header-size 32) -(defconstant Symbol-Table-Entry-Size 12) - -(defconstant n_undf #x0) -(defconstant n_abs #x2) -(defconstant n_text #x4) -(defconstant n_data #x6) -(defconstant n_bss #x8) -(defconstant n_comm #x12) -(defconstant n_fn #x1f) -(defconstant n_ext #x1) - -(defvar file-count 0 - "Number of foreign function files loaded into the current Lisp.") - -(defvar temporary-foreign-files NIL - "List of dotted pairs containing location and size of object code - loaded so that foreign functions can be called.") - -(proclaim '(fixnum file-count)) - -(defstruct unix-ste - (type 0 :type fixnum) - (location 0)) - - -(defvar foreign-symbols (make-hash-table :size 1000 :test #'equal)) - -(defmacro read-cword (sap offset) - `(let ((rsap ,sap) - (roff ,offset)) - (declare (fixnum roff)) - (setq roff (the fixnum (ash roff 1))) - (logior (ash (%primitive 16bit-system-ref rsap roff) 16) - (%primitive 16bit-system-ref rsap (the fixnum (1+ roff)))))) - -(defun read-miscop-free-pointer () - (let ((aa lisp::alloctable-address) - (in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift))) - (declare (fixnum in)) - (logand (+ (logior (%primitive 16bit-system-ref aa (the fixnum (1+ in))) - (ash (%primitive 16bit-system-ref aa in) 16)) 3) - (lognot 3)))) - -(defun write-miscop-free-pointer (value) - (let ((aa lisp::alloctable-address) - (in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift)) - (vl (logand value #xFFFF)) - (vh (logand (ash value -16) #xFFFF))) - (declare (fixnum in)) - (%primitive 16bit-system-set aa (the fixnum (1+ in)) vl) - (%primitive 16bit-system-set aa in vh))) - -;;; Load-foreign accepts a file or a list of files to be loaded into the -;;; currently running Lisp core. These files should be standard object -;;; files created by you favourite compiler (e.g., cc). It accepts two -;;; optional parameters: libraries is a list of libraries to search -;;; for unresolved references (default is the standard C library), and -;;; env which is a list of Unix environment strings (default is what -;;; lisp started with). Load-foreign runs ld creating an object file -;;; that has been linked so that it can be loaded into a predetermined -;;; location in memory. - -(defun load-foreign (files &optional - (libraries '("-lc")) - (linker "/usr/cs/bin/ld") - (base-file "/usr/misc/.lisp/bin/lisp") - (env lisp::original-lisp-environment)) - "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 linker argument is used to specifier - the Unix linker to use to link the object files (the default is - /usr/cs/bin/ld). 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." - (if (null (listp files)) (setq files (list files))) - (format t "[Loading foreign files ~A ...~%" files) - (let ((tfl (if files (format nil "/tmp/L~d.~d" - (mach:unix-getuid) - (the fixnum (+ (the fixnum (mach:unix-getpid)) - file-count))) - base-file)) - (ofl (get-last-loaded-file file-count base-file)) - (addr (read-miscop-free-pointer))) - (when files - (setq file-count (the fixnum (1+ file-count))) - (format t " [Running ld ...") - (force-output t) - (let ((nfiles ())) - (dolist (f files) - (let* ((pn (merge-pathnames f *default-pathname-defaults*)) - (tn (probe-file pn))) - (push (if tn (namestring tn) f) nfiles))) - (setf files (nreverse nfiles))) - (run-program linker `("-N" "-A" ,ofl "-T" - ,(format nil "~X" (+ addr unix-header-size)) - "-o" ,tfl ,@files ,@libraries) - :env env :wait t :output t :error t) - (push tfl temporary-foreign-files) - (format t " done.]~%")) - (multiple-value-bind (res dev ino mode nlnk uid gid rdev len) - (mach:unix-stat tfl) - (declare (ignore ino mode nlnk uid gid rdev)) - (when (null res) - (error "Could not stat intermediate file ~a, unix error: ~A." - tfl (mach:get-unix-error-msg dev))) - (format t " [Reading Unix object file ...") - (force-output t) - (multiple-value-bind (fd err) (mach:unix-open tfl mach:o_rdonly 0) - (when (null fd) - (error "Failed to open intermediate file ~A, unix error: ~A." - (mach:get-unix-error-msg err))) - (multiple-value-bind (bytes err2) - (mach:unix-read fd (int-sap addr) - len) - (when (or (null bytes) (not (eq bytes len))) - (if (null bytes) - (error "Read of intermediate file ~A failed, unix error: ~A" - tfl (mach:get-unix-error-msg err2)) - (error "Read of intermediate file ~A only read ~d of ~d bytes." - tfl bytes len)))) - (mach:unix-close fd))) - (format t " done.]~%") - (let ((fsize (logand (+ (load-object-file tfl addr files) 4) (lognot 3)))) - (when files (write-miscop-free-pointer (+ addr fsize))))) - (format t "done.]~%")) - -;;; Get-last-loaded-file attempts to find the file that was last loaded into -;;; Lisp. If one is found, load-foreign uses it as the bases for the initial -;;; symbol table. Otherwise, it uses the lisp startup code. - -(defun get-last-loaded-file (fc base-file) - (declare (fixnum fc)) - (do ((i (the fixnum (1- fc)) (1- i))) - ((< i 0) base-file) - (declare (fixnum i)) - (let ((tfl (format nil "/tmp/L~d.~d" (mach:unix-getuid) - (the fixnum (+ (the fixnum (mach:unix-getpid)) i))))) - (if (probe-file tfl) (return tfl))))) - -;;; Load-object-file, actually loads the object file created by ld. -;;; It makes sure that it is a legal object file. - -(defun load-object-file (file addr flag) - (format t " [Loading symbol table information ...") - (force-output t) - (let* ((sap (int-sap addr)) - (magic (read-cword sap 0)) - (text-size (read-cword sap 1)) - (idata-size (read-cword sap 2)) - (udata-size (read-cword sap 3)) - (symtab-size (read-cword sap 4)) - (epoint (read-cword sap 5)) - (treloc-size (read-cword sap 6)) - (dreloc-size (read-cword sap 7)) - (load-size (+ text-size idata-size udata-size unix-header-size)) - (symstart (+ text-size idata-size (if flag unix-header-size 2048))) - (strstart (+ symstart (the fixnum symtab-size)))) - (declare (fixnum magic text-size idata-size udata-size - symtab-size symstart strstart treloc-size - dreloc-size) - (ignore epoint)) - (unless (or (null flag) - (and (= magic unix-OMagic) (= treloc-size 0) (= dreloc-size 0))) - (error "File ~A is not a legal Unix object file." file)) - (read-symbol-table (the fixnum (+ (the fixnum sap) symstart)) - symtab-size (the fixnum (+ (the fixnum sap) strstart))) - (setq load-size (logand (the fixnum (+ load-size 8192)) (lognot 8191))) - (do ((ind (truncate (+ text-size idata-size unix-header-size) 2) - (1+ ind)) - (end (truncate udata-size 2))) - ((>= ind end)) - (%primitive 16bit-system-set sap ind 0)) - (format t " done.]~%") - load-size)) - -;;; Read-symbol-table reads the symbol table out of the object, making -;;; external symbols available to Lisp, so that they can be used to -;;; link to the C routines. - -(defun read-symbol-table (symstart symtab-size strstart) - (let ((end (the fixnum (+ (the fixnum symstart) (the fixnum symtab-size))))) - (do* ((se symstart (the fixnum (+ (the fixnum se) symbol-table-entry-size))) - (si (logior (ash (%primitive 16bit-system-ref se 0) 16) - (%primitive 16bit-system-ref se 1)) - (logior (ash (%primitive 16bit-system-ref se 0) 16) - (%primitive 16bit-system-ref se 1))) - (st (%primitive 8bit-system-ref se 4) - (%primitive 8bit-system-ref se 4)) - (sv (logior (ash (%primitive 16bit-system-ref se 4) 16) - (%primitive 16bit-system-ref se 5)) - (logior (ash (%primitive 16bit-system-ref se 4) 16) - (%primitive 16bit-system-ref se 5)))) - ((>= (the fixnum se) (the fixnum end))) - (declare (fixnum st)) - (when (or (= st (logior n_text n_ext)) - (= st (logior n_data n_ext)) - (= st (logior n_bss n_ext))) - (let* ((strend (%primitive find-character strstart si (+ si 512) 0))) - (when (null strend) - (error "Symbol table string didn't terminate.")) - (let ((strlen (the fixnum (- (the fixnum strend) (the fixnum si)))) - (offset 0) - (code NIL) - (str NIL)) - (declare (fixnum strlen offset)) - (when (eq (%primitive 8bit-system-ref strstart si) (char-code #\_)) - (setq offset (the fixnum (1+ offset))) - (when (eq (%primitive 8bit-system-ref strstart - (the fixnum (1+ (the fixnum si)))) - (char-code #\.)) - (setq code T) - (setq offset (the fixnum (1+ offset))))) - (setq str (make-string (the fixnum (- strlen offset)))) - (%primitive byte-blt strstart - (the fixnum (+ (the fixnum si) offset)) str 0 strlen) - (if (let ((x (ash sv (- (+ clc::type-shift-16 16))))) - (not (<= clc::first-pointer-type x clc::last-pointer-type))) - (let ((ste (gethash str foreign-symbols)) - (loc (int-sap sv))) - (cond ((null ste) - (setf (gethash str foreign-symbols) - (make-unix-ste :type (if code - (logior n_text - n_ext) st) - :location (if code nil loc)))) - (code - (setf (unix-ste-type ste) (logior n_text n_ext))) - (T - (setf (unix-ste-location ste) loc))))))))))) - -;;; Get-code-pointer accepts a simple string which should be the name -;;; of a C routine that has already been loaded into the Lisp core image. -;;; This name should use the correct capitalization of the C name without -;;; the default underscore. -(defun get-code-pointer (name) - (let ((ste (gethash name foreign-symbols))) - (when (null ste) - (error "There is no foreign function named ~A loaded." name)) - (when (not (eq (unix-ste-type ste) (logior n_text n_ext))) - (error "~A is a foreign external variable, not a foreign function." name)) - (unix-ste-location ste))) - - -;;; Get-data-pointer is similar to get-code-pointer, except it returns the -;;; address of a foreign global variable. - -(defun get-data-pointer (name) - (let ((ste (gethash name foreign-symbols))) - (when (null ste) - (error "There is no foreign variable named ~A loaded." name)) - (when (eq (unix-ste-type ste) (logior n_text n_ext)) - (error "~A is a foreign function, not a foreign variable." name)) - (unix-ste-location ste))) diff --git a/code/format-time.lisp b/code/format-time.lisp deleted file mode 100644 index e57d2b3716a8bd55269bd949b15dbc79342bf556..0000000000000000000000000000000000000000 --- a/code/format-time.lisp +++ /dev/null @@ -1,186 +0,0 @@ -;;; -*- Mode: Lisp; Package: Extensions; Log: code.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). -;;; ********************************************************************** - -;;; 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 (integerp timezone) (<= 0 timezone 32)) - (error "~A: Timezone should be an integer between 0 and 32." - timezone))) - (multiple-value-bind (secs mins hours day month year dow dst tz) - (decode-universal-time universal-time timezone) - (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 a3d1adfbca63187ac2a13427a94babdaac8e94ef..0000000000000000000000000000000000000000 --- a/code/format.lisp +++ /dev/null @@ -1,1538 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Functions to implement FORMAT for Spice Lisp. -;;; -;;; Original by David Adam. -;;; Re-write by Bill Maddox. -;;; Currently not maintained. -;;; -;;; FORMAT is part of the standard Spice Lisp environment. -;;; -(in-package "LISP") - -(export '(format)) - -;;; Special variables local to FORMAT - -(defvar *format-control-string* "" - "The current FORMAT control string") - -(defvar *format-index* 0 - "The current index into *format-control-string*") - -(defvar *format-length* 0 - "The length of the current FORMAT control string") - -(defvar *format-arguments* () - "Arguments to the current call of FORMAT") - -(defvar *format-original-arguments* () - "Saved arglist from top-level FORMAT call for ~* and ~@*") - -(defvar *format-stream-stack* () - "A stack of string streams for collecting FORMAT output") - -(defvar *format-dispatch-table* () - "Dispatch table for FORMAT commands") - - -;;; Specials imported from PRINT and STREAM - -(proclaim '(special *print-base* *standard-output* *terminal-io*)) - -;;; Specials imported from ERRORFUNS - -(proclaim '(special *error-output*)) - - - -;;;; ERRORS - -;;; Since errors may occur while an indirect control string is being -;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary -;;; in order to indicate the location in the control string where the -;;; error was detected. To this end, errors detected by format are -;;; signalled by throwing a list of the form ((control-string args)) -;;; to the tag FORMAT-ERROR. This throw will be caught at each level -;;; of indirection, and the list of error messages re-thrown with an -;;; additional message indicating that indirection was present CONSed -;;; onto it. Ultimately, the last throw will be caught by the top level -;;; FORMAT function, which will then signal an error to the Lisp error -;;; system in such a way that all the errror messages will be displayed -;;; in reverse order. - -(defun format-error (complaint &rest args) - (throw 'format-error - (list (list "~1{~:}~%~S~%~V@T^" complaint args - *format-control-string* (1+ *format-index*))))) - - - -;;; MACROS - -;;; This macro establishes the correct environment for processing -;;; an indirect control string. CONTROL-STRING is the string to -;;; process, and FORMS are the forms to do the processing. They -;;; invariably will involve a call to SUB-FORMAT. CONTROL-STRING -;;; is guaranteed to be evaluated exactly once. - -(defmacro format-with-control-string (control-string &body forms) - `(let ((string (if (simple-string-p ,control-string) - ,control-string - (coerce ,control-string 'simple-string)))) - (declare (simple-string string)) - (let ((error (catch 'format-error - (let ((*format-control-string* string) - (*format-length* (length string)) - (*format-index* 0)) - (declare (simple-string *format-control-string*) - (fixnum *format-length* *format-index*)) - ,@forms - nil)))) - (when error - (throw 'format-error - (cons (list "While processing indirect control string~%~S~%~V@T^" - *format-control-string* - (1+ *format-index*)) - error)))))) - - -;;;; WITH-FORMAT-PARAMETERS, and other useful macros. -;;; This macro rebinds collects output to the standard output stream -;;; in a string. For efficiency, we avoid consing a new stream on -;;; every call. A stack of string streams is maintained in order to -;;; guarantee re-entrancy. - -(defmacro format-stringify-output (&body forms) - `(let ((*standard-output* - (if *format-stream-stack* - (pop *format-stream-stack*) - (make-string-output-stream)))) - (unwind-protect - (progn ,@forms - (prog1 - (get-output-stream-string *standard-output*) - (push *standard-output* *format-stream-stack*))) - (get-output-stream-string *standard-output*)))) - - - -;;; Pops an argument from the current argument list. This is either the -;;; list of arguments given to the top-level call to FORMAT, or the argument -;;; list for the current iteration in a ~{~} construct. An error is signalled -;;; if the argument list is empty. - -(defmacro pop-format-arg () - '(if *format-arguments* - (pop *format-arguments*) - (format-error "Missing argument"))) - - -;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION. -;;; PARMVAR is the list of parameters. PARMDEFS is a list of lists of the form -;;; (<var> <default>). The FORMS are evaluated in an environment where each -;;; <var> is bound to either the value of the parameter supplied in the -;;; parameter list, or to its <default> value if the parameter was omitted or -;;; explicitly defaulted. - -(defmacro with-format-parameters (parmvar parmdefs &body forms) - (do ((parmdefs parmdefs (cdr parmdefs)) - (bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar)) - ,(cadar parmdefs))) - bindings))) - ((null parmdefs) - `(let ,(nreverse bindings) - (when ,parmvar - (format-error "Too many parameters")) - ,@forms)))) - - - -;;;; Control String Parsing - -;;; The current control string is kept in *format-control-string*. -;;; The variable *format-index* is the position of the last character -;;; processed, indexing from zero. The variable *format-length* is the -;;; length of the control string, which is one greater than the maximum -;;; value of *format-index*. - - -;;; Gets the next character from the current control string. It is an -;;; error if there is none. Leave *format-index* pointing to the -;;; character returned. - -(defmacro nextchar () - '(if (< (the fixnum (incf (the fixnum *format-index*))) - (the fixnum *format-length*)) - (schar *format-control-string* *format-index*) - (format-error "Syntax error"))) - - -;;; Returns the current character, i.e. the one pointed to by *format-index*. - -(defmacro format-peek () - '(schar *format-control-string* *format-index*)) - - -;;; Returns the index of the first occurrence of the specified character -;;; between indices START (inclusive) and END (exclusive) in the control -;;; string. - - -(defmacro format-find-char (char start end) - `(position ,char (the simple-string *format-control-string*) - :start ,start :end ,end :test #'char=)) - - -;;; Attempts to parse a parameter, starting at the current index. -;;; Returns the value of the parameter, or NIL if none is found. -;;; On exit, *format-index* points to the first character which is -;;; not a part of the recognized parameter. - -(defun format-get-parameter () - (case (format-peek) - (#\# (nextchar) (length (the list *format-arguments*))) - ((#\V #\v) (prog1 (pop-format-arg) (nextchar))) - (#\' (prog1 (nextchar) (nextchar))) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (do* ((number (digit-char-p (format-peek)) - (+ (* 10 number) (digit-char-p (format-peek))))) - ((not (digit-char-p (nextchar))) number))) - (#\- - (nextchar) - (case (format-peek) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (do* ((number (digit-char-p (format-peek)) - (+ (* 10 number) (digit-char-p (format-peek))))) - ((not (digit-char-p (nextchar))) (- number)))) - (t (decf (the fixnum *format-index*)) ; put back to out of place "-" - nil))) - (#\+ - (nextchar) - (case (format-peek) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (do* ((number (digit-char-p (format-peek)) - (+ (* 10 number) (digit-char-p (format-peek))))) - ((not (digit-char-p (nextchar))) number))) - (t (decf (the fixnum *format-index*)) ; put back to out of place "-" - nil))) - (t nil))) - - -;;;; Parsing the directives to FORMAT. - -;;; PARSE-FORMAT-OPERATION parses a format directive, including flags and -;;; parameters. On entry, *format-index* should point to the "~" preceding the -;;; command. On exit, *format-index* points to the command character itself. -;;; Returns the list of parameters, the ":" flag, the "@" flag, and the command -;;; character as multiple values. Explicitly defaulted parameters appear in -;;; the list of parameters as NIL. Omitted parameters are simply not included -;;; in the list at all. -;;; -(defmacro parse-format-operation-modifier () - `(let ((temp (format-peek))) - (cond ((char= temp #\:) - (nextchar) - (setf colon-p t)) - ((char= temp #\@) - (nextchar) - (setf atsign-p t))))) -;;; -(defun parse-format-operation () - (let* ((ch (nextchar)) - (parms (if (or (digit-char-p ch) - (member ch '(#\, #\# #\V #\v #\' #\+ #\-) :test #'char=)) - (do ((parms (list (format-get-parameter)) - (cons (format-get-parameter) parms))) - ((char/= (format-peek) #\,) (nreverse parms)) - (declare (list parms)) - (nextchar)) - '())) - colon-p atsign-p) - (parse-format-operation-modifier) - (parse-format-operation-modifier) - (values parms colon-p atsign-p (format-peek)))) - - - -;;; Starting at the current value of *format-index*, finds the first -;;; occurrence of one of the specified directives. Embedded constructs, -;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored. And error is -;;; signalled if no satisfactory command is found. Otherwise, the -;;; following are returned as multiple values: -;;; -;;; The value of *format-index* at the start of the search -;;; The index of the "~" character preceding the command -;;; The parameter list of the command -;;; The ":" flag -;;; The "@" flag -;;; The command character -;;; -;;; Implementation note: The present implementation is not particulary -;;; careful with storage allocation. It would be a good idea to have -;;; a separate function for skipping embedded constructs which did not -;;; bother to cons parameter lists and then throw them away. -;;; -;;; We go to some trouble here to use POSITION for most of the searching. -;;; -;;; Another note: *FORMAT-ARGUMENTS* is let bound here so that we can -;;; guarantee that that list is not changed by FORMAT-FIND-COMMAND. -;;; This is necessary since PARSE-FORMAT-OPERATION (called below) calls -;;; FORMAT-GET-PARAMETER. If the parameter is #\V or #\v then -;;; FORMAT-GET-PARAMETER will pop *FORMAT-ARGUMENTS*. This causes the -;;; argument to be lost when we actually go to do the real formatting. -;;; -(defun format-find-command (command-list) - (let ((start *format-index*) - (*format-arguments* *format-arguments*)) - (do ((place start *format-index*) - (tilde (format-find-char #\~ start *format-length*) - (format-find-char #\~ place *format-length*))) - ((not tilde) - (format-error "Expecting one of ~S" command-list)) - (setq *format-index* tilde) - (multiple-value-bind (parms colon atsign command) - (parse-format-operation) - (when (member command command-list :test #'char=) - (return (values start tilde parms colon atsign command))) - (case command - (#\{ (nextchar)(format-find-command '(#\}))) - (#\< (nextchar)(format-find-command '(#\>))) - (#\( (nextchar)(format-find-command '(#\)))) - (#\[ (nextchar)(format-find-command '(#\]))) - ((#\} #\> #\) #\]) - (format-error "No matching bracket"))))))) - - - -;;;; This is the FORMAT top-level function. - -(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." - - (let ((*format-original-arguments* format-arguments) ;for abs. and rel. goto - (*format-arguments* format-arguments) - (*print-radix* nil) - (*format-control-string* - (if (simple-string-p control-string) - control-string - (coerce control-string 'simple-string)))) - (declare (simple-string *format-control-string*)) - (cond - ((not destination) - (format-stringify-output - (let ((errorp (catch 'format-error - (catch 'format-escape - (catch 'format-colon-escape - (sub-format 0 (length *format-control-string*)))) - nil))) - (when errorp - (error "~%~:{~@?~%~}" (nreverse errorp)))))) - ((and (stringp destination) (array-has-fill-pointer-p destination)) - (with-output-to-string (*standard-output* destination) - (let ((errorp (catch 'format-error - (catch 'format-escape - (catch 'format-colon-escape - (sub-format 0 (length *format-control-string*)))) - nil))) - (when errorp - (error "~%~:{~@?~%~}" (nreverse errorp))) - nil))) - (t - (let ((*standard-output* - (if (or (eq destination 't) - (and (synonym-stream-p destination) - (eq (synonym-stream-symbol destination) - '*standard-output*))) - *standard-output* - destination))) - (let ((errorp (catch 'format-error - (catch 'format-escape - (catch 'format-colon-escape - (sub-format 0 (length *format-control-string*)))) - nil))) - (when errorp - (error "~%~:{~@?~%~}" (nreverse errorp)))) - nil))))) - -;;;; SUB-FORMAT, the real work of FORMAT. - -;;; This function does the real work of format. The segment of the control -;;; string between indiced START (inclusive) and END (exclusive) is processed -;;; as follows: Text not part of a directive is output without further -;;; processing. Directives are parsed along with their parameters and flags, -;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and -;;; PARMS. -;;; -;;; Implementation Note: FORMAT-FIND-CHAR uses the POSITION stream operation -;;; for speed. This is potentially faster than character-at-a-time searching. - -(defun sub-format (start end) - (declare (fixnum start end)) - (let ((*format-index* start) - (*format-length* end)) - (declare (fixnum *format-index* *format-length*)) - (do* ((place start *format-index*) - (tilde (format-find-char #\~ start end) - (format-find-char #\~ place end))) - ((not tilde) - (write-string *format-control-string* *standard-output* - :start place :end end)) - (declare (fixnum place) (type (or fixnum null) tilde)) - (when (> tilde place) - (write-string *format-control-string* *standard-output* - :start place :end tilde)) - (setq *format-index* tilde) - (multiple-value-bind - (parms colon atsign command) - (parse-format-operation) - (let ((cmdfun (svref *format-dispatch-table* (char-code command)))) - (if cmdfun - (funcall cmdfun colon atsign parms) - (format-error "Illegal FORMAT command ~~~S" command)))) - (unless (< (the fixnum (incf (the fixnum *format-index*))) end) - (return))))) - - - -;;;; Conditional case conversion ~( ... ~) - -(defun format-capitalization (colon atsign parms) - (when parms - (format-error "No parameters allowed to ~~(")) - (nextchar) - (multiple-value-bind - (prev tilde end-parms end-colon end-atsign) - (format-find-command '(#\))) - (when (or end-parms end-colon end-atsign) - (format-error "Flags or parameters not allowed")) - (let ((string (format-stringify-output (sub-format prev tilde)))) - (declare (string string)) - (write-string - (cond ((and atsign colon) - (nstring-upcase string)) - (colon - (nstring-capitalize string)) - (atsign - (let ((strlen (length string))) - (declare (fixnum strlen)) - ;; Capitalize the first word only - (nstring-downcase string) - (do ((i 0 (1+ i))) - ((or (<= strlen i) (alpha-char-p (char string i))) - (setf (char string i) (char-upcase (char string i))) - string) - (declare (fixnum i))))) - (t (nstring-downcase string))))))) - - - -;;; Up and Out (Escape) ~^ - -(defun format-escape (colon atsign parms) - (when atsign - (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon)) - (when (if (first parms) - (if (second parms) - (if (third parms) - (typecase (second parms) - (integer - (<= (first parms) (second parms) (third parms))) - (character - (char< (first parms) (second parms) (third parms))) - (t nil)) - (equal (first parms) (second parms))) - (zerop (first parms))) - (not *format-arguments*)) - (throw (if colon 'format-colon-escape 'format-escape) nil))) - - -;;;; Conditional expression ~[ ... ] - - -;;; ~[ - -(defun format-untagged-condition () - (let ((test (pop-format-arg))) - (unless (integerp test) - (format-error "Argument to ~~[ must be integer - ~S" test)) - (do ((count 0 (1+ count))) - ((= count test) - (multiple-value-bind - (prev tilde parms colon atsign cmd) - (format-find-command '(#\; #\])) - (declare (ignore colon)) - (when atsign - (format-error "Atsign flag not allowed")) - (when parms - (format-error "No parameters allowed")) - (sub-format prev tilde) - (unless (char= cmd #\]) - (format-find-command '(#\]))))) - (multiple-value-bind - (prev tilde parms colon atsign cmd) - (format-find-command '(#\; #\])) - (declare (ignore prev tilde)) - (when atsign - (format-error "Atsign flag not allowed")) - (when parms - (format-error "Parameters not allowed")) - (when (char= cmd #\]) (return)) - (when colon - (nextchar) - (multiple-value-bind (prev tilde parms colon atsign cmd) - (format-find-command '(#\; #\])) - (declare (ignore parms colon atsign)) - (sub-format prev tilde) - (unless (char= cmd #\]) - (format-find-command '(#\])))) - (return)) - (nextchar))))) - - -;;; ~@[ - -(defun format-funny-condition () - (multiple-value-bind - (prev tilde parms colon atsign) - (format-find-command '(#\])) - (when (or colon atsign parms) - (format-error "Flags or arguments not allowed")) - (if *format-arguments* - (if (car *format-arguments*) - (sub-format prev tilde) - (pop *format-arguments*)) - (format-error "Missing argument")))) - - -;;; ~:[ - -(defun format-boolean-condition () - (multiple-value-bind - (prev tilde parms colon atsign) - (format-find-command '(#\;)) - (when (or parms colon atsign) - (format-error "Flags or parameters not allowed")) - (nextchar) - (if (pop-format-arg) - (multiple-value-bind - (prev tilde parms colon atsign) - (format-find-command '(#\])) - (when (or colon atsign parms) - (format-error "Flags or parameters not allowed")) - (sub-format prev tilde)) - (progn - (sub-format prev tilde) - (format-find-command '(#\])))))) - - -(defun format-condition (colon atsign parms) - (when parms - (push (pop parms) *format-arguments*) - (unless (null parms) - (format-error "Too many parameters to ~["))) - (nextchar) - (cond (colon - (when atsign - (format-error "~~:@[ undefined")) - (format-boolean-condition)) - (atsign - (format-funny-condition)) - (t (format-untagged-condition)))) - - -;;;; Iteration ~{ ... ~} - -(defun format-iteration (colon atsign parms) - (with-format-parameters parms ((max-iter -1)) - (nextchar) - (multiple-value-bind - (prev tilde end-parms end-colon end-atsign) - (format-find-command '(#\})) - (when (or end-atsign end-parms) - (format-error "Illegal terminator for ~~{")) - (if (= prev tilde) - ;; Use an argument as the control string if ~{~} is empty - (let ((string (pop-format-arg))) - (unless (stringp string) - (format-error "Control string is not a string")) - (format-with-control-string string - (format-do-iteration 0 *format-length* - max-iter colon atsign end-colon))) - (format-do-iteration prev tilde max-iter colon atsign end-colon))))) - - -;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here -;;; to correctly implement ~^ and ~:^. The former aborts only the current -;;; iteration, but the latter aborts the entire iteration process. - -(defun format-do-iteration (start end max-iter colon atsign at-least-once-p) - (catch 'format-colon-escape - (catch 'format-escape - (if atsign - (do* ((count 0 (1+ count))) - ((or (= count max-iter) - (and (null *format-arguments*) - (if (= count 0) (not at-least-once-p) t)))) - (catch 'format-escape - (if colon - (let* ((*format-original-arguments* (pop-format-arg)) - (*format-arguments* *format-original-arguments*)) - (unless (listp *format-arguments*) - (format-error "Argument must be a list")) - (sub-format start end)) - (sub-format start end)))) - (let* ((*format-original-arguments* (pop-format-arg)) - (*format-arguments* *format-original-arguments*)) - (unless (listp *format-arguments*) - (format-error "Argument must be a list")) - (do* ((count 0 (1+ count))) - ((or (= count max-iter) - (and (null *format-arguments*) - (if (= count 0) (not at-least-once-p) t)))) - (catch 'format-escape - (if colon - (let* ((*format-original-arguments* (pop-format-arg)) - (*format-arguments* *format-original-arguments*)) - (unless (listp *format-arguments*) - (format-error "Argument must be a list of lists")) - (sub-format start end)) - (sub-format start end))))))))) - - - -;;;; Justification ~< ... ~> - -;;; Parses a list of clauses delimited by ~; and terminated by ~>. -;;; Recursively invoke SUB-FORMAT to process them, and return a list -;;; of the results, the length of this list, and the total number of -;;; characters in the strings composing the list. - -(defun format-get-trailing-segments () - (nextchar) - (multiple-value-bind - (prev tilde colon atsign parms cmd) - (format-find-command '(#\; #\>)) - (when colon - (format-error "~~:; allowed only after first segment in ~~<")) - (when (or atsign parms) - (format-error "Flags and parameters not allowed")) - (let ((str (catch 'format-escape - (format-stringify-output (sub-format prev tilde))))) - (declare (string str)) - (if str - (if (char= cmd #\;) - (multiple-value-bind - (segments numsegs numchars) - (format-get-trailing-segments) - (values (cons str segments) - (1+ numsegs) (+ numchars (length str)))) - (values (list str) 1 (length str))) - (values () 0 0))))) - - -;;; Gets the first segment, which is treated specially. Call -;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest. - -(defun format-get-segments () - (multiple-value-bind - (prev tilde parms colon atsign cmd) - (format-find-command '(#\; #\>)) - (when atsign - (format-error "Atsign flag not allowed")) - (let ((first-seg (format-stringify-output (sub-format prev tilde)))) - (if (char= cmd #\;) - (multiple-value-bind - (segments numsegs numchars) - (format-get-trailing-segments) - (if colon - (values first-seg parms segments numsegs numchars) - (values nil nil (cons first-seg segments) (1+ numsegs) - (+ (length first-seg) numchars)))) - (values nil nil (list first-seg) 1 (length first-seg)))))) - - - - -;;;; Padding functions for Justification. - -;;; Given the total number of SPACES needed for padding, and the number -;;; of padding segments needed (PADDINGS), returns a list of such segments. -;;; We try to allocate the spaces equally to each segment. When this is -;;; not possible, allocate any left over spaces to the first segment. -;;; -(defun make-pad-segs (spaces padding-segs) - (do* ((extra-space () (and (plusp extra-spaces) - extra-inc - (zerop (rem segs extra-inc)))) - (result () (cons (cond ((= segs 1) (+ min-space extra-spaces)) - (extra-space (1+ min-space)) - (t min-space)) - result)) - (min-space (truncate spaces padding-segs)) - (extra-spaces (- spaces (* padding-segs min-space)) - (if extra-space - (1- extra-spaces) extra-spaces)) - (extra-inc (if (plusp extra-spaces) - (truncate spaces extra-spaces))) - (segs padding-segs (1- segs))) - ((zerop segs) result))) - - -;;; Determine the actual width to be used for a field requiring WIDTH -;;; characters according to the following rule: If WIDTH is less than or -;;; equal to MINCOL, use WIDTH as the actual width. Otherwise, round up -;;; to MINCOL + k * COLINC for the smallest possible positive integer k. -;;; -(defun format-round-columns (width mincol colinc) - (if (> width mincol) - (multiple-value-bind - (quotient remainder) - (floor (- width mincol) colinc) - (+ mincol (* quotient colinc) (if (zerop remainder) 0 colinc))) - mincol)) - - - -(defun format-justification (colon atsign parms) - (with-format-parameters parms - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - (unless (and (integerp mincol) (not (minusp mincol))) - (format-error "Mincol must be a non-negative integer - ~S" mincol)) - (unless (and (integerp colinc) (plusp colinc)) - (format-error "Colinc must be a positive integer - ~S" colinc)) - (unless (and (integerp minpad) (not (minusp minpad))) - (format-error "Minpad must be a non-negative integer - ~S" minpad)) - (unless (characterp padchar) - (format-error "Padchar must be a character - ~S" padchar)) - (nextchar) - (multiple-value-bind - (special-arg special-parms segments numsegs numchars) - (format-get-segments) - (let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0) - (1- numsegs) - (if (and atsign (or (/= numsegs 1) colon)) - 1 0))) - (width (format-round-columns (+ numchars (* minpad padsegs)) - mincol colinc)) - (spaces (append (if (or colon (= numsegs 1)) () '(0)) - (make-pad-segs (- width numchars) padsegs) - (if (and atsign (or (/= numsegs 1) colon)) - () '(0))))) - (when special-arg - (with-format-parameters special-parms ((spare 0) - (linel (or (line-length) 72))) - (let ((pos (or (charpos *standard-output*) 0))) - (when (> (+ pos width spare) linel) - (write-string special-arg))))) - (cond ((and atsign (= numsegs 1) (not colon)) - (write-string (car segments)) - (dotimes (i (car spaces)) (write-char padchar))) - (t - (do ((segs segments (cdr segs)) - (spcs spaces (cdr spcs))) - ((null segs) (dotimes (i (car spcs)) (write-char padchar))) - (dotimes (i (car spcs)) (write-char padchar)) - (write-string (car segs))))))))) - -;;;; Newline ~& - -(defun format-terpri (colon atsign parms) - (when (or colon atsign) - (format-error "Flags not allowed")) - (with-format-parameters parms ((repeat-count 1)) - (dotimes (i repeat-count) (terpri)))) - - -;;; Fresh-line ~% - -(defun format-freshline (colon atsign parms) - (when (or colon atsign) - (format-error "Flags not allowed")) - (with-format-parameters parms ((repeat-count 1)) - (fresh-line) - (dotimes (i (1- repeat-count)) (terpri)))) - - -;;; Page ~| - -(defun format-page (colon atsign parms) - (when (or colon atsign) - (format-error "Flags not allowed")) - (with-format-parameters parms ((repeat-count 1)) - (dotimes (i repeat-count) (write-char #\form)))) - - -;;; Print a tilde ~~ - -(defun format-tilde (colon atsign parms) - (when (or colon atsign) - (format-error "Flags not allowed")) - (with-format-parameters parms ((repeat-count 1)) - (dotimes (i repeat-count) (write-char #\~)))) - - -;;; Continue control string on next line ~<newline> - -(defun format-eat-whitespace () - (nextchar) - (setq *format-index* - (1- (the fixnum - (position-if-not #'(lambda (ch) (or (whitespace-char-p ch) - (char= ch #\linefeed))) - (the simple-string *format-control-string*) - :start *format-index*))))) - - -(defun format-newline (colon atsign parms) - (when parms - (format-error "Parameters not allowed")) - (cond (colon - (when atsign (format-error "~:@<newline> is undefined"))) - (atsign (terpri)(format-eat-whitespace)) - (t (format-eat-whitespace)))) - - -;;;; Pluralize word (~P) and Skip Arguments (~*) - -(defun format-plural (colon atsign parms) - (when parms - (format-error "Parameters not allowed")) - (when colon - ;; Back up one argument first - (let ((cdrs (- (length (the list *format-original-arguments*)) - (length (the list *format-arguments*)) - 1))) - (if (minusp cdrs) - (format-error "No previous argument") - (setq *format-arguments* - (nthcdr cdrs *format-original-arguments*))))) - (if (eql (pop-format-arg) 1) - (write-string (if atsign "y" "")) - (write-string (if atsign "ies" "s")))) - - - -;;; Skip arguments (relative goto) ~* - -(defun format-skip-arguments (colon atsign parms) - (with-format-parameters parms ((count 1)) - (cond (atsign - (when (or (minusp count) - (> count (length *format-original-arguments*))) - (format-error "Illegal to go to non-existant argument")) - (setq *format-arguments* - (nthcdr count *format-original-arguments*))) - (colon - (let ((cdrs (- (length (the list *format-original-arguments*)) - (length (the list *format-arguments*)) - count))) - (if (minusp cdrs) - (format-error "Skip to nonexistant argument") - (setq *format-arguments* - (nthcdr cdrs *format-original-arguments*))))) - (t - (if (> count (length *format-arguments*)) - (format-error "Skip to nonexistant argument") - (setq *format-arguments* (nthcdr count *format-arguments*))))))) - - - -;;;; Indirection ~? - -(defun format-indirection (colon atsign parms) - (if (or colon parms) (format-error "Colon flag or parameters not allowed")) - (let ((string (pop-format-arg))) - (unless (stringp string) - (format-error "Indirected control string is not a string")) - (format-with-control-string string - (if atsign - (sub-format 0 *format-length*) - (let* ((*format-original-arguments* (pop-format-arg)) - (*format-arguments* *format-original-arguments*)) - (unless (listp *format-arguments*) - (format-error "Argument must be a list")) - (sub-format 0 *format-length*)))))) - - - -;;; Tabulation ~T - -(defun format-tab (colon atsign parms) - (with-format-parameters parms ((colnum 1) (colinc 1)) - (when colon - (format-error "Tab-to in pixel units not supported")) - (let* ((pos (charpos *standard-output*)) - (len (cond (pos (let ((col (if atsign (+ pos colnum) colnum))) - (if (> pos col) - (- colinc (rem (- pos col) colinc)) - (- col pos)))) - (atsign colnum) - (t 2)))) - (declare (fixnum len)) - (do ((i len (- i 40))) - ((<= i 40) (write-string " " - *standard-output* :start 0 :end i)) - (declare (fixnum i)) - (write-string " " - *standard-output* - :start 0 - :end 40))))) - -;;;; Ascii ~A - -(defun format-princ (colon atsign parms) - (let ((arg (pop-format-arg))) - (if (null parms) - (if arg (princ arg) (write-string (if colon "()" "NIL"))) - (with-format-parameters parms - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - (format-write-field (if arg - (princ-to-string arg) - (if colon "()" "NIL")) - mincol colinc minpad padchar atsign))))) - - - -;;; S-expression ~S - -(defun format-prin1 (colon atsign parms) - (let ((arg (pop-format-arg))) - (if (null parms) - (if arg (prin1 arg) (write-string (if colon "()" "NIL"))) - (with-format-parameters parms - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - (format-write-field (if arg - (prin1-to-string arg) - (if colon "()" "NIL")) - mincol colinc minpad padchar atsign))))) - - - -;;; Character ~C - -(defun format-print-character (colon atsign parms) - (with-format-parameters parms () - (let ((char (pop-format-arg))) - (unless (characterp char) - (format-error "Argument must be a character")) - (cond ((not colon) - (cond (atsign - (prin1 char)) - ((zerop (char-bits char)) - (write-char char)) - (t - (format-print-named-character char nil)))) - (t - (format-print-named-character char t)))))) - -(defun format-print-named-character (char longp) - (when (char-bit char :control) - (write-string (if longp "Control-" "C-"))) - (when (char-bit char :meta) - (write-string (if longp "Meta-" "M-"))) - (when (char-bit char :super) - (write-string (if longp "Super-" "S-"))) - (when (char-bit char :hyper) - (write-string (if longp "Hyper-" "H-"))) - (let* ((ch (code-char (char-code char))) ;strip funny bits - (name (char-name ch))) - (cond (name (write-string (string-capitalize name))) - ;; Print control characters as "^"<char> - ((<= 0 (the fixnum (char-code char)) 31) - (write-char #\^) - (write-char (code-char (+ 64 (the fixnum (char-code char)))))) - (t (write-char ch))))) - - - - -;;;; NUMERIC PRINTING - -;;; Insert commas after every third digit, scanning from right to left. - -(defun format-add-commas (string commachar) - (do* ((length (length (the string string))) - (new-length (+ length - (the fixnum (floor (the fixnum (1- length)) 3)))) - (new-string (make-string new-length :initial-element commachar) - (replace (the string new-string) - (the string string) - :start1 (max 0 (- new-pos 3)) - :end1 new-pos - :start2 (max 0 (- pos 3)) - :end2 pos)) - (pos length (- pos 3)) - (new-pos new-length (- new-pos 4))) - ((not (plusp pos)) new-string) - (declare (fixnum length new-length pos new-pos)))) - - -;;; Output a string in a field at MINCOL wide, padding with PADCHAR. -;;; Pads on the left if PADLEFT is true, else on the right. If the -;;; length of the string plus the minimum permissible padding, MINPAD, -;;; is greater than MINCOL, the actual field size is rounded up to -;;; MINCOL + k * COLINC for the smallest possible positive integer k. - -(defun format-write-field (string mincol colinc minpad padchar padleft) - (unless (and (integerp mincol) (not (minusp mincol))) - (format-error "Mincol must be a non-negative integer - ~S" mincol)) - (unless (and (integerp colinc) (plusp colinc)) - (format-error "Colinc must be a positive integer - ~S" colinc)) - (unless (and (integerp minpad) (not (minusp minpad))) - (format-error "Minpad must be a non-negative integer - ~S" minpad)) - (unless (characterp padchar) - (format-error "Padchar must be a character - ~S" padchar)) - (let* ((strlen (length (the string string))) - (width (format-round-columns (+ strlen minpad) mincol colinc))) - (cond (padleft - (dotimes (i (- width strlen)) (write-char padchar)) - (write-string string)) - (t - (write-string string) - (dotimes (i (- width strlen)) (write-char padchar)))))) - - -;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing -;;; directives. The parameters are interpreted as defined for ~D. -;;; -(defun format-print-number (number radix print-commas-p print-sign-p parms) - (with-format-parameters parms - ((mincol 0) (padchar #\space) (commachar #\,)) - (let* ((*print-base* radix) - (text (princ-to-string number))) - (if (integerp number) - (format-write-field - (if (and (plusp number) print-sign-p) - (if print-commas-p - (concatenate 'string "+" (format-add-commas text commachar)) - (concatenate 'string "+" text)) - (if print-commas-p - (format-add-commas text commachar) - text)) - mincol 1 0 padchar t) ;colinc = 1, minpad = 0, padleft = t - (write-string text))))) - - -;;;; Print a cardinal number in English - - -;;; The following are initialized in FORMAT-INIT to get around cold-loader -;;; lossage. - -(defvar cardinal-ones () "Table of cardinal ones-place digits in English") - -(defvar cardinal-tens () "Table of cardinal tens-place digits in English") - -(defvar cardinal-teens () "Table of cardinal 'teens' digits in English") - - -(defun format-print-small-cardinal (n) - (multiple-value-bind - (hundreds rem) (truncate n 100) - (when (plusp hundreds) - (write-string (svref cardinal-ones hundreds)) - (write-string " hundred") - (when (plusp rem) (write-char #\space))) ; ; ; RAD - (when (plusp rem) - (multiple-value-bind (tens ones) - (truncate rem 10) - (cond ((< 1 tens) - (write-string (svref cardinal-tens tens)) - (when (plusp ones) - (write-char #\-) - (write-string (svref cardinal-ones ones)))) - ((= tens 1) - (write-string (svref cardinal-teens ones))) - ((plusp ones) - (write-string (svref cardinal-ones ones)))))))) - - -(defvar cardinal-periods () "Table of cardinal 'illions' in English") - - -(defun format-print-cardinal (n) - (cond ((minusp n) - (write-string "negative ") - (format-print-cardinal-aux (- n) 0 n)) - ((zerop n) - (write-string "zero")) - (t (format-print-cardinal-aux n 0 n)))) - -(defun format-print-cardinal-aux (n period err) - (multiple-value-bind (beyond here) (truncate n 1000) - (unless (<= period 10) - (format-error "Number too large to print in English: ~:D" err)) - (unless (zerop beyond) - (format-print-cardinal-aux beyond (1+ period) err)) - (unless (zerop here) - (unless (zerop beyond) (write-char #\space)) - (format-print-small-cardinal here) - (write-string (svref cardinal-periods period))))) - - -;;;; Print an ordinal number in English - - -(defvar ordinal-ones () "Table of ordinal ones-place digits in English") - -(defvar ordinal-tens () "Table of ordinal tens-place digits in English") - - -(defun format-print-ordinal (n) - (when (minusp n) - (write-string "negative ")) - (let ((number (abs n))) - (multiple-value-bind - (top bot) (truncate number 100) - (unless (zerop top) (format-print-cardinal (- number bot))) - (when (and (plusp top) (plusp bot)) (write-char #\space)) - (multiple-value-bind - (tens ones) (truncate bot 10) - (cond ((= bot 12) (write-string "twelfth")) - ((= tens 1) - (write-string (svref cardinal-teens ones));;;RAD - (write-string "th")) - ((and (zerop tens) (plusp ones)) - (write-string (svref ordinal-ones ones))) - ((and (zerop ones)(plusp tens)) - (write-string (svref ordinal-tens tens))) - ((plusp bot) - (write-string (svref cardinal-tens tens)) - (write-char #\-) - (write-string (svref ordinal-ones ones))) - ((plusp number) (write-string "th")) - (t (write-string "zeroeth"))))))) - - -;;; Print Roman numerals - -(defun format-print-old-roman (n) - (unless (< 0 n 5000) - (format-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) (- i cur-val)))) - ((< i cur-val) i)))) - ((zerop start)))) - - -(defun format-print-roman (n) - (unless (< 0 n 4000) - (format-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) (- i cur-val)))) - ((< i cur-val) - (cond ((<= (- cur-val cur-sub-val) i) - (write-char cur-sub-char) - (write-char cur-char) - (- i (- cur-val cur-sub-val))) - (t i)))))) - ((zerop start)))) - - - -;;;; Format Radix Options (~D ~B ~O ~X ~R). - -;;; Decimal ~D - -(defun format-print-decimal (colon atsign parms) - (format-print-number (pop-format-arg) 10 colon atsign parms)) - - -;;; Binary ~B - -(defun format-print-binary (colon atsign parms) - (format-print-number (pop-format-arg) 2 colon atsign parms)) - - -;;; Octal ~O - -(defun format-print-octal (colon atsign parms) - (format-print-number (pop-format-arg) 8 colon atsign parms)) - - -;;; Hexadecimal ~X - -(defun format-print-hexadecimal (colon atsign parms) - (format-print-number (pop-format-arg) 16 colon atsign parms)) - - -;;; Radix ~R - -(defun format-print-radix (colon atsign parms) - (let ((number (pop-format-arg))) - (if parms - (format-print-number number (pop parms) colon atsign parms) - (if atsign - (if colon - (format-print-old-roman number) - (format-print-roman number)) - (if colon - (format-print-ordinal number) - (format-print-cardinal number)))))) - - -;;;; FLOATING-POINT NUMBERS - -;;; Fixed-format floating point ~F -;;; -(defun format-fixed (colon atsign parms) - (when colon - (format-error "Colon flag not allowed")) - (with-format-parameters parms - ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) - ;;Note that the scale factor k defaults to nil. This is interpreted as - ;;zero by flonum-to-string, but more efficiently. - (let ((number (pop-format-arg))) - (if (floatp number) - (format-fixed-aux number w d k ovf pad atsign) - (if (rationalp number) - (format-fixed-aux - (coerce number 'short-float) w d k ovf pad atsign) - (let ((*print-base* 10)) - (format-write-field - (princ-to-string number) w 1 0 #\space t))))))) - - -(defun format-fixed-aux (number w d k ovf pad atsign) - (if (not (or w d)) - (prin1 number) - (let ((spaceleft w)) - (when (and w (or atsign (minusp number))) (decf spaceleft)) - (multiple-value-bind - (str len lpoint tpoint) - (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))) - (t (when w (dotimes (i spaceleft) (write-char pad))) - (if (minusp number) - (write-char #\-) - (if atsign (write-char #\+))) - (when lpoint (write-char #\0)) - (write-string str) - (when tpoint (write-char #\0)))))))) - - -;;;; Exponential-format floating point ~E - - -(defun format-exponential (colon atsign parms) - (when colon - (format-error "Colon flag not allowed")) - (with-format-parameters parms - ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil)) - (let ((number (pop-format-arg))) - (if (floatp number) - (format-exp-aux number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-exp-aux - (coerce number 'short-float) w d e k ovf pad marker atsign) - (let ((*print-base* 10)) - (format-write-field - (princ-to-string number) w 1 0 #\space t))))))) - - -(defun format-exponent-marker (number) - (if (typep number *read-default-float-format*) - #\E - (typecase number - (short-float #\S) -; (single-float #\F) - (double-float #\D) - (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 (number w d e k ovf pad marker atsign) - (if (not (or w d)) - (prin1 number) - (multiple-value-bind (num expt) - (scale-exponent (abs number)) - (let* ((expt (- expt k)) - (estr (princ-to-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 e ovf (> elen e)) - ;;exponent overflow - (dotimes (i w) (write-char ovf)) - (multiple-value-bind (fstr flen lpoint ) ;(tpoint) - (flonum-to-string num spaceleft fdig k fmin) - (when w - (decf spaceleft flen) - ;; (when tpoint (decf spaceleft)) ; deleted as per Rutgers' fix - (when lpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq lpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;significand overflow - (dotimes (i w) (write-char ovf))) - (t (when w - (dotimes (i spaceleft) (write-char pad))) - (if (minusp number) - (write-char #\-) - (if atsign (write-char #\+))) - (when lpoint (write-char #\0)) - (write-string fstr) - ;; (when tpoint (write-char #\0)) ; as per Rutgers' fix - (write-char (if marker - marker - (format-exponent-marker number))) - (write-char (if (minusp expt) #\- #\+)) - (when e - ;;zero-fill before exponent if necessary - (dotimes (i (- e (length estr))) (write-char #\0))) - (write-string estr))))))))) - - - -;;;; General Floating Point - ~G - -(defun format-general-float (colon atsign parms) - (when colon - (format-error "Colon flag not allowed")) - (with-format-parameters parms - ((w nil) (d nil) (e nil) (k nil) (ovf #\*) (pad #\space) (marker nil)) - (let ((number (pop-format-arg))) - ;;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 number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-general-aux - (coerce number 'short-float) w d e k ovf pad marker atsign) - (let ((*print-base* 10)) - (format-write-field - (princ-to-string number) w 1 0 #\space t))))))) - - -(defun format-general-aux (number w d e k ovf pad marker atsign) - (multiple-value-bind (ignore n) - (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) - (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) - (format-fixed-aux number ww dd nil ovf pad atsign) - (dotimes (i ee) (write-char #\space))) - (t (format-exp-aux - number w d e (or k 1) ovf pad marker atsign)))))) - - -;;; Dollars floating-point format ~$ - -(defun format-dollars (colon atsign parms) - (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space)) - (let ((number (pop-format-arg))) - (if (rationalp number) (setq number (coerce number 'short-float))) - (if (floatp number) - (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) - (signlen (length signstr))) - (multiple-value-bind (str strlen ig2 ig3 pointplace) - (flonum-to-string number nil d nil) - (declare (ignore ig2 ig3)) - (when colon (write-string signstr)) - (dotimes (i (- w signlen (- n pointplace) strlen)) - (write-char pad)) - (unless colon (write-string signstr)) - (dotimes (i (- n pointplace)) (write-char #\0)) - (write-string str))) - (let ((*print-base* 10)) - (format-write-field (princ-to-string number) w 1 0 #\space t)))))) - - -;;;; Some stuff for Compiler, MACLISP interaction. - -;;; The following crock simulates some Common Lisp functions in the -;;; cross-compiler's MACLISP environment for the benefit of the hairy -;;; dispatch-table initialization macro. The internal representation -;;; of character objects in the compiler is known to this code. - -#| -(eval-when (compile-maclisp) - - (setq char-code-limit 256) - - (defun char-downcase (char) - (let ((ch (cadr char))) - (if (lessp 64 ch 91) (list '**character** (+ ch 32)) char))) - - (defun char-upcase (char) - (let ((ch (cadr char))) - (if (lessp 96 ch 123) (list '**character** (- ch 32)) char))) - - (defun char= (a b) - (= (cadr a) (cadr b))) - - (defun char< (a b) - (< (cadr a) (cadr b))) - - (defun char-code (char) - (cadr char)) - - (defun code-char (code) - (list '**character** code))) -|# - -;;;; INITIALIZATION - - -;;; Hairy dispatch-table initialization macro. Takes a list of two-element -;;; lists (<character> <function-object>) and returns a vector char-code-limit -;;; elements in length, where the Ith element is the function associated with -;;; the character with char-code I. If the character is case-convertible, it -;;; must be given in only one case; however, an entry in the vector will be -;;; made for both. - - -(defmacro make-dispatch-vector (&body entries) - (let ((entries (mapcan #'(lambda (x) - (let ((lower (char-downcase (car x))) - (upper (char-upcase (car x)))) - (if (char= lower upper) - (list x) - (list (cons upper (cdr x)) - (cons lower (cdr x)))))) - entries))) - (do ((entries (sort entries #'(lambda (x y) (char< (car x) (car y))))) - (charidx 0 (1+ charidx)) - (comtab () (cons (if entries - (if (= (char-code (caar entries)) charidx) - (cadr (pop entries)) - nil) - nil) - comtab))) - ((= charidx char-code-limit) - (if entries - (error "Garbage in dispatch vector - ~S" entries)) - `(vector ,@(nreverse comtab)))))) - - - -;;; These initializations properly belong in the DEFVARs for these objects. -;;; At present, they must be done after loading due to a limitation in the -;;; cold loader. - -(defun format-init () - (setf cardinal-ones - '#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) - (setf cardinal-tens - '#(nil nil "twenty" "thirty" "forty" - "fifty" "sixty" "seventy" "eighty" "ninety")) - (setf cardinal-teens - '#("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD - "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) - (setf cardinal-periods - '#("" " thousand" " million" " billion" " trillion" " quadrillion" - " quintillion" " sextillion" " septillion" " octillion" " nonillion" - " decillion")) - (setf ordinal-ones - '#(nil "first" "second" "third" "fourth" - "fifth" "sixth" "seventh" "eighth" "ninth")) - (setf ordinal-tens - '#(nil "tenth" "twentieth" "thirtieth" "fortieth" - "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) - (setf *format-dispatch-table* - (make-dispatch-vector - (#\B #'format-print-binary) - (#\O #'format-print-octal) - (#\D #'format-print-decimal) - (#\X #'format-print-hexadecimal) - (#\R #'format-print-radix) - (#\F #'format-fixed) - (#\E #'format-exponential) - (#\G #'format-general-float) - (#\A #'format-princ) - (#\C #'format-print-character) - (#\P #'format-plural) - (#\S #'format-prin1) - (#\T #'format-tab) - (#\% #'format-terpri) - (#\& #'format-freshline) - (#\* #'format-skip-arguments) - (#\| #'format-page) - (#\~ #'format-tilde) - (#\$ #'format-dollars) - (#\? #'format-indirection) - (#\^ #'format-escape) - (#\[ #'format-condition) - (#\{ #'format-iteration) - (#\< #'format-justification) - (#\( #'format-capitalization) - (#\newline #'format-newline)))) diff --git a/code/gc.lisp b/code/gc.lisp deleted file mode 100644 index 9622aaf3506a2a3cc251fd3bf228aa01ebbe49ac..0000000000000000000000000000000000000000 --- a/code/gc.lisp +++ /dev/null @@ -1,612 +0,0 @@ -;;; -*- Mode: Lisp; Package: LISP; Log: code.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 (Scott.Fahlman@CS.CMU.EDU). -;;; ********************************************************************** -;;; -;;; Garbage collection and allocation related code. -;;; -;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al. -;;; - -(in-package "EXTENSIONS") -(export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off - *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook* - *gc-notify-before* *gc-notify-after* get-bytes-consed)) - -(in-package "LISP") -(export '(room)) - - - -;;;; Room. - -(defvar alloctable-address (int-sap %fixnum-alloctable-address) - "A system area pointer that addresses the the alloctable.") - -(defun alloc-ref (index) - (logior (%primitive 16bit-system-ref alloctable-address (1+ index)) - (ash (logand %type-space-mask - (%primitive 16bit-system-ref alloctable-address index)) - 16))) - -(defun space-usage (type) - (let ((base (ash type %alloc-ref-type-shift))) - (values (alloc-ref base) - (alloc-ref (+ base 8)) - (alloc-ref (+ base 12))))) - -(defconstant type-space-names - '#("Bignum" "Ratio" "Complex" "Short-Float" "Short-Float" "Long-Float" - "String" "Bit-Vector" "Integer-Vector" "Code-Vector" "General-Vector" - "Array" "Function" "Symbol" "List")) - -(defun room-header () - (fresh-line) - (princ " Type | Dynamic | Static | Read-Only | Total") - (terpri) - (princ "-------------------|-----------|-----------|-----------|-----------") - (terpri)) - -(defun room-summary (dynamic static read-only) - (princ "-------------------|-----------|-----------|-----------|-----------") - (format t "~% Totals: |~10:D |~10:D |~10:D =~10:D~%" - dynamic static read-only (+ static dynamic read-only))) - -(defun describe-one-type (type dynamic static read-only) - (declare (fixnum type dynamic static read-only)) - (format t "~18A |~10:D |~10:D |~10:D |~10:D~%" - (elt (the simple-vector type-space-names) - (the fixnum (- type (the fixnum %first-pointer-type)))) - dynamic static read-only (the fixnum (+ static dynamic read-only)))) - -(defun room (&optional (x t) (object nil argp)) - "Displays information about storage allocation. - If X is true then information is displayed broken down by types. - If Object is supplied then just display information for objects of - that type." - (when x - (let ((type (%primitive get-type object))) - (when (or (> type %last-pointer-type) - (< type %first-pointer-type)) - (error "Objects of type ~S have no allocated storage." - (type-of object))) - (room-header) - (cond - (argp - (multiple-value-bind (dyn stat ro) - (space-usage type) - (describe-one-type type dyn stat ro))) - (t - (let ((cum-dyn 0) - (cum-stat 0) - (cum-ro 0)) - (do ((type %first-pointer-type (1+ type))) - ((= type (1+ %last-pointer-type))) - (if (not (or (eq type %short-+-float-type) - (eq type %short---float-type))) - (multiple-value-bind (dyn stat ro) - (space-usage type) - (describe-one-type type dyn stat ro) - (incf cum-dyn dyn) (incf cum-stat stat) (incf cum-ro ro)))) - (room-summary cum-dyn cum-stat cum-ro))))))) - - -;;;; DYNAMIC-USAGE. - -;;; -;;; DYNAMIC-USAGE -- Interface -;;; -;;; Return the number of bytes of dynamic storage allocated. -;;; -(defun dynamic-usage () - "Returns the number of bytes of dynamic storage currently allocated." - (system:%primitive dynamic-space-in-use)) - - -;;;; GET-BYTES-CONSED. - -;;; -;;; Internal State -;;; -(defvar *last-bytes-in-use* nil) -(defvar *total-bytes-consed* 0) - -;;; -;;; GET-BYTES-CONSED -- Exported -;;; -(defun get-bytes-consed () - "Returns the number of bytes consed since the first time this function - was called. The first time it is called, it returns zero." - (cond ((null *last-bytes-in-use*) - (setq *last-bytes-in-use* (dynamic-usage)) - (setq *total-bytes-consed* 0)) - (t - (let ((bytes (dynamic-usage))) - (incf *total-bytes-consed* (- bytes *last-bytes-in-use*)) - (setq *last-bytes-in-use* bytes)))) - *total-bytes-consed*) - - -;;;; Variables and Constants. - -;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*. -;;; -(defconstant default-bytes-consed-between-gcs 2000000) - -;;; This variable is the user-settable variable that specifices the -;;; minimum amount of dynamic space which must be consed before a GC -;;; will be triggered. -;;; -(defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs - "This number specifies the minimum number of bytes of dynamic space - that must be consed before the next gc will occur.") - -;;; Internal trigger. When the dynamic usage increases beyond this -;;; amount, the system notes that a garbage collection needs to occur by -;;; setting *NEED-TO-COLLECT-GARBAGE* to T. -;;; -(defvar *gc-trigger* default-bytes-consed-between-gcs) - - - -;;; -;;; The following specials are used to control when garbage collection -;;; occurs. -;;; - -;;; -;;; *GC-INHIBIT* -;;; -;;; When non-NIL, inhibits garbage collection. -;;; -(defvar *gc-inhibit* nil) - -;;; -;;; *ALREADY-MAYBE-GCING* -;;; -;;; This flag is used to prevent recursive entry into the garbage -;;; collector. -;;; -(defvar *already-maybe-gcing* nil) - -;;; When T, indicates that the dynamic usage has exceeded the value -;;; *GC-TRIGGER*. -;;; -(defvar *need-to-collect-garbage* nil) - - -;;;; GC Hooks. - -;;; -;;; *BEFORE-GC-HOOKS* -;;; *AFTER-GC-HOOKS* -;;; -;;; These variables are a list of functions which are run before and -;;; after garbage collection occurs. -;;; -(defvar *before-gc-hooks* nil - "A list of functions that are called before garbage collection occurs. - The functions should take no arguments.") -;;; -(defvar *after-gc-hooks* nil - "A list of functions that are called after garbage collection occurs. - The functions should take no arguments.") - -;;; -;;; *GC-INHIBIT-HOOK* -;;; -;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC -;;; was explicitly forced by calling EXT:GC). If the hook function -;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and -;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T. -;;; Presumably someone will call GC-ON later to collect the garbage. -;;; -(defvar *gc-inhibit-hook* nil - "Should be bound to a function or NIL. If it is a function, this - function should take one argument, the current amount of dynamic - usage. The function should return NIL if garbage collection should - continue and non-NIL if it should be inhibited. Use with caution.") - - - -;;; -;;; *GC-VERBOSE* -;;; -(defvar *gc-verbose* t - "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and - *GC-NOTIFY-AFTER* to be called before and after a garbage collection - occurs respectively.") - - -(defun default-gc-notify-before (bytes-in-use) - (system:beep *standard-output*) - (format t "~&[GC threshold exceeded with ~:D bytes in use. ~ - Commencing GC.]~%" bytes-in-use) - (finish-output)) -;;; -(defparameter *gc-notify-before* #'default-gc-notify-before - "This function bound to this variable is invoked before GC'ing (unless - *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in - bytes). It should notify the user that the system is going to GC.") - -(defun default-gc-notify-after (bytes-retained bytes-freed new-trigger) - (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%" - bytes-retained bytes-freed) - (format t "[GC will next occur when at least ~:D bytes are in use.]~%" - new-trigger) - (system:beep *standard-output*) - (finish-output)) -;;; -(defparameter *gc-notify-after* #'default-gc-notify-after - "The function bound to this variable is invoked after GC'ing (unless - *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now - free, the number of bytes freed by the GC, and the new GC trigger - threshold. The function should notify the user that the system has - finished GC'ing.") - - -;;;; Stack grovelling: - -;;; VECTOR-ALLOC-END -- Internal -;;; -;;; Return a pointer to past the end of the memory allocated for a -;;; vector-like object. -;;; -(defun vector-alloc-end (vec) - (%primitive pointer+ - vec - (* (%primitive vector-word-length vec) %word-size))) - - -(defvar *gc-debug* nil) - -;;; PRINT-RAW-ADDR -- Interface -;;; -;;; Print the full address of an arbitary object. -;;; -(defun print-raw-addr (x &optional (stream *standard-output*)) - (let ((fix (%primitive make-fixnum x))) - (format stream "~4,'0X~4,'0X " - (logior (ash (%primitive get-type x) 11) - (ash (%primitive get-space x) 9) - (ash fix -16)) - (logand fix #xFFFF)))) - - -;;; GC-GROVEL-STACK -- Internal -;;; -;;; Locate all raw pointers on stack stack, and clobber them with something -;;; that won't cause GC to gag. We return a list of lists of the form: -;;; (object offset stack-location*), -;;; -;;; where Object is some valid vector-like object pointer and Offset is an -;;; offset to be added to Object. The result of this addition should be stored -;;; into each Stack-Location after GC completes. We clobber the stack -;;; locations with Offset for no particular reason (might aid debugging.) -;;; -;;; There are three major steps in the algorithm: -;;; -;;; 1] Find all the distinct vector-like pointers on the stack, building a -;;; list of all the locations that each pointer is stored in. We do this -;;; using two hash-tables: the one for code pointers is separate, since -;;; they must be special-cased. -;;; -;;; Note that we do our scan downward from the current CONT, and thus don't -;;; scan our own frame. We don't want to modify the frame for the running -;;; function, as this is apt to cause problems. It isn't necessary to -;;; grovel the current frame because we return before GC happens. -;;; -;;; 2] Sort all of the vector-like pointers (other than code vectors), and -;;; scan through this list finding raw pointers based on the assumption -;;; that we will always see the true pointer to the vector header before -;;; any raw pointers into that vector. This exploits our GC invariant that -;;; when an indexing temp is in use, the true object pointer must be live -;;; on the stack or in a register. [By now, any register indexing temp -;;; will have been saved on the stack.] -;;; -;;; During this scan, we also note any true vector pointers that point to a -;;; function object. -;;; -;;; Whenever we locate a raw vector pointer, we create a fixup for the -;;; locations holding that pointer and then clobber the locations. -;;; -;;; 3] Iterate over all code pointers, clobbering the locations and -;;; making fixups for those pointers that point inside some function object -;;; that appears on the stack. This exploits our GC invariant that a -;;; *valid* code pointer only appears on the stack when some containing -;;; function object also appears on the stack. Note that *invalid* code -;;; pointers may appear in the stack garbage unaccompanied by any function -;;; object. Such isolated code pointers are set to 0. (Code pointers in -;;; the heap must always point to the code vector header, and are always -;;; considered valid.) -;;; -;;; This different invariant for code pointers allows us to throw around -;;; raw code pointers without clearing them when they are no longer needed. -;;; -(defun gc-grovel-stack () - (let ((vec-table (make-hash-table :test #'eq)) - (code-table (make-hash-table :test #'eq)) - (base (%primitive make-immediate-type 0 %control-stack-type)) - (fixups ())) - ;; - ;; Find all vector-like objects on the stack, putting code vectors in a - ;; separate table. (step 1) - (do ((sp (%primitive pointer+ (%primitive current-fp) - (- %stack-increment)) - (%primitive pointer+ sp (- %stack-increment)))) - ((%primitive pointer< sp base)) - (let* ((el (%primitive read-control-stack sp)) - (el-type (%primitive get-type el))) - - (when (and *gc-debug* (simple-vector-p el)) - (let ((hdr (%primitive read-control-stack el))) - (unless (and (fixnump hdr) (> hdr 0) - (<= (length el) #xFFFF) - (<= (%primitive get-vector-subtype el) - 3)) - (format t "Suspicious G-vector ") - (print-raw-addr el) - (format t "at ") - (print-raw-addr sp) - (terpri)))) - - (when (and (< (%primitive get-space el) %static-space) - (<= %string-type el-type %function-type)) - (push sp (gethash el - (if (eq el-type %code-type) - code-table - vec-table)))))) - - (let ((vecs ()) - (functions ())) - (maphash #'(lambda (k v) - (declare (ignore v)) - (push k vecs)) - vec-table) - - (setq vecs - (sort vecs - #'(lambda (x y) - (%primitive pointer< x y)))) - - ;; - ;; Iterate over non-code vector-like pointers in order (step 2.) - (loop - (unless vecs (return)) - (let* ((base (pop vecs)) - (end (vector-alloc-end base))) - - (when (and (= (%primitive get-type base) %function-type) - (<= %function-entry-subtype - (%primitive get-vector-subtype base) - %function-constants-subtype)) - (push base functions)) - - (loop - (unless vecs (return)) - (let ((next (first vecs))) - (unless (%primitive pointer< next end) (return)) - (pop vecs) - - (let ((offset (%primitive pointer- next base)) - (sps (gethash next vec-table))) - (dolist (sp sps) - (%primitive write-control-stack sp offset)) - (push (list* base offset sps) fixups)))))) - - ;; - ;; Iterate over all code pointers (step 3.) - (maphash #'(lambda (code-ptr sps) - (dolist (fun functions - (dolist (sp sps) - (%primitive write-control-stack sp 0))) - (let* ((base (%primitive header-ref fun - %function-code-slot)) - (end (vector-alloc-end base))) - (when (and (not (%primitive pointer< code-ptr base)) - (%primitive pointer< code-ptr end)) - (let ((offset (%primitive pointer- code-ptr base))) - (dolist (sp sps) - (%primitive write-control-stack sp offset)) - (push (list* base offset sps) fixups)) - (return))))) - code-table) - - (when *gc-debug* - (dolist (f fixups) - (terpri) - (print-raw-addr (first f)) - (format t "~X " (second f)) - (dolist (sp (cddr f)) - (print-raw-addr sp))) - (terpri)) - - fixups))) - - -;;; GC-FIXUP-STACK -- Internal -;;; -;;; Given a list of GC fixups as returned by GC-GROVEL-STACK, fix up all the -;;; raw pointers on the stack. -;;; -(defun gc-fixup-stack (fixups) - (dolist (fixup fixups) - (let ((new (%primitive pointer+ (first fixup) (second fixup)))) - (dolist (sp (cddr fixup)) - (%primitive write-control-stack sp new))))) - - -;;;; Internal GC - -;;; %GC -- Internal -;;; -;;; %GC is the real garbage collector. What we do: -;;; -- Call GC-GROVEL-STACK to locate any raw pointers on the stack. -;;; -- Invoke the COLLECT-GARBAGE miscop, adding the amount of garbage -;;; collected to *total-bytes-consed*. -;;; -- Invalidate & revalidate the old spaces to free up their memory. -;;; -- Call GC-FIXUP-STACK to restore raw pointers on the stack. -;;; -;;; *** Warning: the stack *including the current frame* is in a somewhat -;;; altered state until after GC-FIXUP-STACK is called. Don't change a single -;;; character from the start of this function until after call to -;;; GC-FIXUP-STACK unless you really know what you are doing. -;;; -;;; It is important that we not do anything that creates raw pointers between -;;; the time we call GC-GROVEL-STACK and the time we invoke COLLECT-GARBAGE. -;;; In particular, this means no function calls. All raw pointers on the stack -;;; have been trashed, so we cannot use any raw pointers until they have been -;;; regenerated. In particular, we cannot return from this function, since the -;;; return PC is a raw pointer. -;;; -;;; We also can't expect the value of any variables allocated between the -;;; grovel and fixup to persist after the fixup, since the value that variable -;;; held at grovel time may have been a pointer that needed to be fixed. -;;; -(defun %gc () - (let* ((oldspace-base (ash (%primitive newspace-bit) 25)) - (old-bytes (system:%primitive dynamic-space-in-use)) - (result nil) - (fixups (gc-grovel-stack))) - (%primitive clear-registers) - (setq result (%primitive collect-garbage)) - (let ((new-bytes (system:%primitive dynamic-space-in-use))) - (when *last-bytes-in-use* - (incf *total-bytes-consed* (- old-bytes *last-bytes-in-use*)) - (setq *last-bytes-in-use* new-bytes))) - (gc-fixup-stack fixups) - (do* ((i %first-pointer-type (1+ i)) - (this-space (logior oldspace-base (ash i 27)) - (logior oldspace-base (ash i 27))) - (losing-gr nil)) - ((= i (1+ %last-pointer-type)) - (when losing-gr - (system:gr-error "While reclaiming VM" losing-gr))) - (let ((gr (mach:vm_deallocate *task-self* this-space - (- #x2000000 8192)))) - (unless (eql gr mach:kern-success) (setq losing-gr gr))) - (let ((gr (mach:vm_allocate *task-self* this-space - (- #x2000000 8192) nil))) - (unless (eql gr mach:kern-success) (setq losing-gr gr)))) - result)) - -;;; -;;; *INTERNAL-GC* -;;; -;;; This variables contains the function that does the real GC. This is -;;; for low-level GC experimentation. Do not touch it if you do not -;;; know what you are doing. -;;; -(defvar *internal-gc* #'%gc) - - -;;;; SUB-GC - -;;; -;;; CAREFULLY-FUNCALL -- Internal -;;; -;;; Used to carefully invoke hooks. -;;; -(defmacro carefully-funcall (function &rest args) - `(handler-case (funcall ,function ,@args) - (error (cond) - (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond) - nil))) - -;;; -;;; SUB-GC -- Internal -;;; -;;; SUB-GC decides when and if to do a garbage collection. The -;;; VERBOSE-P flag controls whether or not the notify functions are -;;; called. The FORCE-P flags controls if a GC should occur even if the -;;; dynamic usage is not greater than *GC-TRIGGER*. -;;; -(defun sub-gc (verbose-p force-p) - (unless *already-maybe-gcing* - (let* ((*already-maybe-gcing* t) - (pre-gc-dyn-usage (dynamic-usage))) - (unless (integerp *bytes-consed-between-gcs*) - (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~ - integer. Reseting it to 2000000" *bytes-consed-between-gcs*) - (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs)) - (when (> *bytes-consed-between-gcs* *gc-trigger*) - (setf *gc-trigger* *bytes-consed-between-gcs*)) - (when (> pre-gc-dyn-usage *gc-trigger*) - (setf *need-to-collect-garbage* t)) - (when (or force-p - (and *need-to-collect-garbage* (not *gc-inhibit*))) - (setf *gc-inhibit* t) ; Set *GC-INHIBIT* to T before calling the hook - (when (and (not force-p) - *gc-inhibit-hook* - (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage)) - (return-from sub-gc nil)) - (setf *gc-inhibit* nil) ; Reset *GC-INHIBIT* - (multiple-value-bind - (winp old-mask) - (mach:unix-sigsetmask lockout-interrupts) - (unwind-protect - (progn - (unless winp (warn "Could not set sigmask!")) - (let ((*standard-output* *terminal-io*)) - (when verbose-p - (carefully-funcall *gc-notify-before* pre-gc-dyn-usage)) - (dolist (hook *before-gc-hooks*) - (carefully-funcall hook)) - (funcall *internal-gc*) - (let* ((post-gc-dyn-usage (dynamic-usage)) - (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage))) - (setf *need-to-collect-garbage* nil) - (setf *gc-trigger* - (+ post-gc-dyn-usage *bytes-consed-between-gcs*)) - (dolist (hook *after-gc-hooks*) - (carefully-funcall hook)) - (when verbose-p - (carefully-funcall *gc-notify-after* - post-gc-dyn-usage bytes-freed - *gc-trigger*))))) - (when winp - (unless (values (mach:unix-sigsetmask old-mask)) - (warn "Could not restore sigmask!")))))))) - nil) - -;;; -;;; MAYBE-GC -- Internal -;;; -;;; This routine is called by the allocation miscops to decide if a GC -;;; should occur. The argument, object, is the newly allocated object -;;; which must be returned to the caller. -;;; -(defun maybe-gc (object) - (sub-gc *gc-verbose* nil) - object) - -;;; -;;; GC -- Exported -;;; -;;; This is the user advertised garbage collection function. -;;; -(defun gc (&optional (verbose-p *gc-verbose*)) - "Initiates a garbage collection. The optional argument, VERBOSE-P, - which defaults to the value of the variable *GC-VERBOSE* controls - whether or not GC statistics are printed." - (sub-gc verbose-p t)) - - -;;;; Auxiliary Functions. - -(defun gc-on () - "Enables the garbage collector." - (setq *gc-inhibit* nil) - (when *need-to-collect-garbage* - (sub-gc *gc-verbose* nil)) - nil) - -(defun gc-off () - "Disables the garbage collector." - (setq *gc-inhibit* t) - nil) diff --git a/code/globals.lisp b/code/globals.lisp deleted file mode 100644 index 5712d2fb6aab5aa06f4f54397a8fedd4f952e3ea..0000000000000000000000000000000000000000 --- a/code/globals.lisp +++ /dev/null @@ -1,58 +0,0 @@ -;;; -*- Package: Lisp; Log: code.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 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* *file-input-handlers* - *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* - mach::*free-trap-arg-blocks* conditions::*handler-clusters* - conditions::*restart-clusters* - alloctable-address ext::*c-type-names* *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* - - ;; hack to get these args to with-trap-arg-block to work in - ;; the bootstrapping env, since the var must be known to be - ;; special, in addition to being known to be an alien var. - mach::timeval mach::timezone mach::int1 mach::int2 - mach::int3 mach::tchars mach::ltchars)) - - -(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/hash.lisp b/code/hash.lisp deleted file mode 100644 index da755ecfa84fd6aa535ede7fb839836732787c8b..0000000000000000000000000000000000000000 --- a/code/hash.lisp +++ /dev/null @@ -1,442 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hashing and hash table functions for Spice Lisp. -;;; Written by Skef Wholey. -;;; -(in-package 'lisp) -(export '(hash-table hash-table-p make-hash-table - gethash remhash maphash clrhash - hash-table-count sxhash)) - -;;; Vector subtype codes. - -(defconstant valid-hashing 2) -(defconstant must-rehash 3) - - -;;; What a hash-table is: - -(defstruct (hash-table (:constructor make-hash-table-structure) - (:conc-name hash-table-) - (:print-function %print-hash-table)) - "Structure used to implement hash tables." - (kind 'eq) - (size 65 :type fixnum) - (rehash-size 101) ; might be a float - (rehash-threshold 57 :type fixnum) - (number-entries 0 :type fixnum) - (table () :type simple-vector)) - -;;; A hash-table-table is a vector of association lists. When an -;;; entry is made in a hash table, a pair of (key . value) is consed onto -;;; the element in the vector arrived at by hashing. - -;;; How to print one: - -(defun %print-hash-table (structure stream depth) - (declare (ignore depth)) - (format stream "#<~A Hash Table {~X}>" - (symbol-name (hash-table-kind structure)) - (system:%primitive lisp::make-fixnum structure))) - - - -;;; Hashing functions for the three kinds of hash tables: - -(eval-when (compile) - -(defmacro eq-hash (object) - "Gives us a hashing of an object such that (eq a b) implies - (= (eq-hash a) (eq-hash b))" - `(%primitive make-fixnum ,object)) - -(defmacro eql-hash (object) - "Gives us a hashing of an object such that (eql a b) implies - (= (eql-hash a) (eql-hash b))" - `(if (numberp ,object) - (logand (truncate ,object) most-positive-fixnum) - (%primitive make-fixnum ,object))) - -(defmacro equal-hash (object) - "Gives us a hashing of an object such that (equal a b) implies - (= (equal-hash a) (equal-hash b))" - `(sxhash ,object)) - -) - -;;; Rehashing functions: - -(defun almost-primify (num) - (declare (fixnum num)) - "Almost-Primify returns an almost prime number greater than or equal - to NUM." - (if (= (rem num 2) 0) - (setq num (+ 1 num))) - (if (= (rem num 3) 0) - (setq num (+ 2 num))) - (if (= (rem num 7) 0) - (setq num (+ 4 num))) - num) - -(eval-when (compile) - -(defmacro grow-size (table) - "Returns a fixnum for the next size of a growing hash-table." - `(let ((rehash-size (hash-table-rehash-size ,table))) - (if (floatp rehash-size) - (ceiling (* rehash-size (hash-table-size ,table))) - (+ rehash-size (hash-table-size ,table))))) - -(defmacro grow-rehash-threshold (table new-length) - "Returns the next rehash threshold for the table." - table - `,new-length -; `(ceiling (* (hash-table-rehash-threshold ,table) -; (/ ,new-length (hash-table-size ,table)))) - ) - -(defmacro hash-set (vector key value length hashing-function) - "Used for rehashing. Enters the value for the key into the vector - by hashing. Never grows the vector. Assumes the key is not yet - entered." - `(let ((index (rem (the fixnum (funcall ,hashing-function ,key)) - (the fixnum ,length)))) - (declare (fixnum index)) - (setf (aref (the simple-vector ,vector) index) - (cons (cons ,key ,value) - (aref (the simple-vector ,vector) index))))) - -) - -(defun rehash (structure hash-vector new-length) - (declare (simple-vector hash-vector)) - (declare (fixnum new-length)) - "Rehashes a hash table and replaces the TABLE entry in the structure if - someone hasn't done so already. New vector is of NEW-LENGTH." - (do ((new-vector (make-array new-length)) - (i 0 (1+ i)) - (size (hash-table-size structure)) - (hashing-function (case (hash-table-kind structure) - (eq #'(lambda (x) (eq-hash x))) - (eql #'(lambda (x) (eql-hash x))) - (equal #'(lambda (x) (equal-hash x)))))) - ((= i size) - (cond ((eq hash-vector (hash-table-table structure)) - (cond ((> new-length size) - (setf (hash-table-table structure) new-vector) - (setf (hash-table-rehash-threshold structure) - (grow-rehash-threshold structure new-length)) - (setf (hash-table-size structure) new-length)) - (t - (setf (hash-table-table structure) new-vector))) - (if (not (eq (hash-table-kind structure) 'equal)) - (%primitive set-vector-subtype new-vector - valid-hashing))))) - (declare (fixnum i size)) - (do ((bucket (aref hash-vector i) (cdr bucket))) - ((null bucket)) - (hash-set new-vector (caar bucket) (cdar bucket) new-length - hashing-function)) - (setf (aref hash-vector i) nil))) - -;;; Macros for Gethash, %Puthash, and Remhash: - -(eval-when (compile) - -;;; Hashop dispatches on the kind of hash table we've got, rehashes if -;;; necessary, and binds Vector to the hash vector, Index to the index -;;; into that vector that the Key points to, and Size to the size of the -;;; hash vector. Since Equal hash tables only need to be maybe rehashed -;;; sometimes, one can tell it if it's one of those times with the -;;; Equal-Needs-To-Rehash-P argument. - -(defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body) - `(let* ((vector (hash-table-table hash-table)) - (size (length vector))) - (declare (simple-vector vector) (fixnum size) - (inline assoc)) - (case (hash-table-kind hash-table) - (equal - ,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed))) - (let ((index (rem (the fixnum (equal-hash key)) size))) - (declare (fixnum index)) - ,equal-body)) - (eq - (without-gcing - (eq-rehash-if-needed) - (let ((index (rem (the fixnum (eq-hash key)) size))) - (declare (fixnum index)) - ,eq-body))) - (eql - (without-gcing - (eq-rehash-if-needed) - (let ((index (rem (the fixnum (eql-hash key)) size))) - (declare (fixnum index)) - ,eql-body)))))) - -(defmacro eq-rehash-if-needed () - `(let ((subtype (%primitive get-vector-subtype vector))) - (declare (fixnum subtype)) - (cond ((/= subtype valid-hashing) - (rehash hash-table vector size) - (setq vector (hash-table-table hash-table))) - ((> (hash-table-number-entries hash-table) - (hash-table-rehash-threshold hash-table)) - (rehash hash-table vector (grow-size hash-table)) - (setq vector (hash-table-table hash-table)) - (setq size (length vector)))))) - -(defmacro equal-rehash-if-needed () - `(cond ((> (hash-table-number-entries hash-table) - (hash-table-rehash-threshold hash-table)) - (rehash hash-table vector (grow-size hash-table)) - (setq vector (hash-table-table hash-table)) - (setq size (length vector))))) - -(defmacro rehash-if-needed () - `(let ((subtype (%primitive get-vector-subtype vector)) - (size (length vector))) - (declare (fixnum subtype size)) - (cond ((and (not (eq (hash-table-kind hash-table) 'equal)) - (/= subtype valid-hashing)) - (rehash hash-table vector size) - (setq vector (hash-table-table hash-table)) - (setq size (length vector))) - ((> (hash-table-number-entries hash-table) - (hash-table-rehash-threshold hash-table)) - (rehash hash-table vector (grow-size hash-table)) - (setq vector (hash-table-table hash-table)) - (setq size (length vector)))))) - -) - -;;; Making hash tables: - -(defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101) - rehash-threshold) - "Creates and returns a hash table. See manual for details." - (declare (fixnum size)) - (cond ((eq test #'eq) (setq test 'eq)) - ((eq test #'eql) (setq test 'eql)) - ((eq test #'equal) (setq test 'equal))) - (if (not (member test '(eq eql equal) :test #'eq)) - (error "~S is an illegal :Test for hash tables." test)) - (setq size (if (<= size 37) 37 (almost-primify size))) - (cond ((null rehash-threshold) - (setq rehash-threshold size)) - ((floatp rehash-threshold) - (setq rehash-threshold (ceiling (* rehash-threshold size))))) - (make-hash-table-structure :size size - :rehash-size rehash-size - :rehash-threshold rehash-threshold - :table - (if (eq test 'equal) - (make-array size) - (%primitive set-vector-subtype - (make-array size) - valid-hashing)) - :kind test))) - -;;; Manipulating hash tables: - -(defun gethash (key hash-table &optional default) - "Finds the entry in Hash-Table whose key is Key and returns the associated - value and T as multiple values, or returns Default and Nil if there is no - such entry." - (macrolet ((lookup (test) - `(let ((cons (assoc key (aref vector index) :test #',test))) - (declare (list cons)) - (if cons - (values (cdr cons) t) - (values default nil))))) - (hashop nil - (lookup eq) - (lookup eql) - (lookup equal)))) - -(defun %puthash (key hash-table value) - "Create an entry in HASH-TABLE associating KEY with VALUE; if there already - is an entry for KEY, replace it. Returns VALUE." - (macrolet ((store (test) - `(let ((cons (assoc key (aref vector index) :test #',test))) - (declare (list cons)) - (cond (cons (setf (cdr cons) value)) - (t - (push (cons key value) (aref vector index)) - (incf (hash-table-number-entries hash-table)) - value))))) - (hashop t - (store eq) - (store eql) - (store equal)))) - -(defun remhash (key hash-table) - "Remove any entry for KEY in HASH-TABLE. Returns T if such an entry - existed; () otherwise." - (hashop nil - (let ((bucket (aref vector index))) ; EQ case - (cond ((and bucket (eq (caar bucket) key)) - (pop (aref vector index)) - (decf (hash-table-number-entries hash-table)) - t) - (t - (do ((last bucket bucket) - (bucket (cdr bucket) (cdr bucket))) - ((null bucket) ()) - (when (eq (caar bucket) key) - (rplacd last (cdr bucket)) - (decf (hash-table-number-entries hash-table)) - (return t)))))) - (let ((bucket (aref vector index))) ; EQL case - (cond ((and bucket (eql (caar bucket) key)) - (pop (aref vector index)) - (decf (hash-table-number-entries hash-table)) - t) - (t - (do ((last bucket bucket) - (bucket (cdr bucket) (cdr bucket))) - ((null bucket) ()) - (when (eql (caar bucket) key) - (rplacd last (cdr bucket)) - (decf (hash-table-number-entries hash-table)) - (return t)))))) - (let ((bucket (aref vector index))) ; EQUAL case - (cond ((and bucket (equal (caar bucket) key)) - (pop (aref vector index)) - (decf (hash-table-number-entries hash-table)) - t) - (t - (do ((last bucket bucket) - (bucket (cdr bucket) (cdr bucket))) - ((null bucket) ()) - (when (equal (caar bucket) key) - (rplacd last (cdr bucket)) - (decf (hash-table-number-entries hash-table)) - (return t)))))))) - -(defun maphash (map-function hash-table) - "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value - of the entry; returns T." - (let ((vector (hash-table-table hash-table))) - (declare (simple-vector vector)) - (rehash-if-needed) - (do ((i 0 (1+ i)) - (size (hash-table-size hash-table))) - ((= i size)) - (declare (fixnum i size)) - (do ((bucket (aref vector i) (cdr bucket))) - ((null bucket)) - - (funcall map-function (caar bucket) (cdar bucket)))))) - -(defun clrhash (hash-table) - "Removes all entries of HASH-TABLE and returns the hash table itself." - (let ((vector (hash-table-table hash-table))) - (declare (simple-vector vector)) - (setf (hash-table-number-entries hash-table) 0) - (do ((i 0 (1+ i)) - (size (hash-table-size hash-table))) - ((= i size) hash-table) - (declare (fixnum i size)) - (setf (aref vector i) nil)))) - -(defun hash-table-count (hash-table) - "Returns the number of entries in the given Hash-Table." - (hash-table-number-entries hash-table)) - -;;; Primitive Hash Function - -;;; The maximum length and depth to which we hash lists. -(defconstant sxhash-max-len 7) -(defconstant sxhash-max-depth 3) - -(eval-when (compile eval) - - -(defconstant sxmash-total-bits 26) -(defconstant sxmash-rotate-bits 7) - -(defmacro sxmash (place with) - (let ((n-with (gensym))) - `(let ((,n-with ,with)) - (declare (fixnum ,n-with)) - (setf ,place - (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits)) - (ash (logand ,n-with - ,(1- (ash 1 - (- sxmash-total-bits - sxmash-rotate-bits)))) - ,sxmash-rotate-bits) - (the fixnum ,place)))))) - -(defmacro sxhash-simple-string (sequence) - `(%primitive sxhash-simple-string ,sequence)) - -(defmacro sxhash-string (sequence) - (let ((data (gensym)) - (start (gensym)) - (end (gensym))) - `(with-array-data ((,data ,sequence) - (,start) - (,end)) - (if (zerop ,start) - (%primitive sxhash-simple-substring ,data ,end) - (sxhash-simple-string (coerce (the string ,sequence) - 'simple-string)))))) - -(defmacro sxhash-list (sequence depth) - `(if (= ,depth sxhash-max-depth) - 0 - (do ((sequence ,sequence (cdr (the list sequence))) - (index 0 (1+ index)) - (hash 2)) - ((or (atom sequence) (= index sxhash-max-len)) hash) - (declare (fixnum hash index)) - (sxmash hash (internal-sxhash (car sequence) (1+ ,depth)))))) - - -); eval-when (compile eval) - - -(defun sxhash (s-expr) - "Computes a hash code for S-EXPR and returns it as an integer." - (internal-sxhash s-expr 0)) - - -(defun internal-sxhash (s-expr depth) - (typecase s-expr - ;; The pointers and immediate types. - (list (sxhash-list s-expr depth)) - (fixnum - (ldb (byte 23 0) s-expr)) - #+nil - (structure ???) - ;; Other-pointer types. - (simple-string (sxhash-simple-string s-expr)) - (symbol (sxhash-simple-string (symbol-name s-expr))) - (number - (etypecase s-expr - (integer (ldb (byte 23 0) s-expr)) - (float (multiple-value-bind (significand exponent) - (integer-decode-float s-expr) - (logxor (the fixnum (ldb (byte 23 0) significand)) - (the fixnum (ldb (byte 23 0) exponent))))) - (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0) - (internal-sxhash (denominator s-expr) 0)))) - (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0) - (internal-sxhash (imagpart s-expr) 0)))))) - (array - (typecase s-expr - (string (sxhash-string s-expr)) - (t (array-rank s-expr)))) - #+nil - (compiled-function (%primitive header-length s-expr)) - ;; Everything else. - (t (%primitive make-fixnum s-expr)))) diff --git a/code/internet.lisp b/code/internet.lisp deleted file mode 100644 index a01e8e1b254bf86ced7a4a1d8d10cfb9571c6993..0000000000000000000000000000000000000000 --- a/code/internet.lisp +++ /dev/null @@ -1,424 +0,0 @@ -;;; -*- Log: code.log; Package: extensions -*- -;;; -;;; ********************************************************************** -;;; 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 an interface to internet domain sockets. -;;; -;;; Written by William Lott. -;;; - -(in-package "EXTENSIONS") - -(export '(htonl ntohl htons ntohs lookup-host-entry host-entry host-entry-name - host-entry-aliases host-entry-addr-list host-entry-addr - 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)) - - -(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)))) - - - -(eval-when (compile load eval) - #+ :IBM-RT-PC - (pushnew :NETWORK-BYTE-ORDER *features*) - ) - -#+ :NETWORK-BYTE-ORDER -(progn - (defmacro htonl (x) x) - (defmacro ntohl (x) x) - (defmacro htons (x) x) - (defmacro ntohs (x) x)) - -#- :NETWORK-BYTE-ORDER -(progn - (defmacro htonl (x) - (let ((val (gensym))) - `(let ((,val ,x)) - (logior (ash (ldb (byte 8 0) - ,val) - 24) - (ash (ldb (byte 8 8) - ,val) - 16) - (ash (ldb (byte 8 16) - ,val) - 8) - (ldb (byte 8 24) - ,val))))) - (defmacro ntohl (x) - `(htonl ,x)) - (defmacro htons (x) - (let ((val (gensym))) - `(let ((,val ,x)) - (logior (ash (ldb (byte 8 0) - ,val) - 8) - (ldb (byte 8 8) - ,val))))) - (defmacro ntohs (x) - `(htons ,x))) - - - -;;;; Host entry operations. - -(defstruct host-entry - name - aliases - addr-type - addr-list) - -(defun host-entry-addr (host) - (car (host-entry-addr-list host))) - - -(def-c-pointer *char (null-terminated-string 256)) -(def-c-type pointer (unsigned-byte 32)) - -(def-c-record inet-sockaddr - (family short) - (port unsigned-short) - (addr unsigned-long) - (zero (unsigned-byte 64))) - -(def-c-record hostent - (name *char) - (aliases pointer) - (addrtype int) - (length int) - (addr_list pointer)) - -(def-c-routine "gethostbyname" (*hostent) - (name *char)) -(def-c-routine "gethostbyaddr" (*hostent) - (addr pointer) - (len int) - (type int)) - -(defalien *alien-ulong* (unsigned-byte 32) 32) -(defalien *alien-sockaddr* inet-sockaddr (c-sizeof 'inet-sockaddr)) - -(defoperator (my-hostent-aliases pointer) - ((hostent hostent)) - `(alien-index (alien-value ,hostent) - (long-words 1) - (long-words 1))) - -(defoperator (my-hostent-addr_list pointer) - ((hostent hostent)) - `(alien-index (alien-value ,hostent) - (long-words 4) - (long-words 1))) - -(defoperator (pointer-index pointer) - ((pointer pointer) - index) - `(alien-index (alien-value ,pointer) - (long-words ,index) - (long-words 1))) - -(defoperator (pointer-indirect pointer) - ((pointer pointer) - index) - `(alien-indirect (alien-index (alien-value ,pointer) - 0 - (long-words 1)) - (long-words (1+ ,index)))) - -(defun mumble (array) - (alien-bind ((foo array pointer t) - (bar (pointer-indirect (alien-value foo) 0) pointer t) - (baz (pointer-index (alien-value bar) 0) pointer t)) - (alien-value baz))) - -(defoperator (deref-string-ptr (null-terminated-string 512)) - ((alien pointer)) - `(alien-indirect (alien-value ,alien) - (bytes 512))) - -(defoperator (deref-ulong-ptr (unsigned-byte 32)) - ((alien pointer)) - `(alien-indirect (alien-value ,alien) - (long-words 1))) - -(defmacro listify-c-array (array derefer) - (let ((results (gensym)) - (index (gensym)) - (p1 (gensym)) - (p2 (gensym)) - (p3 (gensym))) - `(let ((,results nil) - (,index 0)) - (loop - (alien-bind - ((,p1 (pointer-indirect ,array ,index) pointer t) - (,p2 (pointer-index (alien-value ,p1) ,index) pointer t) - (,p3 (,derefer (alien-value ,p2)))) - (when (zerop (alien-address (alien-value ,p3))) - (return (nreverse ,results))) - (push (alien-access (alien-value ,p3)) - ,results)) - (incf ,index))))) - -(defun lookup-host-entry (host) - (if (typep host 'host-entry) - host - (let ((hostent - (typecase host - (string - (gethostbyname host)) - ((unsigned-byte 32) - (setf (system:alien-access *alien-ulong*) host) - (gethostbyaddr (system:alien-sap *alien-ulong*) - 4 ; bytes per ulong - af-inet)) - (t - (error "Invalid host ~S for ~S -- must be either a string or (unsigned-byte 32)"))))) - (if (not (null hostent)) - (alien-bind ((alien hostent hostent t) - (name - (alien-access (hostent-name (alien-value alien)) - '(alien (null-terminated-string 256) - 2048)) - (null-terminated-string 256) - t) - (aliases - (my-hostent-aliases (alien-value alien)) - pointer - t) - (addr-list - (my-hostent-addr_list (alien-value alien)) - pointer - t)) - (make-host-entry - :name (alien-access (alien-value name)) - :aliases (listify-c-array (alien-value aliases) deref-string-ptr) - :addr-type (alien-access (hostent-addrtype (alien-value alien))) - :addr-list (listify-c-array (alien-value addr-list) - deref-ulong-ptr))))))) - -(defun fill-in-sockaddr (addr port) - (setf (alien-access (inet-sockaddr-family (alien-value *alien-sockaddr*))) - af-inet) - (setf (alien-access (inet-sockaddr-port (alien-value *alien-sockaddr*))) - port) - (setf (alien-access (inet-sockaddr-addr (alien-value *alien-sockaddr*))) - addr) - (values)) - -(defun create-inet-socket (&optional (kind :stream)) - (multiple-value-bind (proto type) - (internet-protocol kind) - (multiple-value-bind (socket err) - (unix-socket af-inet type proto) - (when (null socket) - (error "Error creating socket: ~A" - (get-unix-error-msg err))) - socket))) - -(defun connect-to-inet-socket (host port &optional (kind :stream)) - (let ((socket (create-inet-socket kind)) - (hostent (lookup-host-entry host))) - (fill-in-sockaddr (host-entry-addr hostent) port) - (multiple-value-bind (ok err) - (unix-connect socket - *alien-sockaddr*) - (unless ok - (unix-close socket) - (error "Error connecting socket to [~A:~A]: ~A" - (host-entry-name hostent) - port - (get-unix-error-msg err))) - socket))) - -(defun create-inet-listener (port &optional (kind :stream)) - (let ((socket (create-inet-socket kind))) - (fill-in-sockaddr 0 port) - (multiple-value-bind (ok err) - (unix-bind socket - *alien-sockaddr*) - (unless ok - (unix-close socket) - (error "Error binding socket to port ~a: ~a" - port - (get-unix-error-msg err)))) - (when (eq kind :stream) - (multiple-value-bind (ok err) - (unix-listen socket 5) - (unless ok - (unix-close socket) - (error "Error listening to socket: ~a" - (get-unix-error-msg err))))) - socket)) - -(defun accept-tcp-connection (unconnected) - (declare (fixnum unconnected)) - (multiple-value-bind (connected err) - (unix-accept unconnected - *alien-sockaddr*) - (when (null connected) - (error "Error accepting a connection: ~a" - (get-unix-error-msg err))) - (values connected - (alien-access (inet-sockaddr-addr *alien-sockaddr*))))) - -(defun close-socket (socket) - (multiple-value-bind (ok err) - (unix-close socket) - (unless ok - (error "Error closing socket: ~a" - (get-unix-error-msg err)))) - (values)) - - - -;;;; 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)) - (multiple-value-bind (value err) - (mach:unix-recv (car handlers) - buffer - 1 - mach:msg-oob) - (cond ((null value) - (cerror "Ignore it" - "Error recving oob data on ~A: ~A" - (car handlers) - (mach:get-unix-error-msg err))) - (t - (setf handled t) - (let ((char (schar buffer 0)) - (handled nil)) - (declare (string-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."))) - (values)) - -;;; 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) - (string-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 mach:sigurg #'sigurg-handler) - (mach:unix-fcntl fd mach::f-setown (mach: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) - (string-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) - (string-char char)) - (let ((buffer (make-string 1 :initial-element char))) - (declare (simple-string buffer)) - (multiple-value-bind (value err) - (mach:unix-send fd buffer 1 mach:msg-oob) - (unless value - (error "Error sending ~S OOB to across ~A: ~A" - char - fd - (mach:get-unix-error-msg err)))))) diff --git a/code/lispinit.lisp b/code/lispinit.lisp deleted file mode 100644 index 05f2f426596e543c985432f3c3e9b8238abf8ed2..0000000000000000000000000000000000000000 --- a/code/lispinit.lisp +++ /dev/null @@ -1,1084 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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). -;;; ********************************************************************** -;;; -;;; Initialization and low-level interrupt support for the Spice Lisp system. -;;; Written by Skef Wholey and Rob MacLachlan. -;;; -(in-package "LISP" :use '("SYSTEM" "DEBUG")) - -(in-package "XLIB") - -(in-package "LISP") - -(export '(most-positive-fixnum most-negative-fixnum sleep - ++ +++ ** *** // ///)) - - -(in-package "SYSTEM" :nicknames '("SYS")) -(export '(add-port-death-handler remove-port-death-handler sap-int - int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing - *in-the-compiler* compiler-version *pornography-of-death* - *port-receive-rights-handlers* *port-ownership-rights-handlers* - without-interrupts with-reply-port map-port add-port-object - remove-port-object make-object-set object-set-operation - server-message *xwindow-table* map-xwindow add-xwindow-object - remove-xwindow-object server-event coerce-to-key-event - coerce-to-motion-event coerce-to-expose-event - coerece-to-exposecopy-event coerce-to-focuschange-event server - *nameserverport* *usertypescript* *userwindow* *typescriptport* - *task-self* *task-data* *task-notify* *file-input-handlers* - with-interrupts with-enabled-interrupts enable-interrupt - ignore-interrupt default-interrupt)) - -(in-package "EXTENSIONS") -(export '(quit *prompt* print-herald save-lisp gc-on gc-off - *before-save-initializations* *after-save-initializations* - *editor-lisp-p* *clx-server-displays*)) - -(in-package "LISP") - -;;; These go here so that we can refer to them in top-level forms. - -(defvar *before-save-initializations* () - "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* () - "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.") - -;;; Make the error system enable interrupts. - -(defconstant most-positive-fixnum 134217727 - "The fixnum closest in value to positive infinity.") - -(defconstant most-negative-fixnum -134217728 - "The fixnum closest in value to negative infinity.") - - -;;; Random information: - -(defvar compiler-version "???") -(defvar *lisp-implementation-version* "3.0(?)") - -(defvar *in-the-compiler* () - "Bound to T while running code inside the compiler. Macros may test this to - see where they are being expanded.") - -(defparameter %fasl-code-format 6) - -;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs... -(proclaim '(special *gc-inhibit* *already-maybe-gcing* - *need-to-collect-garbage* *gc-verbose* - *before-gc-hooks* *after-gc-hooks*)) - -;;;; Global ports: - -(defvar *task-self* 1 - "Port that refers to the current task.") - -(defvar *task-data* 2 - "Port used to receive data for the current task.") - -(defvar *nameserverport* () - "Port to the name server.") - - -;;; Software interrupt stuff. - -(defvar *in-server* NIL - "*In-server* is set to T when the SIGMSG interrupt has been enabled - in Server.") - -(defvar server-unique-object (cons 1 2)) - -(defconstant lockout-interrupts (logior (mach:sigmask :sigint) - (mach:sigmask :sigquit) - (mach:sigmask :sigfpe) - (mach:sigmask :sigsys) - (mach:sigmask :sigpipe) - (mach:sigmask :sigalrm) - (mach:sigmask :sigurg) - (mach:sigmask :sigstop) - (mach:sigmask :sigtstp) - (mach:sigmask :sigcont) - (mach:sigmask :sigchld) - (mach:sigmask :sigttin) - (mach:sigmask :sigttou) - (mach:sigmask :sigio) - (mach:sigmask :sigxcpu) - (mach:sigmask :sigxfsz) - (mach:sigmask :sigvtalrm) - (mach:sigmask :sigprof) - (mach:sigmask :sigwinch) - (mach:sigmask :sigmsg) - (mach:sigmask :sigemsg))) - -(defconstant interrupt-stack-size 4096 - "Size of stack for Unix interrupts.") - -(defvar software-interrupt-stack NIL - "Address of the stack used by Mach to send signals to Lisp.") - -(defvar %sp-interrupts-inhibited nil - "True if emergency message interrupts should be inhibited, false otherwise.") - -(defvar *software-interrupt-vector* - (make-array mach::maximum-interrupts) - "A vector that associates Lisp functions with Unix interrupts.") - -(defun enable-interrupt (interrupt function &optional character) - "Enable one Unix interrupt and associate a Lisp function with it. - Interrupt should be the number of the interrupt to enable. Function - should be a funcallable object that will be called with three - arguments: the signal code, a subcode, and the context of the - interrupt. The optional character should be an ascii character or - an integer that causes the interrupt from the keyboard. This argument - is only used for SIGINT, SIGQUIT, and SIGTSTP interrupts and is ignored - for any others. Returns the old function associated with the interrupt - and the character that generates it if the interrupt is one of SIGINT, - SIGQUIT, SIGTSTP and character was specified." - (unless (< 0 interrupt mach::maximum-interrupts) - (error "Interrupt number ~D is not between 1 and ~D." - mach::maximum-interrupts)) - (let ((old-fun (svref *software-interrupt-vector* interrupt)) - (old-char ())) - (when (and character - (or (eq interrupt mach:sigint) - (eq interrupt mach:sigquit) - (eq interrupt mach:sigtstp))) - (when (characterp character) - (setq character (char-code character))) - (when (mach:unix-isatty 0) - (if (or (eq interrupt mach:sigint) - (eq interrupt mach:sigquit)) - (mach:with-trap-arg-block mach:tchars tc - (multiple-value-bind - (val err) - (mach:unix-ioctl 0 mach:TIOCGETC - (alien-value-sap mach:tchars)) - (if (null val) - (error "Failed to get tchars information, unix error ~S." - (mach:get-unix-error-msg err)))) - (cond ((eq interrupt mach:sigint) - (setq old-char - (alien-access (mach::tchars-intrc (alien-value tc)))) - (setf (alien-access (mach::tchars-intrc (alien-value tc))) - character)) - (T - (setq old-char - (alien-access (mach::tchars-quitc (alien-value tc)))) - (setf (alien-access (mach::tchars-quitc (alien-value tc))) - character))) - (multiple-value-bind - (val err) - (mach:unix-ioctl 0 mach:tiocsetc - (alien-value-sap mach:tchars)) - (if (null val) - (error "Failed to set tchars information, unix error ~S." - (mach:get-unix-error-msg err))))) - (mach:with-trap-arg-block mach:ltchars tc - (multiple-value-bind - (val err) - (mach:unix-ioctl 0 mach:TIOCGLTC - (alien-value-sap mach:ltchars)) - (if (null val) - (error "Failed to get ltchars information, unix error ~S." - (mach:get-unix-error-msg err)))) - (setq old-char - (alien-access (mach::ltchars-suspc (alien-value tc)))) - (setf (alien-access (mach::ltchars-suspc (alien-value tc))) - character) - (multiple-value-bind - (val err) - (mach:unix-ioctl 0 mach:TIOCSLTC - (alien-value-sap mach:ltchars)) - (if (null val) - (error "Failed to set ltchars information, unix error ~S." - (mach:get-unix-error-msg err)))))))) - (setf (svref *software-interrupt-vector* interrupt) function) - (if (null function) - (mach:unix-sigvec interrupt mach:sig_dfl 0 0) - (let ((diha (+ (ash clc::romp-data-base 16) - clc::software-interrupt-offset))) - (mach:unix-sigvec interrupt diha lockout-interrupts 1))) - (if old-char - (values old-fun old-char) - old-fun))) - -(defun ignore-interrupt (interrupt) - "The Unix interrupt handling mechanism is set up so that interrupt is - ignored." - (unless (< 0 interrupt mach::maximum-interrupts) - (error "Interrupt number ~D is not between 1 and 31.")) - (let ((old-fun (svref *software-interrupt-vector* interrupt))) - (mach:unix-sigvec interrupt mach:sig_ign 0 0) - (setf (svref *software-interrupt-vector* interrupt) NIL) - old-fun)) - -(defun default-interrupt (interrupt) - "The Unix interrupt handling mechanism is set up to do the default action - under mach. Lisp will not get control of the interrupt." - (unless (< 0 interrupt mach::maximum-interrupts) - (error "Interrupt number ~D is not between 1 and 31.")) - (let ((old-fun (svref *software-interrupt-vector* interrupt))) - (mach:unix-sigvec interrupt mach:sig_dfl 0 0) - (setf (svref *software-interrupt-vector* interrupt) NIL) - old-fun)) - - -;;; %SP-Software-Interrupt-Handler is called by the miscops when a Unix -;;; signal arrives. The three arguments correspond to the information -;;; passed to a normal Unix signal handler, i.e.: -;;; signal -- the Unix signal number. -;;; code -- a code for those signals which can be caused by more -;;; than one kind of event. This code specifies the sub-event. -;;; scp -- a pointer to the context of the signal. - -;;; Because of the way %sp-software-interrupt-handler returns, it doesn't -;;; unwind the binding stack properly. The only variable affected by this -;;; is software-interrupt-stack, so it must be handled specially. - -(defun %sp-software-interrupt-handler (signal code scp stack) - (declare (optimize (speed 3) (safety 0))) - (if (and %sp-interrupts-inhibited - (not (memq signal '(#.mach:sigill #.mach:sigbus #.mach:sigsegv)))) - (progn - (let ((iin %sp-interrupts-inhibited)) - (setq %sp-interrupts-inhibited - (nconc (if (consp iin) iin) - (list `(,signal ,code ,scp)))) - (mach:unix-sigsetmask 0))) - (let* ((old-stack software-interrupt-stack) - (new-stack ()) - (%sp-interrupts-inhibited T)) - (unwind-protect - (progn - (when *in-server* - (mach:unix-sigvec mach:sigmsg mach::sig_dfl 0 0)) - (multiple-value-bind (gr addr) - (mach:vm_allocate *task-self* 0 - interrupt-stack-size t) - (gr-error 'mach:vm_allocate gr '%sp-software-interrupt-handler) - (setq software-interrupt-stack - (int-sap (+ addr interrupt-stack-size)))) - (setq new-stack software-interrupt-stack) - (mach:unix-sigstack new-stack 0) - (mach:unix-sigsetmask 0) - (funcall (svref *software-interrupt-vector* signal) - signal code scp) - (mach:unix-sigsetmask lockout-interrupts)) - (mach:vm_deallocate *task-self* - (- (sap-int new-stack) - interrupt-stack-size) - interrupt-stack-size) - (setq software-interrupt-stack old-stack) - (mach:unix-sigstack old-stack 0) - (when *in-server* - (let ((diha (+ (ash clc::romp-data-base 16) - clc::software-interrupt-offset))) - (mach:unix-sigvec mach:sigmsg diha lockout-interrupts 1))) - (mach:unix-sigsetmask 0)))) - (%primitive break-return stack)) - - -(defun ih-sigint (signal code scp) - (declare (ignore signal code scp)) - (without-hemlock - (with-interrupts - (break "Software Interrupt" t)))) - -(defun ih-sigquit (signal code scp) - (declare (ignore signal code scp)) - (throw 'top-level-catcher nil)) - -(defun ih-sigtstp (signal code scp) - (declare (ignore signal code scp)) - (without-hemlock -; (reset-keyboard 0) - (mach:unix-kill (mach:unix-getpid) mach:sigstop))) - -(defun ih-sigill (signal code scp) - (declare (ignore signal code)) - (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext) - 'mach:sigcontext) - mach:sigcontext T)) - (error "Illegal instruction encountered at IAR ~X." - (alien-access (mach::sigcontext-iar (alien-value context)))))) - -(defun ih-sigbus (signal code scp) - (declare (ignore signal code)) - (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext) - 'mach:sigcontext) - mach:sigcontext T)) - (with-interrupts - (error "Bus error encountered at IAR ~X." - (alien-access (mach::sigcontext-iar (alien-value context))))))) - -(defun ih-sigsegv (signal code scp) - (declare (ignore signal code)) - (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext) - 'mach:sigcontext) - mach:sigcontext T)) - (with-interrupts - (error "Segment violation encountered at IAR ~X." - (alien-access (mach::sigcontext-iar (alien-value context))))))) - -(defun ih-sigfpe (signal code scp) - (declare (ignore signal code)) - (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext) - 'mach:sigcontext) - mach:sigcontext T)) - (with-interrupts - (error "Floating point exception encountered at IAR ~X." - (alien-access (mach::sigcontext-iar (alien-value context))))))) - -;;; When we're in server then throw back to server. If we're not -;;; in server then just ignore the sigmsg interrupt. We can't handle -;;; it and we should never get it anyway. But of course we do -- it's -;;; dealing with interrupts and there funny at best. -(defun ih-sigmsg (signal code scp) - (declare (ignore signal code scp)) - (mach:unix-sigsetmask (mach:sigmask :sigmsg)) - (default-interrupt mach:sigmsg) - (when *in-server* - (setq *in-server* nil) - (throw 'server-catch server-unique-object))) - -(defun ih-sigemsg (signal code scp) - (declare (ignore signal code scp)) - (service-emergency-message-interrupt)) - -(defun init-mach-signals () - (declare (optimize (speed 3) (safety 0))) - (multiple-value-bind (gr addr) - (mach:vm_allocate *task-self* 0 interrupt-stack-size t) - (gr-error 'mach:vm_allocate gr 'enable-interrupt) - (setq software-interrupt-stack - (int-sap (+ addr interrupt-stack-size)))) - (let ((iha (get 'clc::interrupt-handler '%loaded-address)) - (diha (+ (ash clc::romp-data-base 16) clc::software-interrupt-offset))) - (%primitive pointer-system-set diha 0 iha)) - (mach:unix-sigstack software-interrupt-stack 0) - (enable-interrupt mach:sigint #'ih-sigint) - (enable-interrupt mach:sigquit #'ih-sigquit) - (enable-interrupt mach:sigtstp #'ih-sigtstp) - (enable-interrupt mach:sigill #'ih-sigill) - (enable-interrupt mach:sigbus #'ih-sigbus) - (enable-interrupt mach:sigsegv #'ih-sigsegv) - (enable-interrupt mach:sigemsg #'ih-sigemsg) - (enable-interrupt mach:sigfpe #'ih-sigfpe) -; (reset-keyboard 0) - ) - - -;;;; Reply port allocation. -;;; -;;; We maintain a global stack of reply ports which is shared among -;;; all matchmaker interfaces, and could be used by other people as well. -;;; -;;; The stack is represented by a vector, and a pointer to the first -;;; free port. The stack grows upward. There is always at least one -;;; NIL entry in the stack after the last allocated port. -;;; -(defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports. -(defvar *reply-port-pointer* 0) ; Index of first free port. -(defvar *reply-port-depth* 0) ; Dynamic depth in With-Reply-Port forms. - -;;; We use this as the reply port when allocating or deallocating reply -;;; ports to get around potentially nasty interactions. Interrupts -;;; are always off when we are doing this, so we don't have to have -;;; more than one of these, or worry about unwinding. -(defvar *allocate-reply-port* (mach:mach-task_data)) - -;;; Reset-Reply-Port-Stack -- Internal -;;; -;;; This is a before-save initialization which Nil's out the reply -;;; port stack and sets *allocate-reply-port* back to DataPort so that -;;; things initialize right at OS-Init time. -;;; -(defun reset-reply-port-stack () - (setq *reply-port-pointer* 0 *reply-port-depth* 0) - (fill (the simple-vector *reply-port-stack*) nil) - (setq *allocate-reply-port* (mach:mach-task_data))) -(pushnew 'reset-reply-port-stack *before-save-initializations*) - -;;; Allocate-New-Reply-Ports -- Internal -;;; -;;; If we run out of reply ports, we allocate another one, possibly -;;; growing the stack. -;;; -(defun allocate-new-reply-ports () - (let* ((stack *reply-port-stack*) - (pointer *reply-port-pointer*) - (len (length stack))) - (declare (simple-vector stack) (fixnum len)) - (when (eql pointer (1- len)) - (let ((new (make-array (* len 2)))) - (replace new stack :end1 len :end2 len) - (setq stack new *reply-port-stack* new))) - (setf (svref stack pointer) *allocate-reply-port*) - (let ((port (gr-call* mach:port_allocate (mach:mach-task_self)))) - (gr-call mach:port_disable (mach:mach-task_self) port) - ;; - ;; Nil out the allocate reply port so it isn't used for mundane purposes. - (setf (svref stack pointer) nil) - (setf (svref stack (1- pointer)) port) - port))) - -;;; Reallocate-Reply-Ports -- Internal -;;; -;;; This function is called when With-Reply-Port finds the stack pointer -;;; to be other than what it expected when it finishes. Reallocates all -;;; of the ports on the stack from Start to *reply-port-pointer*. We -;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and -;;; bind *reply-port-depth*, so that the allocation functions are happy. -;;; -(defun reallocate-reply-ports (start) - (let* ((pointer *reply-port-pointer*) - (*reply-port-depth* pointer) - (stack *reply-port-stack*) - (save-port (svref stack pointer))) - (when (> start pointer) - (error "More ports in use than allocated???")) - (setf (svref stack pointer) *allocate-reply-port*) - (do ((i start (1+ i))) - ((= i pointer) - (setf (svref stack pointer) save-port)) - (let ((port (svref stack i))) - (gr-call mach:port_deallocate *task-self* port) - (setf (svref stack i) - (gr-call* mach:port_allocate *task-self*)))))) - - -;;;; Server stuff: -;;; -;;; There is a fair amount of stuff to support Matchmaker RPC servers -;;; and asynchonous message service. RPC message service needs to be -;;; centralized since a server must receive on all ports, and there is -;;; no way for a particular server to know about all other servers -;;; in the same lisp. -;;; -;;; The idea is that you receive the message, and then dispatch off -;;; of the port received on and the message ID received. Ports correspond -;;; to objects that the server manages. Message ID's correspond to the -;;; operations on the objects. Objects are grouped into object sets, which -;;; are sets of objects having the same operations defined. -;;; -;;; The same mechanism is used for handling asynchronous messages. -;;; - -;;; The current implementation uses standard eq[l] hashtables for both -;;; levels of dispatching. Special purpose data structures would be more -;;; efficient, but the ~1ms overhead will probably be lost in the noise. - -;;; -;;; Hashtable from ports to objects. Each entry is a cons (object . set). -;;; -(defvar *port-table* (make-hash-table :test #'eql)) - -;;; Hashtable from windows to objects. Each entry is a cons (object . set). -;;; -(defvar *xwindow-table* (make-hash-table :test #'eql)) - - -(defstruct (object-set - (:constructor make-object-set - (name &optional - (default-handler #'default-default-handler))) - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Object Set ~S>" (object-set-name s))))) - name ; Name, for descriptive purposes. - (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun. - default-handler) - -(setf (documentation 'make-object-set 'function) - "Make an object set for use by a RPC/xevent server. Name is for - descriptive purposes only.") - -;;; Default-Default-Handler -- Internal -;;; -;;; If no such operation defined, signal an error. -;;; -(defun default-default-handler (object) - (alien-bind ((msg (server-message-msg server-message))) - (error "No operation for ID ~D on ~S in ~S." - (alien-access (mach:msg-id (alien-value msg))) object - (car (gethash (alien-access (mach:msg-localport (alien-value msg))) - *port-table*))))) - - -;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and -;;; object set mapped to by a xwindow or port in *xwindow-table* or -;;; *port-table*. -;;; -(macrolet ((defmapper (name table) - `(defun ,(intern (concatenate 'simple-string - "MAP-" (symbol-name name))) - (,name) - ,(format nil "Return as multiple values the object and ~ - object-set mapped to by ~A." - (string-downcase (symbol-name name))) - (let ((temp (gethash ,name ,table))) - (if temp - (values (car temp) (cdr temp)) - (values nil nil)))))) - (defmapper port *port-table*) - (defmapper xwindow *xwindow-table*)) - - -;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair -;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*. -;;; -(macrolet ((def-add-object (name table) - `(defun ,(intern (concatenate 'simple-string - "ADD-" (symbol-name name) - "-OBJECT")) - (,name object object-set) - ,(format nil "Add a new ~A/object/object-set association." - (string-downcase (symbol-name name))) - (check-type object-set object-set) - (setf (gethash ,name ,table) (cons object object-set)) - object))) - (def-add-object port *port-table*) - (def-add-object xwindow *xwindow-table*)) - - -;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and -;;; its associated object/object-set pair from *port-table* or *xwindow-table*. -;;; -(macrolet ((def-remove-object (name table) - `(defun ,(intern (concatenate 'simple-string - "REMOVE-" (symbol-name name) - "-OBJECT")) - (,name) - ,(format nil - "Remove ~A and its associated object/object-set pair." - (string-downcase (symbol-name name))) - (remhash ,name ,table)))) - (def-remove-object port *port-table*) - (def-remove-object xwindow *xwindow-table*)) - - -;;; Object-Set-Operation -- Public -;;; -;;; Look up the handler function for a given message ID. -;;; -(defun object-set-operation (object-set message-id) - "Return the handler function in Object-Set for the operation specified by - Message-ID, if none, NIL is returned. The handler function is passed - the object. The received message is in server-Message." - (check-type object-set object-set) - (check-type message-id fixnum) - (values (gethash message-id (object-set-table object-set)))) - -;;; %Set-Object-Set-Operation -- Internal -;;; -;;; The setf inverse for Object-Set-Operation. -;;; -(defun %set-object-set-operation (object-set message-id new-value) - (check-type object-set object-set) - (check-type message-id fixnum) - (setf (gethash message-id (object-set-table object-set)) new-value)) -;;; -(defsetf object-set-operation %set-object-set-operation - "Sets the handler function for an object set operation.") - -;;;; Emergency Message Handling: -;;; -;;; We use the same mechanism for asynchronous messages as is used for -;;; normal server messages. The only tricky part is that we don't want -;;; some random server function being called when we really want to -;;; receive an emergency message, so we can't receive on all ports. -;;; Instead, we use MessagesWaiting to find the ports with emergency -;;; messages. - -(defalien waiting-ports nil (long-words 128)) - -;;; Service-Emergency-Message-Interrupt -- Internal -;;; -;;; This is a lot like the server function, but we only receive on -;;; ports with one emergency message. We only receive one message because -;;; the handler function might have caused any other messages to be received. -;;; When we re-enable interrupts, if any emergency messages are left, we -;;; should be interrupted again. -;;; -(defun service-emergency-message-interrupt () - (grab-message-loop)) - -;;; -;;; This object set is used for DataPort, which is the port various magical -;;; message from the kernel are received on... -(defvar *kernel-messages* (make-object-set "Kernel Messages")) - -(compiler-let ((*alien-eval-when* '(compile eval))) -(defrecord port-death-msg - (msg mach:msg #.(record-size 'mach:msg)) - (ex-port-tt pad (long-words 1)) - (ex-port (signed-byte 32) (long-words 1))) - -(defoperator (server-message-port-death-msg port-death-msg) - ((msg server-message)) - `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg))) -); Compiler-Let - - -;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are -;;; called upon port death. If a port dies that is not in the table, we print -;;; out a message on *Trace-Output* describing its death. If -;;; *Pornography-Of-Death* is true, we don't even print that message. - -(defvar *port-death-handlers* (make-hash-table :test #'eql) - "Don't use this --- use Add-Port-Death-Handler instead.") - -;;; Add-Port-Death-Handler, Remove-Port-Death-Handler -- Public -;;; -(defun add-port-death-handler (port function) - "Make Function a handler for port death on Port. When the port dies, - Function is called with the port and an argument. See also - Remove-Port-Death-Handler." - (pushnew function (gethash port *port-death-handlers*)) - nil) -;;; -(defun remove-port-death-handler (port function) - "Undoes the effect of Add-Port-Death-Handler." - (setf (gethash port *port-death-handlers*) - (delete function (gethash port *port-death-handlers*))) - nil) - -(setf (object-set-operation *kernel-messages* mach:notify-port-deleted) - #'(lambda (obj) - (declare (ignore obj)) - (let* ((ex-port (alien-access - (port-death-msg-ex-port - (server-message-port-death-msg server-message)))) - (handlers (gethash ex-port *port-death-handlers*))) - (remhash ex-port *port-table*) - (remhash ex-port *port-death-handlers*) - (if (null handlers) - (handle-unclaimed-port-death ex-port) - (dolist (fun handlers) (funcall fun ex-port)))) - mach:kern-success)) - -(defvar *pornography-of-death* t - "If true, nothing is said about port deaths.") - -(defun handle-unclaimed-port-death (port) - (unless *pornography-of-death* - (format *trace-output* "~&[Port ~S just bit the dust.]~%" port))) - -;;; Port receive and ownership rights messages are handled simlarly, but -;;; by default we deallocate the port to make sure it's really dead. This -;;; gets around problems with ports being exhausted because some servers -;;; don't really nuke the port when the deallocate the object. -;;; - -(defvar *port-receive-rights-handlers* (make-hash-table :test #'eql) - "This is a hashtable from ports to functions. The function is called with - the port as its argument when a port receive rights message for that port - is received from the kernel.") - -(defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql) - "This is a hashtable from ports to functions. The function is called with - the port as its argument when a port ownership rights message for that port - is received from the kernel.") - -(setf (object-set-operation *kernel-messages* mach:notify-receive-rights) - #'(lambda (obj) - (declare (ignore obj)) - (let ((ex-port (alien-access - (port-death-msg-ex-port - (server-message-port-death-msg server-message))))) - (funcall (gethash ex-port *port-receive-rights-handlers* - #'handle-unclaimed-port-rights) - ex-port)) - mach:kern-success)) - -(setf (object-set-operation *kernel-messages* mach:notify-ownership-rights) - #'(lambda (obj) - (declare (ignore obj)) - (let ((ex-port (alien-access - (port-death-msg-ex-port - (server-message-port-death-msg server-message))))) - (funcall (gethash ex-port *port-ownership-rights-handlers* - #'handle-unclaimed-port-rights) - ex-port)) - mach:kern-success)) - -(defun handle-unclaimed-port-rights (port) - (unless *pornography-of-death* - (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%" - port)) - (mach:port_deallocate *task-self* port) - (remhash port *port-receive-rights-handlers*) - (remhash port *port-ownership-rights-handlers*) - (remhash port *port-table*)) - -(add-port-object *task-data* nil *kernel-messages*) - -;;; Clear-Port-Tables -- Internal -;;; -;;; A before-save initialization which clears all of the port hashtables. -;;; -(defun clear-port-tables () - (clrhash *port-table*) - (clrhash *port-death-handlers*) - (clrhash *port-receive-rights-handlers*) - (clrhash *port-ownership-rights-handlers*)) - -(pushnew 'clear-port-tables *before-save-initializations*) - - -;;; %Initial-Function is called when a cold system starts up. First we zoom -;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen -;;; at "load time." Then we initialize the various subsystems and call the -;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until -;;; someone (most likely the Quit function) throws to the tag -;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms -;;; in Unwind-Protects will get executed. - -(proclaim '(special *lisp-initialization-functions*)) - -(eval-when (compile) - (defmacro print-and-call (name) - `(progn - (%primitive print ',name) - (,name)))) - -(defun %initial-function () - "Gives the world a shove and hopes it spins." - (setq *already-maybe-gcing* t) - (setf *gc-inhibit* t) - (setf *need-to-collect-garbage* nil) - (setq *gc-verbose* t) - (setq *before-gc-hooks* ()) - (setq *after-gc-hooks* ()) - (setq %sp-interrupts-inhibited nil) - (%primitive print "In initial-function, and running.") - - ;; Many top-level forms call INFO, (SETF INFO). - (print-and-call c::globaldb-init) - - ;; Some of the random top-level forms call Make-Array, which calls Subtypep... - (print-and-call subtypep-init) - - (setq *lisp-initialization-functions* - (nreverse *lisp-initialization-functions*)) - (%primitive print "Calling top-level forms.") - (dolist (fun *lisp-initialization-functions*) - (funcall fun)) - (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed. - - (print-and-call os-init) - (print-and-call filesys-init) - (print-and-call conditions::error-init) - - (print-and-call reader-init) - (print-and-call backq-init) - (print-and-call sharp-init) - ;; After the various reader subsystems have done their thing to the standard - ;; readtable, copy it to *readtable*. - (setq *readtable* (copy-readtable std-lisp-readtable)) - - (print-and-call stream-init) - (print-and-call random-init) - (print-and-call format-init) - (print-and-call package-init) - (print-and-call pprint-init) - - (setq *already-maybe-gcing* nil) - (terpri) - (princ "CMU Common Lisp kernel core image ") - (princ (lisp-implementation-version)) - (princ ".") - (terpri) - (princ "[You are in the LISP package.]") - (terpri) - (catch '%end-of-the-world - (loop - (%top-level) - (write-line "You're certainly a clever child."))) - (mach:unix-exit 0)) - - -;;;; Initialization functions: - -;;; Reinit is called to reinitialize the world when a saved core image -;;; is resumed. -(defvar *task-notify* NIL) - -(defun reinit () - (without-interrupts - (setq *already-maybe-gcing* t) - (os-init) - (stream-reinit) - (setq *already-maybe-gcing* nil)) - (setq *task-notify* (mach:mach-task_notify)) - (mach:port_enable (mach:mach-task_self) *task-notify*) - (add-port-object *task-notify* nil *kernel-messages*) - (init-mach-signals)) - - -;;; 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. - -(defun os-init () - (setq *task-self* (mach:mach-task_self)) - (setq *task-data* (mach:mach-task_data))) - - -;;; Setup-path-search-list returns a list of the directories that are -;;; in the unix path environment variable. This is so that run-program -;;; can be smarter about where to find a program to run. -(defun setup-path-search-list () - (let ((path (cdr (assoc :path 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))))))) - - -;;;; Miscellaneous external functions: - -(defun print-herald () - (write-string "CMU Common Lisp ") - (write-line (lisp-implementation-version)) - (write-string "Hemlock ") (write-string *hemlock-version*) - (write-string ", Compiler ") (write-line compiler-version) - (write-line "Send bug reports and questions to Gripe.") - (values)) - -(defvar *editor-lisp-p* nil - "This is true if and only if the lisp was started with the -edit switch.") - -(defun save-lisp (core-file-name &key - (purify t) - (root-structures ()) - (init-function - #'(lambda () - (throw 'top-level-catcher nil))) - (load-init-file t) - (print-herald t) - (process-command-line t)) - "Saves a Spice 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 - This should be a list of the main entry points in any newly loaded - systems. This need not be supplied, but locality will be better if it - is. This is 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. - - :print-herald - If true, print out the lisp system herald when starting." - - (if purify - (purify :root-structures root-structures) - (gc)) - (unless (save core-file-name) - (setf (search-list "default:") (list (default-directory))) - (setf (search-list "path:") (setup-path-search-list)) - (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 (or (and cl-switch - (or (cmd-switch-value cl-switch) - (car (cmd-switch-words cl-switch)) - "init")) - "init"))) - (load (merge-pathnames name (user-homedir-pathname)) - :if-does-not-exist nil)))) - (when print-herald - (print-herald)) - (when process-command-line - (ext::invoke-switch-demons *command-line-switches* - *command-switch-demons*)) - (funcall init-function))) - - -;;; WORLD-LOAD-INIT-FUNCTION -- Interface -;;; -;;; The init function we pass to SAVE-LISP in worldload. We turn on GC and -;;; thow to top level. -;;; -(defun world-load-init-function () - (gc-on) - (abort)) - - -;;; Quit gets us out, one way or another. - -(defun quit (&optional recklessly-p) - "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is - non-Nil." -; (reset-keyboard 0) - (dolist (x (if (boundp 'extensions::temporary-foreign-files) - extensions::temporary-foreign-files)) - (mach:unix-unlink x)) - (if recklessly-p - (mach:unix-exit 0) - (throw '%end-of-the-world nil))) - - - -(defalien sleep-msg mach:msg (record-size 'mach:msg)) -(setf (alien-access (mach:msg-simplemsg sleep-msg)) T) -(setf (alien-access (mach:msg-msgtype sleep-msg)) 0) -(setf (alien-access (mach:msg-msgsize sleep-msg)) - (/ (record-size 'mach:msg) 8)) - -;;; Currently there is a bug in the Mach timeout code that if the timeout -;;; period is too short the receive never returns. - -(defun sleep (n) - "This function causes execution to be suspended for N seconds. N may - be any non-negative, non-complex number." - (with-reply-port (sleep-port) - (let ((m (round (* 1000 n)))) - (cond ((minusp m) - (error "Argument to Sleep, ~S, is a negative number." n)) - ((zerop m)) - (t - (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port) - (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m))) - (unless (eql gr mach:rcv-timed-out) - (gr-error 'mach:receive gr))))))) - nil) - - -;;;; TOP-LEVEL loop. - -(defvar / nil - "Holds a list of all the values returned by the most recent top-level EVAL.") -(defvar // nil "Gets the previous value of / when a new value is computed.") -(defvar /// nil "Gets the previous value of // when a new value is computed.") -(defvar * nil "Holds the value of the most recent top-level EVAL.") -(defvar ** nil "Gets the previous value of * when a new value is computed.") -(defvar *** nil "Gets the previous value of ** when a new value is computed.") -(defvar + nil "Holds the value of the most recent top-level READ.") -(defvar ++ nil "Gets the previous value of + when a new value is read.") -(defvar +++ nil "Gets the previous value of ++ when a new value is read.") -(defvar - nil "Holds the form curently being evaluated.") -(defvar *prompt* "* " - "The top-level prompt string. This also may be a function of no arguments - that returns a simple-string.") -(defvar *in-top-level-catcher* nil - "True if we are within the Top-Level-Catcher. This is used by interrupt - handlers to see whether it is o.k. to throw.") - -(defun interactive-eval (form) - "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++, - +, ///, //, /, and -." - (setf +++ ++ - ++ + - + - - - form) - (let ((results (multiple-value-list (eval form)))) - (setf /// // - // / - / results - *** ** - ** * - * (car results))) - (unless (boundp '*) - ;; The bogon returned an unbound marker. - (setf * nil) - (cerror "Go on with * set to NIL." - "EVAL returned an unbound marker.")) - (values-list /)) - -(defconstant eofs-before-quit 10) - -(defun %top-level () - "Top-level READ-EVAL-PRINT loop. Do not call this." - (let ((* nil) (** nil) (*** nil) - (- nil) (+ nil) (++ nil) (+++ nil) - (/// nil) (// nil) (/ nil) - (magic-eof-cookie (cons :eof nil)) - (number-of-eofs 0)) - (loop - (with-simple-restart (abort "Return to Top-Level.") - (catch 'top-level-catcher - (let ((*in-top-level-catcher* t)) - (loop - (fresh-line) - (princ (if (functionp *prompt*) - (funcall *prompt*) - *prompt*)) - (force-output) - (let ((form (read *standard-input* nil magic-eof-cookie))) - (cond ((not (eq form magic-eof-cookie)) - (let ((results - (multiple-value-list (interactive-eval form)))) - (dolist (result results) - (fresh-line) - (prin1 result))) - (setf number-of-eofs 0)) - ((eql (incf number-of-eofs) 1) - (let ((stream (make-synonym-stream '*terminal-io*))) - (setf *standard-input* stream) - (setf *standard-output* stream) - (format t "~&Received EOF on *standard-input*, ~ - switching to *terminal-io*.~%"))) - ((> number-of-eofs eofs-before-quit) - (format t "~&Received more than ~D EOFs; Aborting.~%" - eofs-before-quit) - (quit)) - (t - (format t "~&Received EOF.~%"))))))))))) - - - -;;; %Halt -- Interface -;;; -;;; A convenient way to get into the assembly level debugger. -;;; -(defun %halt () - (%primitive halt)) diff --git a/code/list.lisp b/code/list.lisp deleted file mode 100644 index 11e987f5e5a17beb18c0155e529404e1979bcf41..0000000000000000000000000000000000000000 --- a/code/list.lisp +++ /dev/null @@ -1,915 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; 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)) - - -(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)) -;; Assq & memq are just interpreter stubs. -(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))) - (()) - (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 (%primitive 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) - "Performs the cdr function n times on a list." - (%primitive nthcdr n list)) - -(defun last (list) - "Returns the last cons (not the last element!) of a list." - (%primitive last 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) - (declare (fixnum size)) - "Constructs a list with size elements each set to value" - (if (< size 0) (error "~S is an illegal size for MAKE-LIST." size) - (do ((count size (1- count)) - (result '() (cons initial-element result))) - ((zerop count) result) - (declare (fixnum 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) - (if list - (error "~S is not a list." 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-alist (alist) - "Returns a new association list equal to alist, constructed in space" - (if (atom alist) - (if alist - (error "~S is not a list." alist)) - (let ((result - (cons (if (atom (car alist)) - (car alist) - (cons (caar alist) (cdar alist)) ) - '() ))) - (do ((x (cdr alist) (cdr x)) - (splice result - (cdr (rplacd splice - (cons - (if (atom (car x)) - (car x) - (cons (caar x) (cdar x))) - '() ))) )) -;;; 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." - (cond ((not (consp object)) object) - (T (cons (copy-tree (car object)) (copy-tree (cdr 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 (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." - (unless (integerp n) - (error "Wrong type argument, ~S, should have been of type INTEGER.")) - (if (< n 0) (setq n 0)) - (let ((length (1- (length (the list list))))) - (declare (fixnum length)) - (if (< length n) - () - (do* ((top (cdr list) (cdr top)) - (result (list (car list))) - (splice result) - (count length (1- count))) - ((= count n) result) - (setq splice (cdr (rplacd splice (list (car top))))))))) - -(defun nbutlast (list &optional (n 1)) - "Modifies List to remove the last N elements." - (unless (integerp n) - (error "Wrong type argument, ~S, should have been of type INTEGER.")) - (if (< n 0) (setq n 0)) - (let ((length (1- (length (the list list))))) - (declare (fixnum length)) - (if (< length n) () - (do ((1st (cdr list) (cdr 1st)) - (2nd list 1st) - (count length (1- count))) - ((= count n) - (rplacd 2nd ()) - list))))) - -(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 (fixnum n)) - "Sets the Nth element of List (zero based) to Newval." - (if (< n 0) - (error "~S is an illegal N for SETF of NTH." n) - (do ((count n (1- count))) - ((zerop count) (rplaca list newval) newval) - (declare (fixnum count)) - (if (endp (cdr list)) - (error "~S is too large an index for SETF of NTH." n) - (setq list (cdr list)))))) - -;;;; 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." - (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." - (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)" - (unless (listp list) - (error "~S is not a list." list)) - (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)" - (unless (listp list) - (error "~S is not a list." list)) - (do ((list list (cdr list))) - ((endp list) ()) - (if (not (funcall test (funcall key (car list)))) - (return list))))) - -(defun tailp (sublist list) - "Returns T if sublist is one of the cons'es in list" - (do ((x list (cdr x))) - ((endp x) '()) - (if (eq x sublist) (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" - (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." - (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." - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res list2)) - (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." - (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." - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil)) - (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." - (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." - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil)) - (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." - (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 ((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." - (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) - - - -;;; 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)))))) -) ;eval-when - - -(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" - (memq item list)) - -(defun assq (item alist) - "Return the first pair of alist where item EQ the key of pair" - (assq item alist)) - -(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/load.lisp b/code/load.lisp deleted file mode 100644 index 8b20c5df9711a9ed7dcf4a692cbf54e087b54ab4..0000000000000000000000000000000000000000 --- a/code/load.lisp +++ /dev/null @@ -1,1008 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Loader for Spice Lisp. -;;; Written by Skef Wholey and Rob MacLachlan. -;;; -(in-package "LISP") -(export '(load *load-verbose*)) - -(in-package "SYSTEM") -(export 'resolve-loaded-assembler-references) - -(in-package "EXTENSIONS") -(export '*load-if-source-newer*) - -(in-package "LISP") - - -;;;; Random state variables: - -(defvar *load-verbose* () - "The default for the :Verbose argument to Load.") -(defvar *load-print-stuff* () - "True if we're gonna mumble about what we're loading.") -(defvar *fasl-file* () "The fasl file we're reading from.") -(defvar *current-code-format* "The code format that we think we are loading.") - -(defvar *in-cold-load* nil) ; True if we are in the cold loader. - -(defvar *load-if-source-newer* :load-object - "The value of *load-if-source-newer* determines what happens when the - source file is newer than the object file. The possible values are: - :load-object - load object file (default), :load-source - load the source - file, :compile - compile the source and then load the object file, or - :query - ask the user if he wants to load the source or object file.") - -(proclaim '(special cold-fop-functions)) - -;;;; The Fop-Table: -;;; -;;; The table is implemented as a simple-vector indexed by the table -;;; offset. We may need to have several, since load can be called recursively. - -(defvar *free-fop-tables* (list (make-array 1000)) - "List of free fop tables for the fasloader.") - -(defvar *current-fop-table* () - "The current fop table.") - -(defvar *current-fop-table-size* () - "The length of the current fop table.") - -(defvar *current-fop-table-index* () - "Index in the fop-table of the next entry to be used.") - -(defun grow-fop-table () - (let* ((new-size (* *current-fop-table-size* 2)) - (new-table (make-array new-size))) - (declare (fixnum new-size) (simple-vector new-table)) - (replace new-table (the simple-vector *current-fop-table*)) - (setq *current-fop-table* new-table) - (setq *current-fop-table-size* new-size))) - -(defmacro push-table (thing) - (let ((n-index (gensym))) - `(let ((,n-index *current-fop-table-index*)) - (declare (fixnum ,n-index)) - (when (= ,n-index (the fixnum *current-fop-table-size*)) - (grow-fop-table)) - (setq *current-fop-table-index* (1+ ,n-index)) - (setf (svref *current-fop-table* ,n-index) ,thing)))) - -;;;; The Fop-Stack: -;;; -;;; The is also in a simple-vector, but it grows down, since it is somewhat -;;; cheaper to test for overflow that way. -;;; -(defvar *fop-stack* (make-array 100) - "The fop stack (we only need one!).") - -(defvar *fop-stack-pointer* 100 - "The index of the most recently pushed item on the fop-stack.") - -(defvar *fop-stack-pointer-on-entry* () - "The current index into the fop stack when we last recursively entered LOAD.") - - -(defun grow-fop-stack () - (let* ((size (length (the simple-vector *fop-stack*))) - (new-size (* size 2)) - (new-stack (make-array new-size))) - (declare (fixnum size new-size) (simple-vector new-stack)) - (replace new-stack (the simple-vector *fop-stack*) :start1 size) - (incf *fop-stack-pointer-on-entry* size) - (setq *fop-stack-pointer* size) - (setq *fop-stack* new-stack))) - -;;; With-Fop-Stack -- Internal -;;; -;;; Cache information about the fop-stack in local variables. Define -;;; a local macro to pop from the stack. Push the result of evaluation if -;;; specified. -;;; -(defmacro with-fop-stack (pushp &body forms) - (let ((n-stack (gensym)) - (n-index (gensym)) - (n-res (gensym))) - `(let ((,n-stack *fop-stack*) - (,n-index *fop-stack-pointer*)) - (declare (simple-vector ,n-stack) (fixnum ,n-index)) - (macrolet ((pop-stack () - `(prog1 - (svref ,',n-stack ,',n-index) - (setq ,',n-index (1+ ,',n-index)))) - (call-with-popped-things (fun n) - (let ((n-start (gensym))) - `(let ((,n-start (+ ,',n-index ,n))) - (setq ,',n-index ,n-start) - (,fun ,@(make-list n :initial-element - `(svref ,',n-stack - (decf ,n-start)))))))) - ,(if pushp - `(let ((,n-res (progn ,@forms))) - (when (zerop ,n-index) - (grow-fop-stack) - (setq ,n-index *fop-stack-pointer* - ,n-stack *fop-stack*)) - (decf ,n-index) - (setq *fop-stack-pointer* ,n-index) - (setf (svref ,n-stack ,n-index) ,n-res)) - `(prog1 - (progn ,@forms) - (setq *fop-stack-pointer* ,n-index))))))) - -;;; FOP database: - -(defvar fop-codes (make-array 256) - "Vector indexed by a FaslOP that yields the FOP's name.") - -(defvar fop-functions - (make-array 256 :initial-element #'(lambda () (error "Losing FOP!"))) - "Vector indexed by a FaslOP that yields a function of 0 arguments which - will perform the operation.") - - -;;; Define-FOP -- Internal -;;; -;;; Defines Name as a fasl operation, with op-code op. If pushp is :nope, -;;; the the body neither pushes or pops the fop stack. If it is nil, then -;;; the body may pop, but the result is ignored. If it is true, the the result -;;; is pushed on the stack. -;;; -(defmacro define-fop ((name op &optional (pushp t)) &rest forms) - `(progn - (defun ,name () - ,(if (eq pushp :nope) - `(progn ,@forms) - `(with-fop-stack ,pushp ,@forms))) - (setf (svref fop-codes ,op) ',name) - (setf (get ',name 'fop-code) ,op) - (setf (svref fop-functions ,op) #',name))) - -;;; Clone-Fop -- Internal -;;; -;;; Defines a pair of fops which are identical except in that one reads -;;; a four byte argument and the other reads a one byte argument. The -;;; argument can be accessed by using the Clone-Arg macro. -;;; -(defmacro clone-fop ((name op &optional (pushp t)) - (small-name small-op) &rest forms) - `(progn - (macrolet ((clone-arg () '(read-arg 4))) - (define-fop (,name ,op ,pushp) ,@forms)) - (macrolet ((clone-arg () '(read-arg 1))) - (define-fop (,small-name ,small-op ,pushp) ,@forms)))) - -;;;; Utilities for reading from the fasl file. - -(proclaim '(inline read-byte)) - -;;; Fast-Read-U-Integer -- Internal -;;; -;;; Expands into code to read an N-byte unsigned integer using -;;; fast-read-byte. -;;; -(defmacro fast-read-u-integer (n) - (do ((res '(fast-read-byte) - `(logior (fast-read-byte) - (ash ,res 8))) - (cnt 1 (1+ cnt))) - ((>= cnt n) res))) - -;;; Fast-Read-Variable-U-Integer -- Internal -;;; -;;; Like Fast-Read-U-Integer, but the size may be determined at run time. -;;; -(defmacro fast-read-variable-u-integer (n) - (let ((n-pos (gensym)) - (n-res (gensym)) - (n-cnt (gensym))) - `(do ((,n-pos 8 (+ ,n-pos 8)) - (,n-cnt (1- ,n) (1- ,n-cnt)) - (,n-res - (fast-read-byte) - (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res))) - ((zerop ,n-cnt) ,n-res)))) - -;;; Fast-Read-S-Integer -- Internal -;;; -;;; Read a signed integer. -;;; -(defmacro fast-read-s-integer (n) - (let ((n-last (gensym))) - (do ((res `(let ((,n-last (fast-read-byte))) - (if (zerop (logand ,n-last #x80)) - ,n-last - (logior ,n-last #x-100))) - `(logior (fast-read-byte) - (ash ,res 8))) - (cnt 1 (1+ cnt))) - ((>= cnt n) res)))) - -;;; Read-Arg -- Internal -;;; -;;; Read an N-byte unsigned integer from the *fasl-file* -;;; -(defmacro read-arg (n) - (if (= n 1) - `(read-byte *fasl-file*) - `(prepare-for-fast-read-byte *fasl-file* - (prog1 - (fast-read-u-integer ,n) - (done-with-fast-read-byte))))) - -;;; Fasload: - -(defun fasload (stream) - (when *load-verbose* - (format t "~&; Loading stuff from ~S.~%" stream)) - (let* ((*fasl-file* stream) - (*current-fop-table* (pop *free-fop-tables*)) - (*current-fop-table-size* ()) - (*current-fop-table-index* 0) - (*fop-stack-pointer-on-entry* *fop-stack-pointer*)) - (if (null *current-fop-table*) - (setq *current-fop-table* (make-array 1000))) - (setq *current-fop-table-size* - (length (the simple-vector *current-fop-table*))) - (unwind-protect - (do ((loaded-group (load-group stream) (load-group stream))) - ((not loaded-group))) - (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*) - ;; - ;; Nil out the table, so we don't hold onto garbage. - (let ((tab *current-fop-table*)) - (dotimes (i *current-fop-table-index*) - (declare (fixnum i)) - (setf (svref tab i) nil)) - (push tab *free-fop-tables*)) - ;; - ;; Ditto for the stack... - (dotimes (i *fop-stack-pointer-on-entry*) - (declare (fixnum i)) - (setf (svref *fop-stack* i) nil)))) - t) - -#| - -(defvar *fop-counts* (make-array 256 :initial-element 0)) -(defvar *fop-times* (make-array 256 :initial-element 0)) -(defvar *print-fops* nil) - -(defun clear-counts () - (fill (the simple-vector *fop-counts*) 0) - (fill (the simple-vector *fop-times*) 0) - t) - -(defun analyze-counts () - (let ((counts ()) - (total-count 0) - (times ()) - (total-time 0)) - (macrolet ((breakdown (lvar tvar vec) - `(progn - (dotimes (i 255) - (declare (fixnum i)) - (let ((n (svref ,vec i))) - (push (cons (svref fop-codes i) n) ,lvar) - (incf ,tvar n))) - (setq ,lvar (subseq (sort ,lvar #'(lambda (x y) - (> (cdr x) (cdr y)))) - 0 10))))) - - (breakdown counts total-count *fop-counts*) - (breakdown times total-time *fop-times*) - (format t "Total fop count is ~D~%" total-count) - (dolist (c counts) - (format t "~30S: ~4D~%" (car c) (cdr c))) - (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0)) - (dolist (m times) - (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0)))))) -|# - -;;; Load-Group -- Internal -;;; -;;; Load-Group returns t if it successfully loads a group from the file, -;;; or () if EOF was encountered while trying to read from the file. -;;; Dispatch to the right function for each fop. Special-case fop-byte-push -;;; since it is real common. -;;; -(defun load-group (file) - (when (check-header file) - (catch 'group-end - (let ((*current-code-format* 'uninitialized-code-format)) - (loop - (let ((byte (read-byte file))) - (if (eql byte 3) - (let ((index *fop-stack-pointer*)) - (when (zerop index) - (grow-fop-stack) - (setq index *fop-stack-pointer*)) - (decf index) - (setq *fop-stack-pointer* index) - (setf (svref *fop-stack* index) - (svref *current-fop-table* (read-byte file)))) - (funcall (svref fop-functions byte))))))))) - -;;; Check-Header returns t if t succesfully read a header from the file, -;;; or () if EOF was hit before anything was read. An error is signaled -;;; if garbage is encountered. - -(defun check-header (file) - (let ((byte (read-byte file NIL '*eof*))) - (cond ((eq byte '*eof*) ()) - ((eq byte (char-int #\F)) - (do ((byte (read-byte file) (read-byte file)) - (count 1 (1+ count))) - ((= byte 255) t) - (declare (fixnum byte)) - (if (and (< count 9) - (not (eql byte (char-int (schar "FASL FILE" count))))) - (error "Bad FASL file format.")))) - (t (error "Bad FASL file format."))))) - - -;;; Load-S-Integer loads a signed integer Length bytes long from the File. - -(defun load-s-integer (length) - (declare (fixnum length)) - (do* ((index length (1- index)) - (byte 0 (read-byte *fasl-file*)) - (result 0 (+ result (ash byte bits))) - (bits 0 (+ bits 8))) - ((= index 0) - (if (logbitp 7 byte) ; look at sign bit - (- result (ash 1 bits)) - result)) - (declare (fixnum index byte bits)))) - -;;; Sloload: - -;;; Something not EQ to anything read from a file: - -(defconstant load-eof-value '(())) - -;;; Sloload loads a text file into the given Load-Package. - -(defun sloload (stream) - (when *load-verbose* - (format t "~&; Loading stuff from ~S.~%" stream)) - (do ((sexpr (read stream nil load-eof-value) - (read stream nil load-eof-value))) - ((eq sexpr load-eof-value)) - (if *load-print-stuff* - (format t "~&; ~S~%" (eval sexpr)) - (eval sexpr)))))) - -;;; Load: - -(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) "nfasl") - (string-equal (pathname-type tn) "fasl")) - (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 "nfasl" :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)))))))))) - - -;;;; Actual FOP definitions: - -(define-fop (fop-nop 0 :nope)) -(define-fop (fop-pop 1 nil) (push-table (pop-stack))) -(define-fop (fop-pop-for-effect 65 nil) (pop-stack)) -(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4))) -(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1))) - -(define-fop (fop-empty-list 4) ()) -(define-fop (fop-truth 5) t) -(define-fop (fop-misc-trap 66) - (%primitive make-immediate-type 0 lisp::%trap-type)) - -(define-fop (fop-character 68) - (int-char (read-arg 3))) -(define-fop (fop-short-character 69) - (code-char (read-arg 1))) - -(define-fop (fop-structure 79) - (%primitive set-vector-subtype (pop-stack) 1)) - -(define-fop (fop-end-group 64 :nope) (throw 'group-end t)) -(define-fop (fop-end-header 255) - (error "Fop-End-Header was executed???")) - -(define-fop (fop-normal-load 81 :nope)) -(define-fop (fop-maybe-cold-load 82 :nope) - (when *in-cold-load* - (setq fop-functions cold-fop-functions))) - -(define-fop (fop-static-heap 60 :nope)) -(define-fop (fop-dynamic-heap 61 :nope)) -(define-fop (fop-read-only-heap 67 :nope)) - -(define-fop (fop-verify-table-size 62 :nope) - (if (/= *current-fop-table-index* (read-arg 4)) - (error "Fasl table of improper size. Bug!"))) -(define-fop (fop-verify-empty-stack 63 :nope) - (if (/= *fop-stack-pointer* *fop-stack-pointer-on-entry*) - (error "Fasl stack not empty. Bug!"))) - -;;;; Loading symbols: - -(defvar *load-symbol-buffer* (make-string 100)) -(defvar *load-symbol-buffer-size* 100) - -(macrolet ((frob (name code name-size package) - (let ((n-package (gensym)) - (n-size (gensym)) - (n-buffer (gensym))) - `(define-fop (,name ,code) - (prepare-for-fast-read-byte *fasl-file* - (let ((,n-package ,package) - (,n-size (fast-read-u-integer ,name-size))) - (when (> ,n-size *load-symbol-buffer-size*) - (setq *load-symbol-buffer* - (make-string (setq *load-symbol-buffer-size* - (* ,n-size 2))))) - (done-with-fast-read-byte) - (let ((,n-buffer *load-symbol-buffer*)) - (read-n-bytes *fasl-file* ,n-buffer 0 ,n-size) - (push-table (intern* ,n-buffer ,n-size ,n-package))))))))) - (frob fop-symbol-save 6 4 *package*) - (frob fop-small-symbol-save 7 1 *package*) - (frob fop-lisp-symbol-save 75 4 *lisp-package*) - (frob fop-lisp-small-symbol-save 76 1 *lisp-package*) - (frob fop-keyword-symbol-save 77 4 *keyword-package*) - (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) - - (frob fop-symbol-in-package-save 8 4 - (svref *current-fop-table* (fast-read-u-integer 4))) - (frob fop-small-symbol-in-package-save 9 1 - (svref *current-fop-table* (fast-read-u-integer 4))) - (frob fop-symbol-in-byte-package-save 10 4 - (svref *current-fop-table* (fast-read-u-integer 1))) - (frob fop-small-symbol-in-byte-package-save 11 1 - (svref *current-fop-table* (fast-read-u-integer 1)))) - -(clone-fop (fop-uninterned-symbol-save 12) - (fop-uninterned-small-symbol-save 13) - (let* ((arg (clone-arg)) - (res (make-string arg))) - (read-n-bytes *fasl-file* res 0 arg) - (push-table (make-symbol res)))) - -(define-fop (fop-package 14) - (let ((name (pop-stack))) - (or (find-package name) - (error "The package ~S does not exist." name)))) - -;;;; Loading numbers: - -(clone-fop (fop-integer 33) - (fop-small-integer 34) - (load-s-integer (clone-arg))) - -(define-fop (fop-word-integer 35) - (prepare-for-fast-read-byte *fasl-file* - (prog1 - (fast-read-s-integer 4) - (done-with-fast-read-byte)))) -(define-fop (fop-byte-integer 36) - (prepare-for-fast-read-byte *fasl-file* - (prog1 - (fast-read-s-integer 1) - (done-with-fast-read-byte)))) - -(define-fop (fop-ratio 70) - (let ((den (pop-stack))) - (%primitive make-ratio (pop-stack) den))) - -(define-fop (fop-complex 71) - (let ((im (pop-stack))) - (%primitive make-complex (pop-stack) im))) - -(define-fop (fop-float 45) - (let* ((n (read-arg 1)) - (exponent (load-s-integer (ceiling n 8))) - (m (read-arg 1)) - (mantissa (load-s-integer (ceiling m 8))) - (number (cond ((or (> n 9) (> m 32)) - (coerce mantissa 'long-float)) - ((> m 21) - (coerce mantissa 'single-float)) - (T (coerce mantissa 'short-float))))) - (multiple-value-bind (f ex s) (decode-float number) - (declare (ignore ex)) - (* s (scale-float f exponent))))) - -;;;; Loading lists: - -(define-fop (fop-list 15) - (do ((res () (cons (pop-stack) res)) - (n (read-arg 1) (1- n))) - ((zerop n) res))) - -(define-fop (fop-list* 16) - (do ((res (pop-stack) (cons (pop-stack) res)) - (n (read-arg 1) (1- n))) - ((zerop n) res))) - -(macrolet ((frob (name op fun n) - `(define-fop (,name ,op) - (call-with-popped-things ,fun ,n)))) - - (frob fop-list-1 17 list 1) - (frob fop-list-2 18 list 2) - (frob fop-list-3 19 list 3) - (frob fop-list-4 20 list 4) - (frob fop-list-5 21 list 5) - (frob fop-list-6 22 list 6) - (frob fop-list-7 23 list 7) - (frob fop-list-8 24 list 8) - - (frob fop-list*-1 25 list* 2) - (frob fop-list*-2 26 list* 3) - (frob fop-list*-3 27 list* 4) - (frob fop-list*-4 28 list* 5) - (frob fop-list*-5 29 list* 6) - (frob fop-list*-6 30 list* 7) - (frob fop-list*-7 31 list* 8) - (frob fop-list*-8 32 list* 9)) - - -;;;; Loading arrays: -;;; - -(clone-fop (fop-string 37) - (fop-small-string 38) - (let* ((arg (clone-arg)) - (res (make-string arg))) - (read-n-bytes *fasl-file* res 0 arg) - res)) - -(clone-fop (fop-vector 39) - (fop-small-vector 40) - (let* ((size (clone-arg)) - (res (make-array size))) - (declare (fixnum size)) - (do ((n (1- size) (1- n))) - ((minusp n)) - (setf (svref res n) (pop-stack))) - res)) - -(clone-fop (fop-uniform-vector 41) - (fop-small-uniform-vector 42) - (make-array (clone-arg) :initial-element (pop-stack))) - -(define-fop (fop-array 83) - (let* ((rank (read-arg 4)) - (vec (pop-stack)) - (size (+ rank %array-first-dim-slot)) - (length (length vec)) - (res (%primitive alloc-array rank))) - (declare (simple-array vec)) - (set-array-header res vec length length 0 - (do ((i (1- size) (1- i)) - (dimensions () (cons (pop-stack) dimensions))) - ((< i %array-first-dim-slot) dimensions)) - nil) - res)) - - -;;; FOP-INT-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. -;;; This must be packed according to the local byte-ordering, allowing us to -;;; directly read the bits. -;;; -(define-fop (fop-int-vector 43) - (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)) - res))) - - -(define-fop (fop-uniform-int-vector 44) - (prepare-for-fast-read-byte *fasl-file* - (let* ((n (fast-read-u-integer 4)) - (size (fast-read-byte)) - (value (fast-read-variable-u-integer (ceiling size 8)))) - (done-with-fast-read-byte) - (make-array n :element-type `(unsigned-byte ,size) - :initial-element value)))) - -(define-fop (fop-alter 52 nil) - (let ((index (read-arg 1)) - (newval (pop-stack)) - (object (pop-stack))) - (declare (fixnum index)) - (typecase object - (list (case index - (0 (rplaca object newval)) - (1 (rplacd object newval)) - (t (error "~S: Bad index for FaslOP Alter. Bug!")))) - (symbol (case index - (0 (set object newval)) - (1 (setf (symbol-function object) newval)) - (2 (setf (symbol-plist object) newval)) - (t (error "~S: Bad index for FaslOP Alter. Bug!")))) - (array (setf (aref object index) newval)) - (t (error "~S: Bad object for FaslOP Alter. Bug!"))))) - -(define-fop (fop-eval 53) - (let ((result (eval (pop-stack)))) - (when *load-print-stuff* - (format t "~&; ~S~%" result)) - result)) - -(define-fop (fop-eval-for-effect 54 nil) - (let ((result (eval (pop-stack)))) - (when *load-print-stuff* - (format t "~&; ~S~%" result)))) - -(define-fop (fop-funcall 55) - (let ((arg (read-arg 1))) - (if (zerop arg) - (funcall (pop-stack)) - (do ((args () (cons (pop-stack) args)) - (n arg (1- n))) - ((zerop n) (apply (pop-stack) args)))))) - -(define-fop (fop-funcall-for-effect 56 nil) - (let ((arg (read-arg 1))) - (if (zerop arg) - (funcall (pop-stack)) - (do ((args () (cons (pop-stack) args)) - (n arg (1- n))) - ((zerop n) (apply (pop-stack) args)))))) - -;;;; Fixing up circularities. -(define-fop (fop-rplaca 200 nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4)) - (val (pop-stack))) - (setf (car (nthcdr idx obj)) val))) - - -(define-fop (fop-rplacd 201 nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4)) - (val (pop-stack))) - (setf (cdr (nthcdr idx obj)) val))) - -(define-fop (fop-svset 202 nil) - (let* ((obi (read-arg 4)) - (obj (svref *current-fop-table* obi)) - (idx (read-arg 4)) - (val (pop-stack))) - (setf (svref obj idx) val))) - -(define-fop (fop-nthcdr 203 t) - (nthcdr (read-arg 4) (pop-stack))) - -;;;; Loading functions: - -(define-fop (fop-code-format 57 :nope) - (setq *current-code-format* (read-arg 1))) - - -;;; Load-Code loads a code object. NItems objects are popped off the stack for -;;; the boxed storage section, then Size bytes of code are read in. This must -;;; be done WITHOUT-GCING, since GC only recognizes code object references that -;;; appear in a function object. If a GC happened before we stored the code -;;; object, the code would disappear. -;;; -(defmacro load-code (nitems size) - `(without-gcing - (let ((box-num ,nitems) - (code-length ,size)) - (declare (fixnum box-num code-length)) - (let ((function (%primitive alloc-function box-num))) - (%primitive set-vector-subtype function %function-constants-subtype) - (do ((index (1- box-num) (1- index))) - ((minusp index)) - (declare (fixnum index)) - (%primitive header-set function index (pop-stack))) - (let ((code (%primitive alloc-code code-length))) - (read-n-bytes *fasl-file* code 0 code-length) - (%primitive header-set function %function-code-slot code)) - (when *load-print-stuff* - (format t "~&; ~S~%" function)) - function)))) - -(define-fop (fop-code 58) - (if (eql *current-code-format* %fasl-code-format) - (load-code (read-arg 4) (read-arg 4)) - (error "~A has an incompatible fasl file format.~@ - You must recompile the source code." - *fasl-file*))) - - -(define-fop (fop-small-code 59) - (if (eql *current-code-format* %fasl-code-format) - (load-code (read-arg 1) (read-arg 2)) - (error "~A has an incompatible fasl file format.~@ - You must recompile the source code." - *fasl-file*))) - - -;;; Now a NOOP except in cold load... -(define-fop (fop-fset 74 nil) - (pop-stack) - (pop-stack)) - - -;;; Modify a slot in a Constants object. -;;; -(clone-fop (fop-alter-code 140 nil) (fop-byte-alter-code 141) - (let ((value (pop-stack)) - (code (pop-stack)) - (index (clone-arg))) - (%primitive header-set code index value))) - - -;;; Kind of like Load-Code, 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. -;;; -(define-fop (fop-function-entry 142) - (let* ((box-num (read-arg 1)) - (function (%primitive alloc-function box-num))) - ;; - ;; Pop boxed things, storing them in the allocated entry object. - (do ((index (1- box-num) (1- index))) - ((minusp index)) - (%primitive header-set function index (pop-stack))) - ;; - ;; Set the subtype of the entry object. - (%primitive set-vector-subtype function (pop-stack)) - ;; - ;; Set code and constants slots in the entry. - (let* ((constants (pop-stack)) - (code (%primitive header-ref constants %function-code-slot))) - (%primitive header-set function %function-code-slot code) - (%primitive header-set function %function-entry-constants-slot - constants)) - - function)) - - - -(define-fop (fop-user-miscop-fixup 134) - (let* ((miscop-name (pop-stack)) - (function-object (pop-stack)) - (code (%primitive header-ref function-object %function-code-slot)) - (offset (read-arg 4)) - (loaded-addr (get miscop-name '%loaded-address))) - (unless loaded-addr - (error "Miscop ~A is undefined." miscop-name)) - - (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))) - - function-object)) - - -;;;; Loading assembler routines: -;;; - -;;; Allocate-Assembler-Code -- Internal -;;; -;;; Allocate some stuff out of assembler code space. -;;; -(defun allocate-assembler-code (bytes) - (let* ((idx (ash %assembler-code-type %alloc-ref-type-shift)) - (free (alloc-ref idx)) - (new (+ free bytes))) - (prog1 - (%primitive make-immediate-type free %assembler-code-type) - (%primitive 16bit-system-set alloctable-address idx (ash new -16)) - (%primitive 16bit-system-set alloctable-address (1+ idx) - (logand new #xFFFF))))) - -(define-fop (fop-assembler-routine 130) - (let* ((code-length (read-arg 4)) - (buffer (make-array code-length :element-type '(unsigned-byte 8))) - (code (allocate-assembler-code code-length))) - (declare (fixnum code-length)) - (read-n-bytes *fasl-file* buffer 0 code-length) - (%primitive byte-blt buffer 0 code 0 code-length) - code)) - -;;; A list of the miscop definitions which have been loaded but not -;;; resolved. Each element is a cons (name . code-ptr). -;;; -(defvar *miscop-definitions* ()) - - -;;; 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. -;;; -(defvar *external-references* ()) -(defvar *user-defined-miscops* ()) - -(define-fop (fop-fixup-miscop-routine 131 nil) - (let* ((external-references (pop-stack)) - (external-labels (pop-stack)) - (name (pop-stack)) - (code (pop-stack)) - (start (%primitive make-immediate-type code %+-fixnum-type))) - (dolist (lab external-labels) - (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start))) - (push (cons name external-references) *external-references*) - (push (cons name code) *miscop-definitions*))) - -(define-fop (fop-fixup-user-miscop-routine 133 nil) - (let* ((external-references (pop-stack)) - (external-labels (pop-stack)) - (name (pop-stack)) - (code (pop-stack)) - (start (%primitive make-immediate-type code %+-fixnum-type))) - (dolist (lab external-labels) - (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start))) - (push (cons name external-references) *external-references*) - (pushnew name *user-defined-miscops*) - (setf (get name 'user-miscop) t))) - -(define-fop (fop-fixup-assembler-routine 132 nil) - (let* ((external-references (pop-stack)) - (external-labels (pop-stack)) - (name (pop-stack)) - (code (pop-stack)) - (start (%primitive make-immediate-type code %+-fixnum-type))) - (dolist (lab external-labels) - (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start))) - (push (cons name external-references) *external-references*))) - -;;; Resolving all the assembler routines' references. - -;;; Patch-Instruction -- Internal -;;; -;;; Used to patch an assembler code object. Hi-var and lo-var are -;;; bound to the values of the high and low halfwords in the instruction. -;;; The values may by changed by setting the variables. -;;; -(defmacro patch-instruction ((hi-var lo-var code offset) &body body) - `(let ((,hi-var (%primitive 16bit-system-ref ,code ,offset)) - (,lo-var (%primitive 16bit-system-ref ,code (1+ ,offset)))) - (multiple-value-prog1 - (progn ,@body) - (%primitive 16bit-system-set ,code ,offset ,hi-var) - (%primitive 16bit-system-set ,code (1+ ,offset) ,lo-var)))) - -;;; Resolve-Loaded-Assembler-References -- Public -;;; -;;; Fix up the recorded external references and define the miscops. -;;; -(defun resolve-loaded-assembler-references () - "This function resolves external label references in loaded assembler - routines. It should be called after assembler files have been loaded. - Miscop definitions do not take effect until this function is called." - (dolist (reflist *external-references*) - (let* ((code-byte-offset (get (car reflist) '%loaded-address)) - (code-halfword-offset (ash code-byte-offset -1)) - (address (%primitive make-immediate-type code-byte-offset - %assembler-code-type))) - (dolist (refs (cdr reflist)) - (let ((how (car refs)) - (label (get (cadr refs) '%loaded-address)) - (location (caddr refs))) - (unless label - (error "~A references ~A, which has not been defined.~%" - (car reflist) (cadr refs))) - (let ((offset (- (- (ash label -1) code-halfword-offset) location))) - (ecase how - (clc::ji - (unless (<= #x-80 offset #x7F) - (error "Offset #X~X out of JI range for ~A to reference ~A.~%" - offset (car reflist) (cadr refs))) - (patch-instruction (hi lo address location) - (setf (ldb (byte 8 0) hi) offset))) - (clc::bi - (unless (<= #x-80000 offset #x7FFFF) - (error "Offset #X~X out of BI range for ~A to reference ~A.~%" - offset (car reflist) (cadr refs))) - (patch-instruction (hi lo address location) - (setf (ldb (byte 4 0) hi) (ash offset -16)) - (setq lo (logand offset #xFFFF)))) - (clc::ba (error "I can't resolve a BA reference yet.~%")) - (clc::l (error "I can't resolve an L reference yet.~%")))))))) - (setq *external-references* ()) - - (dolist (mo *miscop-definitions*) - (let* ((name (intern (symbol-name (car mo)) (find-package "COMPILER"))) - (index (get name 'clc::transfer-vector-index))) - (if index - (%primitive write-control-stack - (%primitive make-immediate-type (ash index 2) - %assembler-code-type) - (cdr mo)) - (pushnew name *user-defined-miscops*)))) - (setq *miscop-definitions* ())) - -(proclaim '(notinline read-byte)) diff --git a/code/machdef.lisp b/code/machdef.lisp deleted file mode 100644 index 2d3471e46ee06571de4a520d407b654a9bf3300d..0000000000000000000000000000000000000000 --- a/code/machdef.lisp +++ /dev/null @@ -1,105 +0,0 @@ -;;; -*- Log: code.log; Package: Mach -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; 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)) - -(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))) - -(defalien timeval timeval (record-size 'timeval)) - -(defrecord timezone - (minuteswest (signed-byte 32) (long-words 1)) - (dsttime (signed-byte 32) (long-words 1))) - -(defalien timezone timezone (record-size 'timezone)) - -(eval-when (compile load eval) -(defrecord int1 - (int (signed-byte 32) (long-words 1))) - -(defalien int1 int1 (record-size 'int1)) - -(defrecord int2 - (int (signed-byte 32) (long-words 1))) - -(defalien int2 int2 (record-size 'int2)) - -(defrecord int3 - (int (signed-byte 32) (long-words 1))) - -(defalien int3 int3 (record-size 'int3)) - -(defrecord sigcontext - (onstack (unsigned-byte 32) (long-words 1)) - (mask (unsigned-byte 32) (long-words 1)) - (sctx-fpa (unsgined-byte 32) (long-words 1)) - (sp (unsigned-byte 32) (long-words 1)) - (fp (unsigned-byte 32) (long-words 1)) - (ap (unsigned-byte 32) (long-words 1)) - (iar (unsigned-byte 32) (long-words 1)) - (icscs (unsigned-byte 32) (long-words 1))) -(defalien sigcontext sigcontext (record-size 'sigcontext)) - - -(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))) -(defalien tchars tchars (record-size 'tchars)) - -(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))) -(defalien ltchars ltchars (record-size 'ltchars)) - -); eval-when (compile load eval) - - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* t)) - -(defmacro sigmask (signal) - "Returns a mask given a signal." - `(ash 1 (1- ,(unix-signal-number signal)))) - -(defmacro with-trap-arg-block (arg-var alien-var &body forms) - `(progn (unless *free-trap-arg-blocks* (alloc-trap-arg-block)) - (let ((*free-trap-arg-blocks* (cdr *free-trap-arg-blocks*)) - (,arg-var (car *free-trap-arg-blocks*))) - (alien-bind ((,alien-var ,arg-var ,arg-var T)) - ,@forms)))) -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* nil)) diff --git a/code/macros.lisp b/code/macros.lisp deleted file mode 100644 index d596068506e8e3818be1552e6ee2c34aa37590e5..0000000000000000000000000000000000000000 --- a/code/macros.lisp +++ /dev/null @@ -1,1530 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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 macros that are part of the standard -;;; Spice Lisp environment. -;;; -;;; Written by Scott Fahlman and Rob MacLachlan. -;;; Modified by Bill Chiles to adhere to -;;; -(in-package 'lisp) -(export '(defvar defparameter defconstant when unless loop setf - defsetf define-setf-method psetf shiftf rotatef push pushnew pop - incf decf remf case typecase with-open-file - with-open-stream with-input-from-string with-output-to-string - locally etypecase ctypecase ecase ccase - get-setf-method get-setf-method-multiple-value - define-modify-macro - otherwise)) ; Sacred to CASE and related macros. - -(in-package "EXTENSIONS") -(export '(do-anonymous collect iterate)) - -(in-package "LISP") - - -;;; Parse-Body -- Public -;;; -;;; Parse out declarations and doc strings, *not* expanding macros. -;;; Eventually the environment arg should be flushed, since macros can't expand -;;; into declarations anymore. -;;; -(defun parse-body (body environment &optional (doc-string-allowed t)) - "This function is to parse the declarations and doc-string out of the body of - a defun-like form. Body is the list of stuff which is to be parsed. - Environment is ignored. If Doc-String-Allowed is true, then a doc string - will be parsed out of the body and returned. If it is false then a string - will terminate the search for declarations. Three values are returned: the - tail of Body after the declarations and doc strings, a list of declare forms, - and the doc-string, or NIL if none." - (declare (ignore environment)) - (let ((decls ()) - (doc nil)) - (do ((tail body (cdr tail))) - ((endp tail) - (values tail (nreverse decls) doc)) - (let ((form (car tail))) - (cond ((and (stringp form) (cdr tail)) - (if doc-string-allowed - (setq doc form) - (return (values tail (nreverse decls) doc)))) - ((not (and (consp form) (symbolp (car form)))) - (return (values tail (nreverse decls) doc))) - ((eq (car form) 'declare) - (push form decls)) - (t - (return (values tail (nreverse decls) doc)))))))) - - -;;;; DEFMACRO: - -#-new-compiler -(proclaim '(special *in-compilation-unit*)) - -(defparameter defmacro-error-string "Macro ~S cannot be called with ~S args.") - -;;; Defmacro -- Public -;;; -;;; Parse the definition and make an expander function. The actual -;;; definition is done by %defmacro which we expand into. -;;; -(defmacro defmacro (name lambda-list &body body) - (let ((whole (gensym)) (environment (gensym))) - (multiple-value-bind - (body local-decs doc) - (parse-defmacro lambda-list whole body name - :environment environment - :error-string 'defmacro-error-string) - (let ((def `(lambda (,whole ,environment) - ,@local-decs - (block ,name - ,body)))) - ;; - ;; ### Bootstrap hack... - ;; When in old compiler, call %%defmacro with #'(lambda ...) so that - ;; the function gets compiled. When in old interpreter (neither in old - ;; or new compiler), just setf the macro-function so that we can have - ;; interpreted macros. - (cond #-new-compiler - (system:*in-the-compiler* - `(c::%%defmacro ',name #',def ,doc)) - #-new-compiler - ((not *in-compilation-unit*) - `(setf (symbol-function ',name) - (cons 'macro #',def))) - (t - `(c::%defmacro ',name - #+new-compiler #',def - #-new-compiler ',def - ',lambda-list ,doc))))))) - - -(eval-when (compile load eval) - -;;; %Defmacro, %%Defmacro -- Internal -;;; -;;; Defmacro expands into %Defmacro which is a function that is treated -;;; magically the compiler. After the compiler has gotten the information it -;;; wants out of macro definition, it compiles a call to %%Defmacro which -;;; happens at load time. We have a %Defmacro function which just calls -;;; %%Defmacro in order to keep the interpreter happy. -;;; -;;; Eventually %%Defmacro should deal with clearing old compiler information -;;; for the functional value. -;;; -(defun c::%defmacro (name definition lambda-list doc) - #+new-compiler - ;; ### bootstrap hack... - ;; This WHEN only necessary to make cross-compiling of this file work. - ;; Necessary because the EVAL-WHEN COMPILE goes into the bootstrap - ;; environment, but is read with the NEW-COMPILER feature. - (when (fboundp 'eval:interpreted-function-p) - (assert (eval:interpreted-function-p definition)) - (setf (eval:interpreted-function-name definition) - (format nil "DEFMACRO ~S" name)) - (setf (eval:interpreted-function-arglist definition) lambda-list)) - (c::%%defmacro name definition doc)) -;;; -(defun c::%%defmacro (name definition doc) - (clear-info function where-from name) - (setf (info function macro-function name) definition) - (setf (info function kind name) :macro) - (setf (documentation name 'function) doc) - name) - -); Eval-When - -;;; ### Bootstrap hack... -;;; -;;; Redefine the top-level defmacro handler to do nothing special when -;;; *bootstrap-defmacro* is true so that our defmacro gets called. -;;; -#-new-compiler -(eval-when (compile load eval) - (defvar *old-pdm* #'clc::process-defmacro) - (defvar *bootstrap-defmacro* nil) - (defun clc::process-defmacro (form) - (ecase *bootstrap-defmacro* - ((t) - (clc::process-random (macroexpand form) nil)) - ((nil) - (funcall *old-pdm* form)) - (:both - (clc::process-random (macroexpand form) nil) - (funcall *old-pdm* form)))))) - -;;; ### Bootstrap hack... -;;; At load time, get defmacro from the old place and store it in the new -;;; place. -#-new-compiler -(c::%%defmacro 'defmacro (macro-function 'defmacro) nil) - - -;;; ### Bootstrap hack... -;;; Install macro definitions in this file only into the new compiler's -;;; environment. -(eval-when (compile) - (setq *bootstrap-defmacro* t)) - - -;;; DEFTYPE is a lot like DEFMACRO. - -(defparameter deftype-error-string "Type ~S cannot be used with ~S args.") - -(defmacro deftype (name arglist &body body) - "Syntax like DEFMACRO, but defines a new type." - (unless (symbolp name) - (error "~S -- Type name not a symbol." name)) - - (let ((whole (gensym))) - (multiple-value-bind (body local-decs doc) - (parse-defmacro arglist whole body name - :default-default ''* - :error-string 'deftype-error-string - ) - `(eval-when (compile load eval) - (%deftype ',name - #'(lambda (,whole) ,@local-decs (block ,name ,body)) - ,@(when doc `(,doc))))))) -;;; -(defun %deftype (name expander &optional doc) - (setf (info type kind name) :defined) - (setf (info type expander name) expander) - (when doc - (setf (documentation name 'type) doc)) - (c::%note-type-defined name) - name) - - -;;; And so is DEFINE-SETF-METHOD. - -(defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.") - -(compiler-let ((*bootstrap-defmacro* :both)) - -(defmacro define-setf-method (access-fn lambda-list &body body) - "Syntax like DEFMACRO, but creates a Setf-Method generator. The body - must be a form that returns the five magical values." - (unless (symbolp access-fn) - (error "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD." - access-fn)) - - (let ((whole (gensym)) (environment (gensym))) - (multiple-value-bind (body local-decs doc) - (parse-defmacro lambda-list whole body access-fn - :environment environment - :error-string 'defsetf-error-string) - `(eval-when (load compile eval) - (setf (info setf inverse ',access-fn) nil) - (setf (info setf expander ',access-fn) - #'(lambda (,whole ,environment) - ,@local-decs - (block ,access-fn ,body))) - ,@(when doc - `((setf (documentation ',access-fn 'setf) ,doc))) - ',access-fn)))) - -); compiler-let - - -;;;; Defun, Defvar, Defparameter, Defconstant: - -;;; Defun -- Public -;;; -;;; Very similar to Defmacro, but simpler. We don't have to parse the -;;; lambda-list. -;;; -(defmacro defun (name lambda-list &body (body decls doc) &whole source) - (let ((def `(lambda ,lambda-list - ,@decls - (block ,(if (and (consp name) (eq (car name) 'setf)) - (cadr name) - name) - ,@body)))) - `(c::%defun ',name #',def ,doc ',source))) - - -;;; %Defun, %%Defun -- Internal -;;; -;;; Similar to %Defmacro, ... -;;; -(defun c::%%defun (name def doc &optional inline-expansion) - (setf (fdefinition name) def) - (when doc - (if (and (consp name) (eq (first name) 'setf)) - (setf (documentation (second name) 'setf) doc) - (setf (documentation name 'function) doc))) - - (unless (eq (info function kind name) :function) - (setf (info function kind name) :function)) - - (when (info function accessor-for name) - (setf (info function accessor-for name) nil)) - - (when (or inline-expansion - (info function inline-expansion name)) - (setf (info function inline-expansion name) inline-expansion)) - name) -;;; -(defun c::%defun (name def doc source) - (declare (ignore source)) - #+new-compiler - (assert (eval:interpreted-function-p def)) - #+new-compiler - (setf (eval:interpreted-function-name def) name) - (c::%%defun name def doc)) - - -;;; DEFCONSTANT -- Public -;;; -(defmacro defconstant (var val &optional doc) - "For defining global constants at top level. The DEFCONSTANT says that the - value is constant and may be compiled into code. If the variable already has - a value, and this is not equal to the init, an error is signalled. The third - argument is an optional documentation string for the variable." - `(c::%defconstant ',var ,val ',doc)) - -;;; %Defconstant, %%Defconstant -- Internal -;;; -;;; Like the other %mumbles except that we currently actually do something -;;; interesting at load time, namely checking if the constant is being -;;; redefined. -;;; -(defun c::%defconstant (name value doc) - (c::%%defconstant name value doc)) -;;; -(defun c::%%defconstant (name value doc) - (when doc - (setf (documentation name 'variable) doc)) - (when (boundp name) - (unless (equalp (symbol-value name) value) - (cerror "Go ahead and change the value." - "Constant ~S being redefined." name))) - (setf (symbol-value name) value) - (setf (info variable kind name) :constant) - (clear-info variable constant-value name) - name) - - -(defmacro defvar (var &optional (val nil valp) (doc nil docp)) - "For defining global variables at top level. Declares the variable - SPECIAL and, optionally, initializes it. If the variable already has a - value, the old value is not clobbered. The third argument is an optional - documentation string for the variable." - `(progn - (proclaim '(special ,var)) - ,@(when valp - `((unless (boundp ',var) - (setq ,var ,val)))) - ,@(when docp - `((setf (documentation ',var 'variable) ',doc))) - ',var)) - -(defmacro defparameter (var val &optional (doc nil docp)) - "Defines a parameter that is not normally changed by the program, - but that may be changed without causing an error. Declares the - variable special and sets its value to VAL. The third argument is - an optional documentation string for the parameter." - `(progn - (proclaim '(special ,var)) - (setq ,var ,val) - ,@(when docp - `((setf (documentation ',var 'variable) ',doc))) - ',var)) - - -;;;; ASSORTED CONTROL STRUCTURES - - -(defmacro when (test &body forms) - "First arg is a predicate. If it is non-null, the rest of the forms are - evaluated as a PROGN." - `(cond (,test nil ,@forms))) - -(defmacro unless (test &rest forms) - "First arg is a predicate. If it is null, the rest of the forms are - evaluated as a PROGN." - `(cond ((not ,test) nil ,@forms))) - - -(defmacro return (&optional (value nil)) - `(return-from nil ,value)) - -(defmacro prog (varlist &body (body decls)) - `(block nil - (let ,varlist - ,@decls - (tagbody ,@body)))) - -(defmacro prog* (varlist &body (body decls)) - `(block nil - (let* ,varlist - ,@decls - (tagbody ,@body)))) - - -;;; Prog1, Prog2 -- Public -;;; -;;; These just turn into a Let. -;;; -(defmacro prog1 (result &rest body) - (let ((n-result (gensym))) - `(let ((,n-result ,result)) - ,@body - ,n-result))) -;;; -(defmacro prog2 (form1 result &rest body) - `(prog1 (progn ,form1 ,result) ,@body)) - - -;;; And, Or -- Public -;;; -;;; AND and OR are defined in terms of IF. -;;; -(defmacro and (&rest forms) - (cond ((endp forms) t) - ((endp (rest forms)) (first forms)) - (t - `(if ,(first forms) - (and ,@(rest forms)) - nil)))) -;;; -(defmacro or (&rest forms) - (cond ((endp forms) nil) - ((endp (rest forms)) (first forms)) - (t - (let ((n-result (gensym))) - `(let ((,n-result ,(first forms))) - (if ,n-result - ,n-result - (or ,@(rest forms)))))))) - - -;;; Cond -- Public -;;; -;;; COND also turns into IF. -;;; -(defmacro cond (&rest clauses) - (if (endp clauses) - nil - (let ((clause (first clauses))) - (when (atom clause) - (error "Cond clause is not a list: ~S." clause)) - (let ((test (first clause)) - (forms (rest clause))) - (if (endp forms) - (let ((n-result (gensym))) - `(let ((,n-result ,test)) - (if ,n-result - ,n-result - (cond ,@(rest clauses))))) - `(if ,test - (progn ,@forms) - (cond ,@(rest clauses)))))))) - - -;;;; Multiple value macros: - -;;; Multiple-Value-XXX -- Public -;;; -;;; All the multiple-value receiving forms are defined in terms of -;;; Multiple-Value-Call. -;;; -(defmacro multiple-value-setq (varlist value-form) - (unless (and (listp varlist) (every #'symbolp varlist)) - (error "Varlist is not a list of symbols: ~S." varlist)) - (let ((temps (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) varlist))) - `(multiple-value-bind ,temps ,value-form - ,@(mapcar #'(lambda (var temp) - `(setq ,var ,temp)) - varlist temps) - ,(car temps)))) -;;; -(defmacro multiple-value-bind (varlist value-form &body body) - (unless (and (listp varlist) (every #'symbolp varlist)) - (error "Varlist is not a list of symbols: ~S." varlist)) - (if (= (length varlist) 1) - `(let ((,(car varlist) ,value-form)) - ,@body) - (let ((ignore (gensym))) - `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore) - (declare (ignore ,ignore)) - ,@body) - ,value-form)))) -;;; -(defmacro multiple-value-list (value-form) - `(multiple-value-call #'list ,value-form)) - - -;;;; SETF and friends. - -;;; Note: The expansions for SETF and friends sometimes create needless -;;; LET-bindings of argument values. The compiler will remove most of -;;; these spurious bindings, so SETF doesn't worry too much about creating -;;; them. - -;;; The inverse for a generalized-variable reference function is stored in -;;; one of two ways: -;;; -;;; A SETF-INVERSE property corresponds to the short form of DEFSETF. It is -;;; the name of a function takes the same args as the reference form, plus a -;;; new-value arg at the end. -;;; -;;; A SETF-METHOD-EXPANDER property is created by the long form of DEFSETF or -;;; by DEFINE-SETF-METHOD. It is a function that is called on the reference -;;; form and that produces five values: a list of temporary variables, a list -;;; of value forms, a list of the single store-value form, a storing function, -;;; and an accessing function. - -(eval-when (compile load eval) - -;;; ### bootstrap hack... -;;; Rename get-setf-method so that we don't blow away setf in the bootstrap -;;; lisp. All references in this file are to the renamed function, and should -;;; eventually be renamed back. -;;; -#+new-compiler -(defun get-setf-method (form &optional environment) - (foo-get-setf-method form environment)) -;;; -(defun foo-get-setf-method (form &optional environment) - "Returns five values needed by the SETF machinery: a list of temporary - variables, a list of values with which to fill them, the temporary for the - new value in a list, the setting function, and the accessing function." - (let (temp) - (cond ((symbolp form) - (let ((new-var (gensym))) - (values nil nil (list new-var) `(setq ,form ,new-var) form))) - ((atom form) - (error "~S illegal atomic form for GET-SETF-METHOD." form)) - ;; - ;; ### Bootstrap hack... - ;; Ignore any DEFSETF info for structure accessors. - ((info function accessor-for (car form)) - (get-setf-method-inverse form `(funcall #'(setf ,(car form))))) - ((setq temp (info setf inverse (car form))) - (get-setf-method-inverse form `(,temp))) - ((setq temp (info setf expander (car form))) - (funcall temp form environment)) - (t - (multiple-value-bind (res win) - (macroexpand-1 form environment) - (if win - (foo-get-setf-method res environment) - (get-setf-method-inverse - form - `(funcall #'(setf ,(car form)))))))))) - -(defun get-setf-method-inverse (form inverse) - (let ((new-var (gensym)) - (vars nil) - (vals nil)) - (dolist (x (cdr form)) - (push (gensym) vars) - (push x vals)) - (setq vals (nreverse vals)) - (values vars vals (list new-var) - `(,@inverse ,@vars ,new-var) - `(,(car form) ,@vars)))) - - -(defun get-setf-method-multiple-value (form &optional environment) - "Like Get-Setf-Method, but may return multiple new-value variables." - (get-setf-method form environment)) - -(defun defsetter (fn rest env) - (let* ((arglist (car rest)) - (new-var (car (cadr rest))) - (%arg-count 0) - (%min-args 0) - (%restp nil) - (%let-list nil) - (%keyword-tests nil)) - (declare (special %arg-count %min-args %restp %let-list %keyword-tests)) - (multiple-value-bind (body local-decs doc) - (parse-body (cddr rest) env) - ;; Analyze the defmacro argument list. - (analyze1 arglist '(cdr %access-arglist) fn '%access-arglist) - ;; Now build the body of the transform. - (values - `(lambda (%access-arglist ,new-var) - ,@(when (null arglist) - '((declare (ignore %access-arglist)))) - (let* ,(nreverse %let-list) - ,@ local-decs - ,@ %keyword-tests - ,@ body)) - doc)))) - -) ; End of Eval-When. - - -(compiler-let ((*bootstrap-defmacro* :both)) - -(defmacro defsetf (access-fn &rest rest &environment env) - "Associates a SETF update function or macro with the specified access - function or macro. The format is complex. See the manual for - details." - (cond ((not (listp (car rest))) - `(eval-when (load compile eval) - (setf (info setf inverse ',access-fn) ',(car rest)) - ;; - ;; ### Bootstrap hack... - ;; In bootstrap env, also install inverse in old place so that we - ;; can still compile defstructs. - #-new-compiler - (setf (get ',access-fn 'setf-inverse) ',(car rest)) - (setf (info setf expander ',access-fn) nil) - ,@(if (and (car rest) (stringp (cadr rest))) - `((eval-when (load eval) - (%put ',access-fn '%setf-documentation ,(cadr rest))))) - ',access-fn)) - ((and (listp (car rest)) (cdr rest) (listp (cadr rest))) - (if (not (= (length (cadr rest)) 1)) - (cerror "Ignore the extra items in the list." - "Only one new-value variable allowed in DEFSETF.")) - (multiple-value-bind (setting-form-generator doc) - (defsetter access-fn rest env) - `(eval-when (load compile eval) - (setf (info setf inverse ',access-fn) nil) - (setf (info setf expander ',access-fn) - #'(lambda (access-form environment) - (declare (ignore environment)) - (do* ((args (cdr access-form) (cdr args)) - (dummies nil (cons (gensym) dummies)) - (newval-var (gensym)) - (new-access-form nil)) - ((atom args) - (setq new-access-form - (cons (car access-form) dummies)) - (values - dummies - (cdr access-form) - (list newval-var) - (funcall (function ,setting-form-generator) - new-access-form newval-var) - new-access-form))))) - ,@(if doc - `((eval-when (load eval) - (%put ',access-fn '%setf-documentation ',doc))) - `((eval-when (load eval) ;SKH 4/17/84 - (remprop ',access-fn '%setf-documentation)))) - ',access-fn))) - (t (error "Ill-formed DEFSETF for ~S." access-fn)))) - -); Compiler-Let - -(defmacro setf (&rest args &environment env) - "Takes pairs of arguments like SETQ. The first is a place and the second - is the value that is supposed to go into that place. Returns the last - value. The place argument may be any of the access forms for which SETF - knows a corresponding setting form." - (let ((temp (length args))) - (cond ((= temp 2) - (cond ((atom (car args)) - `(setq ,(car args) ,(cadr args))) - ((info function accessor-for (caar args)) - `(funcall #'(setf ,(caar args)) ,@(cdar args) ,(cadr args))) - ((setq temp (info setf inverse (caar args))) - `(,temp ,@(cdar args) ,(cadr args))) - (t (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method (car args) env) - (declare (ignore getter)) - (do* ((d dummies (cdr d)) - (v vals (cdr v)) - (let-list nil)) - ((null d) - (setq let-list - (nreverse (cons (list (car newval) - (cadr args)) - let-list))) - `(let* ,let-list ,setter)) - (setq let-list - (cons (list (car d) (car v)) let-list))))))) - ((oddp temp) - (error "Odd number of args to SETF.")) - (t (do ((a args (cddr a)) (l nil)) - ((null a) `(progn ,@(nreverse l))) - (setq l (cons (list 'setf (car a) (cadr a)) l))))))) - - -(defmacro psetf (&rest args &environment env) - "This is to SETF as PSETQ is to SETQ. Args are alternating place - expressions and values to go into those places. All of the subforms and - values are determined, left to right, and only then are the locations - updated. Returns NIL." - (do ((a args (cddr a)) - (let-list nil) - (setf-list nil)) - ((atom a) - `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil)) - (if (atom (cdr a)) - (error "Odd number of args to PSETF.")) - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method (car a) env) - (declare (ignore getter)) - (do* ((d dummies (cdr d)) - (v vals (cdr v))) - ((null d)) - (push (list (car d) (car v)) let-list)) - (push (list (car newval) (cadr a)) let-list) - (push setter setf-list)))) - - - -(defmacro shiftf (&rest args &environment env) - "One or more SETF-style place expressions, followed by a single - value expression. Evaluates all of the expressions in turn, then - assigns the value of each expression to the place on its left, - returning the value of the leftmost." - (if (< (length args) 2) - (error "Too few argument forms to a SHIFTF.")) - (let ((leftmost (gensym))) - (do ((a args (cdr a)) - (let-list nil) - (setf-list nil) - (next-var leftmost)) - ((atom (cdr a)) - (push (list next-var (car a)) let-list) - `(let* ,(nreverse let-list) ,@(nreverse setf-list) ,leftmost)) - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method (car a) env) - (do* ((d dummies (cdr d)) - (v vals (cdr v))) - ((null d)) - (push (list (car d) (car v)) let-list)) - (push (list next-var getter) let-list) - (push setter setf-list) - (setq next-var (car newval)))))) - - -(defmacro rotatef (&rest args &environment env) - "Takes any number of SETF-style place expressions. Evaluates all of the - expressions in turn, then assigns to each place the value of the form to - its right. The rightmost form gets the value of the leftmost. Returns NIL." - (cond ((null args) nil) - ((null (cdr args)) `(progn ,(car args) nil)) - (t (do ((a args (cdr a)) - (let-list nil) - (setf-list nil) - (next-var nil) - (fix-me nil)) - ((atom a) - (rplaca fix-me next-var) - `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil)) - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method (car a) env) - (do ((d dummies (cdr d)) - (v vals (cdr v))) - ((null d)) - (push (list (car d) (car v)) let-list)) - (push (list next-var getter) let-list) - ;; We don't know the newval variable for the last form yet, - ;; so fake it for the first getter and fix it at the end. - (unless fix-me (setq fix-me (car let-list))) - (push setter setf-list) - (setq next-var (car newval))))))) - - -(compiler-let ((*bootstrap-defmacro* :both)) - -(defmacro define-modify-macro (name lambda-list function &optional doc-string) - "Creates a new read-modify-write macro like PUSH or INCF." - (let ((other-args nil) - (rest-arg nil) - (env (gensym)) - (reference (gensym))) - - ;; Parse out the variable names and rest arg from the lambda list. - (do ((ll lambda-list (cdr ll)) - (arg nil)) - ((null ll)) - (setq arg (car ll)) - (cond ((eq arg '&optional)) - ((eq arg '&rest) - (if (symbolp (cadr ll)) - (setq rest-arg (cadr ll)) - (error "Non-symbol &rest arg in definition of ~S." name)) - (if (null (cddr ll)) - (return nil) - (error "Illegal stuff after &rest arg in Define-Modify-Macro."))) - ((memq arg '(&key &allow-other-keys &aux)) - (error "~S not allowed in Define-Modify-Macro lambda list." arg)) - ((symbolp arg) - (push arg other-args)) - ((and (listp arg) (symbolp (car arg))) - (push (car arg) other-args)) - (t (error "Illegal stuff in lambda list of Define-Modify-Macro.")))) - (setq other-args (nreverse other-args)) - `(defmacro ,name (,reference ,@lambda-list &environment ,env) - ,doc-string - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method ,reference ,env) - (do ((d dummies (cdr d)) - (v vals (cdr v)) - (let-list nil (cons (list (car d) (car v)) let-list))) - ((null d) - (push - (list (car newval) - ,(if rest-arg - `(list* ',function getter ,@other-args ,rest-arg) - `(list ',function getter ,@other-args))) - let-list) - `(let* ,(nreverse let-list) - ,setter))))))) - -); Compiler-Let - - -(defmacro push (obj place &environment env) - "Takes an object and a location holding a list. Conses the object onto - the list, returning the modified list." - (if (symbolp place) - `(setq ,place (cons ,obj ,place)) - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method place env) - (do* ((d dummies (cdr d)) - (v vals (cdr v)) - (let-list nil)) - ((null d) - (push (list (car newval) `(cons ,obj ,getter)) - let-list) - `(let* ,(nreverse let-list) - ,setter)) - (push (list (car d) (car v)) let-list))))) - - -(defmacro pushnew (obj place &rest keys &environment env) - "Takes an object and a location holding a list. If the object is already - in the list, does nothing. Else, conses the object onto the list. Returns - NIL. If there is a :TEST keyword, this is used for the comparison." - (if (symbolp place) - `(setq ,place (adjoin ,obj ,place ,@keys)) - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method place env) - (do* ((d dummies (cdr d)) - (v vals (cdr v)) - (let-list nil)) - ((null d) - (push (list (car newval) `(adjoin ,obj ,getter ,@keys)) - let-list) - `(let* ,(nreverse let-list) - ,setter)) - (push (list (car d) (car v)) let-list))))) - - -(defmacro pop (place &environment env) - "The argument is a location holding a list. Pops one item off the front - of the list and returns it." - (if (symbolp place) - `(prog1 (car ,place) (setq ,place (cdr ,place))) - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method place env) - (do* ((d dummies (cdr d)) - (v vals (cdr v)) - (let-list nil)) - ((null d) - (push (list (car newval) getter) let-list) - `(let* ,(nreverse let-list) - (prog1 (car ,(car newval)) - (setq ,(car newval) (cdr ,(car newval))) - ,setter))) - (push (list (car d) (car v)) let-list))))) - - -(define-modify-macro incf (&optional (delta 1)) + - "The first argument is some location holding a number. This number is - incremented by the second argument, DELTA, which defaults to 1.") - - -(define-modify-macro decf (&optional (delta 1)) - - "The first argument is some location holding a number. This number is - decremented by the second argument, DELTA, which defaults to 1.") - - -(defmacro remf (place indicator &environment env) - "Place may be any place expression acceptable to SETF, and is expected - to hold a property list or (). This list is destructively altered to - remove the property specified by the indicator. Returns T if such a - property was present, NIL if not." - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method place env) - (do* ((d dummies (cdr d)) - (v vals (cdr v)) - (let-list nil) - (ind-temp (gensym)) - (local1 (gensym)) - (local2 (gensym))) - ((null d) - (push (list (car newval) getter) let-list) - (push (list ind-temp indicator) let-list) - `(let* ,(nreverse let-list) - (do ((,local1 ,(car newval) (cddr ,local1)) - (,local2 nil ,local1)) - ((atom ,local1) nil) - (cond ((atom (cdr ,local1)) - (error "Odd-length property list in REMF.")) - ((eq (car ,local1) ,ind-temp) - (cond (,local2 - (rplacd (cdr ,local2) (cddr ,local1)) - (return t)) - (t (setq ,(car newval) (cddr ,(car newval))) - ,setter - (return t)))))))) - (push (list (car d) (car v)) let-list)))) - - -;;; The built-in DEFSETFs. - -(defsetf car %rplaca) -(defsetf cdr %rplacd) -(defsetf caar (x) (v) `(%rplaca (car ,x) ,v)) -(defsetf cadr (x) (v) `(%rplaca (cdr ,x) ,v)) -(defsetf cdar (x) (v) `(%rplacd (car ,x) ,v)) -(defsetf cddr (x) (v) `(%rplacd (cdr ,x) ,v)) -(defsetf caaar (x) (v) `(%rplaca (caar ,x) ,v)) -(defsetf cadar (x) (v) `(%rplaca (cdar ,x) ,v)) -(defsetf cdaar (x) (v) `(%rplacd (caar ,x) ,v)) -(defsetf cddar (x) (v) `(%rplacd (cdar ,x) ,v)) -(defsetf caadr (x) (v) `(%rplaca (cadr ,x) ,v)) -(defsetf caddr (x) (v) `(%rplaca (cddr ,x) ,v)) -(defsetf cdadr (x) (v) `(%rplacd (cadr ,x) ,v)) -(defsetf cdddr (x) (v) `(%rplacd (cddr ,x) ,v)) -(defsetf caaaar (x) (v) `(%rplaca (caaar ,x) ,v)) -(defsetf cadaar (x) (v) `(%rplaca (cdaar ,x) ,v)) -(defsetf cdaaar (x) (v) `(%rplacd (caaar ,x) ,v)) -(defsetf cddaar (x) (v) `(%rplacd (cdaar ,x) ,v)) -(defsetf caadar (x) (v) `(%rplaca (cadar ,x) ,v)) -(defsetf caddar (x) (v) `(%rplaca (cddar ,x) ,v)) -(defsetf cdadar (x) (v) `(%rplacd (cadar ,x) ,v)) -(defsetf cdddar (x) (v) `(%rplacd (cddar ,x) ,v)) -(defsetf caaadr (x) (v) `(%rplaca (caadr ,x) ,v)) -(defsetf cadadr (x) (v) `(%rplaca (cdadr ,x) ,v)) -(defsetf cdaadr (x) (v) `(%rplacd (caadr ,x) ,v)) -(defsetf cddadr (x) (v) `(%rplacd (cdadr ,x) ,v)) -(defsetf caaddr (x) (v) `(%rplaca (caddr ,x) ,v)) -(defsetf cadddr (x) (v) `(%rplaca (cdddr ,x) ,v)) -(defsetf cdaddr (x) (v) `(%rplacd (caddr ,x) ,v)) -(defsetf cddddr (x) (v) `(%rplacd (cdddr ,x) ,v)) - -(defsetf first %rplaca) -(defsetf second (x) (v) `(%rplaca (cdr ,x) ,v)) -(defsetf third (x) (v) `(%rplaca (cddr ,x) ,v)) -(defsetf fourth (x) (v) `(%rplaca (cdddr ,x) ,v)) -(defsetf fifth (x) (v) `(%rplaca (cddddr ,x) ,v)) -(defsetf sixth (x) (v) `(%rplaca (cdr (cddddr ,x)) ,v)) -(defsetf seventh (x) (v) `(%rplaca (cddr (cddddr ,x)) ,v)) -(defsetf eighth (x) (v) `(%rplaca (cdddr (cddddr ,x)) ,v)) -(defsetf ninth (x) (v) `(%rplaca (cddddr (cddddr ,x)) ,v)) -(defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v)) -(defsetf rest %rplacd) - -(defsetf elt %setelt) -(defsetf aref %aset) -(defsetf svref %svset) -(defsetf char %charset) -(defsetf bit %bitset) -(defsetf schar %scharset) -(defsetf sbit %sbitset) -(defsetf symbol-value set) -(defsetf symbol-function %sp-set-definition) -(defsetf symbol-plist %sp-set-plist) -(defsetf documentation %set-documentation) -(defsetf nth %setnth) -(defsetf fill-pointer %set-fill-pointer) -(defsetf search-list %set-search-list) - - -(define-setf-method getf (place prop &optional default &environment env) - (multiple-value-bind (temps values stores set get) - (foo-get-setf-method place env) - (let ((newval (gensym)) - (ptemp (gensym)) - (def-temp (gensym))) - (values `(,@temps ,(car stores) ,ptemp ,@(if default `(,def-temp))) - `(,@values ,get ,prop ,@(if default `(,default))) - `(,newval) - `(progn (setq ,(car stores) - (%putf ,(car stores) ,ptemp ,newval)) - ,set - ,newval) - `(getf ,(car stores) ,ptemp ,@(if default `(,def-temp))))))) - -(define-setf-method get (symbol prop &optional default) - "Get turns into %put. Don't put in the default unless it really is supplied and - non-nil, so that we can transform into the get instruction whenever possible." - (let ((symbol-temp (gensym)) - (prop-temp (gensym)) - (def-temp (gensym)) - (newval (gensym))) - (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp))) - `(,symbol ,prop ,@(if default `(,default))) - (list newval) - `(%put ,symbol-temp ,prop-temp ,newval) - `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp)))))) - -(define-setf-method gethash (key hashtable &optional default) - (let ((key-temp (gensym)) - (hashtable-temp (gensym)) - (default-temp (gensym)) - (new-value-temp (gensym))) - (values - `(,key-temp ,hashtable-temp ,@(if default `(,default-temp))) - `(,key ,hashtable ,@(if default `(,default))) - `(,new-value-temp) - `(%puthash ,key-temp ,hashtable-temp ,new-value-temp) - `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp)))))) - -(defsetf subseq (sequence start &optional (end nil)) (v) - `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) - ,v)) - - -;;; Evil hack invented by the gnomes of Vassar Street. The function -;;; arg must be constant. Get a setf method for this function, pretending -;;; that the final (list) arg to apply is just a normal arg. If the -;;; setting and access forms produced in this way reference this arg at -;;; the end, then just splice the APPLY back onto the front and the right -;;; thing happens. - -(define-setf-method apply (function &rest args &environment env) - (if (and (listp function) - (= (list-length function) 2) - (eq (first function) 'function) - (symbolp (second function))) - (setq function (second function)) - (error - "Setf of Apply is only defined for function args of form #'symbol.")) - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method (cons function args) env) - ;; Special case aref and svref. - (cond ((or (eq function 'aref) (eq function 'svref)) - (let ((nargs (subseq setter 0 (1- (length setter)))) - (fcn (if (eq function 'aref) 'lisp::%apply-aset 'lisp::%apply-svset))) - (values dummies vals newval - `(apply (function ,fcn) ,(car newval) ,@(cdr nargs)) - `(apply (function ,function) ,@(cdr getter))))) - ;; Make sure the place is one that we can handle. - (T (unless (and (eq (car (last args)) (car (last vals))) - (eq (car (last getter)) (car (last dummies))) - (eq (car (last setter)) (car (last dummies)))) - (error "Apply of ~S not understood as a location for Setf." - function)) - (values dummies vals newval - `(apply (function ,(car setter)) ,@(cdr setter)) - `(apply (function ,(car getter)) ,@(cdr getter))))))) - - -(define-setf-method ldb (bytespec place &environment env) - "The first argument is a byte specifier. The second is any place form - acceptable to SETF. Replaces the specified byte of the number in this - place with bits from the low-order end of the new value." - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method place env) - (let ((btemp (gensym)) - (gnuval (gensym))) - (values (cons btemp dummies) - (cons bytespec vals) - (list gnuval) - `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) - ,setter - ,gnuval) - `(ldb ,btemp ,getter))))) - - -(define-setf-method mask-field (bytespec place &environment env) - "The first argument is a byte specifier. The second is any place form - acceptable to SETF. Replaces the specified byte of the number in this place - with bits from the corresponding position in the new value." - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method place env) - (let ((btemp (gensym)) - (gnuval (gensym))) - (values (cons btemp dummies) - (cons bytespec vals) - (list gnuval) - `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) - ,setter - ,gnuval) - `(mask-field ,btemp ,getter))))) - - -(define-setf-method char-bit (place bit-name &environment env) - "The first argument is any place form acceptable to SETF. Replaces the - specified bit of the character in this place with the new value." - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method place env) - (let ((btemp (gensym)) - (gnuval (gensym))) - (values `(,@dummies ,btemp) - `(,@vals ,bit-name) - (list gnuval) - `(let ((,(car newval) - (set-char-bit ,getter ,btemp ,gnuval))) - ,setter - ,gnuval) - `(char-bit ,getter ,btemp))))) - - -(define-setf-method the (type place &environment env) - (multiple-value-bind (dummies vals newval setter getter) - (foo-get-setf-method place env) - (values dummies - vals - newval - (subst `(the ,type ,(car newval)) (car newval) setter) - `(the ,type ,getter)))) - - - -;;;; CASE, TYPECASE, & Friends. - -(eval-when (compile load eval) - -;;; CASE-BODY returns code for all the standard "case" macros. Name is the -;;; macro name, and keyform is the thing to case on. Multi-p indicates whether -;;; a branch may fire off a list of keys; otherwise, a key that is a list is -;;; interpreted in some way as a single key. When multi-p, test is applied to -;;; the value of keyform and each key for a given branch; otherwise, test is -;;; applied to the value of keyform and the entire first element, instead of -;;; each part, of the case branch. When errorp, no t or otherwise branch is -;;; permitted, and an ERROR form is generated. When proceedp, it is an error -;;; to omit errorp, and the ERROR form generated is executed within a -;;; RESTART-CASE allowing keyform to be set and retested. -;;; -(defun case-body (name keyform cases multi-p test errorp proceedp) - (let ((keyform-value (gensym)) - (clauses ()) - (keys ())) - (dolist (case cases) - (cond ((atom case) - (error "~S -- Bad clause in ~S." case name)) - ((memq (car case) '(t otherwise)) - (if errorp - (error "No default clause allowed in ~S: ~S" name case) - (push `(t nil ,@(rest case)) clauses))) - ((and multi-p (listp (first case))) - (setf keys (append (first case) keys)) - (push `((or ,@(mapcar #'(lambda (key) - `(,test ,keyform-value ',key)) - (first case))) - nil ,@(rest case)) - clauses)) - (t - (push (first case) keys) - (push `((,test ,keyform-value - ',(first case)) nil ,@(rest case)) clauses)))) - (case-body-aux name keyform keyform-value clauses keys errorp proceedp - `(,(if multi-p 'member 'or) ,@keys)))) - -;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the -;;; cases. Note: it is not necessary that the resulting code signal -;;; case-failure conditions, but that's what KMP's prototype code did. We call -;;; CASE-BODY-ERROR, because of how closures are compiled. RESTART-CASE has -;;; forms with closures that the compiler causes to be generated at the top of -;;; any function using the case macros, regardless of whether they are needed. -;;; -(defun case-body-aux (name keyform keyform-value clauses keys - errorp proceedp expected-type) - (if proceedp - (let ((block (gensym)) - (again (gensym))) - `(let ((,keyform-value ,keyform)) - (block ,block - (tagbody - ,again - (return-from - ,block - (cond ,@(nreverse clauses) - (t - (setf ,keyform-value - (setf ,keyform - (case-body-error - ',name ',keyform ,keyform-value - ',expected-type ',keys))) - (go ,again)))))))) - `(let ((,keyform-value ,keyform)) - (cond - ,@(nreverse clauses) - ,@(if errorp - `((t (error 'conditions::case-failure - :name ',name - :datum ,keyform-value - :expected-type ',expected-type - :possibilities ',keys)))))))) - -); eval-when - -(defun case-body-error (name keyform keyform-value expected-type keys) - (restart-case - (error 'conditions::case-failure - :name name - :datum keyform-value - :expected-type expected-type - :possibilities keys) - (store-value (value) - :report (lambda (stream) - (format stream "Supply a new value for ~S." keyform)) - :interactive read-evaluated-form - value))) - - - -(defmacro case (keyform &body cases) - "CASE Keyform {({(Key*) | Key} Form*)}* - Evaluates the Forms in the first clause with a Key EQL to the value of - Keyform. If a singleton key is T then the clause is a default clause." - (case-body 'case keyform cases t 'eql nil nil)) - -(defmacro ccase (keyform &body cases) - "CCASE Keyform {({(Key*) | Key} Form*)}* - Evaluates the Forms in the first clause with a Key EQL to the value of - Keyform. If none of the keys matches then a correctable error is - signalled." - (case-body 'ccase keyform cases t 'eql t t)) - -(defmacro ecase (keyform &body cases) - "ECASE Keyform {({(Key*) | Key} Form*)}* - Evaluates the Forms in the first clause with a Key EQL to the value of - Keyform. If none of the keys matches then an error is signalled." - (case-body 'ecase keyform cases t 'eql t nil)) - -(defmacro typecase (keyform &body cases) - "TYPECASE Keyform {(Type Form*)}* - Evaluates the Forms in the first clause for which TYPEP of Keyform and Type - is true." - (case-body 'typecase keyform cases nil 'typep nil nil)) - -(defmacro ctypecase (keyform &body cases) - "CTYPECASE Keyform {(Type Form*)}* - Evaluates the Forms in the first clause for which TYPEP of Keyform and Type - is true. If no form is satisfied then a correctable error is signalled." - (case-body 'ctypecase keyform cases nil 'typep t t)) - -(defmacro etypecase (keyform &body cases) - "ETYPECASE Keyform {(Type Form*)}* - Evaluates the Forms in the first clause for which TYPEP of Keyform and Type - is true. If no form is satisfied then an error is signalled." - (case-body 'etypecase keyform cases nil 'typep t nil)) - - -;;;; ASSERT and CHECK-TYPE. - -;;; ASSERT is written this way, to call ASSERT-ERROR, because of how closures -;;; are compiled. RESTART-CASE has forms with closures that the compiler -;;; causes to be generated at the top of any function using ASSERT, regardless -;;; of whether they are needed. -;;; -(defmacro assert (test-form &optional places datum &rest arguments) - "Signals an error if the value of test-form is nil. Continuing from this - error using the CONTINUE restart will allow the user to alter the value of - some locations known to SETF, starting over with test-form. Returns nil." - `(loop - (when ,test-form (return nil)) - (assert-error ',test-form ',places ,datum ,@arguments) - ,@(mapcar #'(lambda (place) - `(setf ,place (assert-prompt ',place ,place))) - places))) - -(defun assert-error (test-form places datum &rest arguments) - (restart-case (if datum - (apply #'error datum arguments) - (simple-assertion-failure test-form)) - (continue () - :report (lambda (stream) (assert-report places stream)) - nil))) - -(defun simple-assertion-failure (assertion) - (error 'simple-type-error - :datum assertion - :expected-type nil ;this needs some work in next revision. -kmp - :format-string "The assertion ~S failed." - :format-arguments (list assertion))) - -(defun assert-report (names stream) - (format stream "Retry assertion") - (if names - (format stream " with new value~P for ~{~S~^, ~}." - (length names) names) - (format stream "."))) - -(defun assert-prompt (name value) - (cond ((y-or-n-p "The old value of ~S is ~S.~ - ~%Do you want to supply a new value? " - name value) - (format *query-io* "~&Type a form to be evaluated:~%") - (flet ((read-it () (eval (read *query-io*)))) - (if (symbolp name) ;help user debug lexical variables - (progv (list name) (list value) (read-it)) - (read-it)))) - (t value))) - - -;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because of how -;;; closures are compiled. RESTART-CASE has forms with closures that the -;;; compiler causes to be generated at the top of any function using -;;; CHECK-TYPE, regardless of whether they are needed. Because it would be -;;; nice if this were cheap to use, and some things can't afford this excessive -;;; consing (e.g., READ-CHAR), we bend backwards a little. -;;; - -(defmacro check-type (place type &optional type-string) - "Signals an error of type type-error if the contents of place are not of the - specified type. If an error is signaled, this can only return if - STORE-VALUE is invoked. It will store into place and start over." - (let ((place-value (gensym))) - `(loop - (let ((,place-value ,place)) - (when (typep ,place-value ',type) (return nil)) - (setf ,place - (check-type-error ',place ,place-value ',type ,type-string)))))) - -(defun check-type-error (place place-value type type-string) - (restart-case (if type-string - (error 'simple-type-error - :datum place :expected-type type - :format-string - "The value of ~S is ~S, which is not ~A." - :format-arguments - (list place place-value type-string)) - (error 'simple-type-error - :datum place :expected-type type - :format-string - "The value of ~S is ~S, which is not of type ~S." - :format-arguments - (list place place-value type))) - (store-value (value) - :report (lambda (stream) - (format stream "Supply a new value of ~S." - place)) - :interactive read-evaluated-form - value))) - -;;; READ-EVALUATED-FORM is used as the interactive method for restart cases -;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros -;;; and by CHECK-TYPE. -;;; -(defun read-evaluated-form () - (format *query-io* "~&Type a form to be evaluated:~%") - (list (eval (read *query-io*)))) - - -;;;; With-XXX - -(defmacro with-open-file ((var &rest open-args) &body (forms decls)) - "Bindspec is of the form (Stream File-Name . Options). The file whose - name is File-Name is opened using the Options and bound to the variable - Stream. If the call to open is unsuccessful, the forms are not - evaluated. The Forms are executed, and when they terminate, normally or - otherwise, the file is closed." - (let ((abortp (gensym))) - `(let ((,var (open ,@open-args)) - (,abortp t)) - ,@decls - (when ,var - (unwind-protect - (multiple-value-prog1 - (progn ,@forms) - (setq ,abortp nil)) - (close ,var :abort ,abortp)))))) - - - -(defmacro with-open-stream ((var stream) &body (forms decls)) - "The form stream should evaluate to a stream. VAR is bound - to the stream and the forms are evaluated as an implicit - progn. The stream is closed upon exit." - (let ((abortp (gensym))) - `(let ((,var ,stream) - (,abortp t)) - ,@decls - (unwind-protect - (multiple-value-prog1 - (progn ,@forms) - (setq ,abortp nil)) - (when ,var - (close ,var :abort ,abortp)))))) - - -(defmacro with-input-from-string ((var string &key index start end) &body (forms decls)) - "Binds the Var to an input stream that returns characters from String and - executes the body. See manual for details." - `(let ((,var - ,(if end - `(make-string-input-stream ,string ,(or start 0) ,end) - `(make-string-input-stream ,string ,(or start 0))))) - ,@decls - (unwind-protect - (progn ,@forms) - (close ,var) - ,@(if index `((setf ,index (string-input-stream-current ,var))))))) - - -(defmacro with-output-to-string ((var &optional string) &body (forms decls)) - "If *string* is specified, it must be a string with a fill pointer; - the output is incrementally appended to the string (as if by use of - VECTOR-PUSH-EXTEND)." - (if string - `(let ((,var (make-fill-pointer-output-stream ,string))) - ,@decls - (unwind-protect - (progn ,@forms) - (close ,var))) - `(let ((,var (make-string-output-stream))) - ,@decls - (unwind-protect - (progn ,@forms) - (close ,var)) - (get-output-stream-string ,var)))) - - -;;;; Iteration macros: - -(defmacro loop (&rest body) - "Executes the body repeatedly until the form is exited by a Throw or - Return. The body is surrounded by an implicit block with name NIL." - (let ((tag (gensym))) - `(block nil (tagbody ,tag ,@body (go ,tag))))) - - -(defmacro dotimes ((var count &optional (result nil)) &body body) - (cond ((numberp count) - `(do ((,var 0 (1+ ,var))) - ((>= ,var ,count) ,result) - (declare (type unsigned-byte ,var)) - ,@body)) - (t (let ((v1 (gensym))) - `(do ((,var 0 (1+ ,var)) (,v1 ,count)) - ((>= ,var ,v1) ,result) - (declare (type unsigned-byte ,var)) - ,@body))))) - - -;;; We repeatedly bind the var instead of setting it so that we never give the -;;; var a random value such as NIL (which might conflict with a declaration). -;;; ### Might not be legal... -;;; -(defmacro dolist ((var list &optional (result nil)) &body body) - (let ((n-list (gensym))) - `(do ((,n-list ,list (cdr ,n-list))) - ((endp ,n-list) - (let ((,var nil)) - (declare (ignorable ,var)) - ,result)) - (let ((,var (car ,n-list))) - ,@body)))) - - -(defmacro do (varlist endlist &body (body decls)) - "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* - Iteration construct. Each Var is initialized in parallel to the value of the - specified Init form. On subsequent iterations, the Vars are assigned the - value of the Step form (if any) in paralell. The Test is evaluated before - each evaluation of the body Forms. When the Test is true, the the Exit-Forms - are evaluated as a PROGN, with the result being the value of the DO. A block - named NIL is established around the entire expansion, allowing RETURN to be - used as an laternate exit mechanism." - - (do-do-body varlist endlist body decls 'let 'psetq 'do nil)) - - -(defmacro do* (varlist endlist &body (body decls)) - "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* - Iteration construct. Each Var is initialized sequentially (like LET*) to the - value of the specified Init form. On subsequent iterations, the Vars are - sequentially assigned the value of the Step form (if any). The Test is - evaluated before each evaluation of the body Forms. When the Test is true, - the the Exit-Forms are evaluated as a PROGN, with the result being the value - of the DO. A block named NIL is established around the entire expansion, - allowing RETURN to be used as an laternate exit mechanism." - (do-do-body varlist endlist body decls 'let* 'setq 'do* nil)) - - -;;;; Miscellaneous macros: - -(defmacro locally (&rest forms) - "A form providing a container for locally-scoped variables." - `(let () ,@forms)) - -(defmacro psetq (&rest pairs) - (do ((lets nil) - (setqs nil) - (pairs pairs (cddr pairs))) - ((atom (cdr pairs)) - `(let ,(nreverse lets) (setq ,@(nreverse setqs)))) - (let ((gen (gensym))) - (push `(,gen ,(cadr pairs)) lets) - (push (car pairs) setqs) - (push gen setqs)))) - -;;; ### Bootstrap hack... -;;; Restore defmacro processing to normal. -;;; -(eval-when (compile) - (setq *bootstrap-defmacro* nil)) - - -;;;; With-Compilation-Unit: - -;;; True if we are within a With-Compilation-Unit form, which normally causes -;;; nested uses to be NOOPS. -;;; -(defvar *in-compilation-unit* nil) - -;;; Count of the number of compilation units dynamically enclosed by the -;;; current active WITH-COMPILATION-UNIT that were unwound out of. -;;; -(defvar *aborted-compilation-units*) - -(compiler-let ((*bootstrap-defmacro* :both)) - -;;; With-Compilation-Unit -- Public -;;; -;;; -(defmacro with-compilation-unit (options &body body) - (let ((force nil) - (n-fun (gensym)) - (n-abort-p (gensym))) - (when (oddp (length options)) - (error "Odd number of key/value pairs: ~S." options)) - (do ((opt options (cddr opt))) - ((null opt)) - (case (first opt) - (:force - (setq force (second opt))) - (t - (warn "Ignoring unknown option: ~S." (first opt))))) - - `(flet ((,n-fun () ,@body)) - (if (or ,force (not *in-compilation-unit*)) - (let ((c::*undefined-warnings* nil) - (c::*compiler-error-count* 0) - (c::*compiler-warning-count* 0) - (c::*compiler-note-count* 0) - (*in-compilation-unit* t) - (*aborted-compilation-units* 0) - (,n-abort-p t)) - (handler-bind ((c::parse-unknown-type - #'(lambda (c) - (c::note-undefined-reference - (c::parse-unknown-type-specifier c) - :type)))) - (unwind-protect - (multiple-value-prog1 - (,n-fun) - (setq ,n-abort-p nil)) - (c::print-summary ,n-abort-p *aborted-compilation-units*)))) - (let ((,n-abort-p t)) - (unwind-protect - (multiple-value-prog1 - (,n-fun) - (setq ,n-abort-p nil)) - (when ,n-abort-p - (incf *aborted-compilation-units*)))))))) -); Compiler-Let diff --git a/code/mipsstrops.lisp b/code/mipsstrops.lisp deleted file mode 100644 index 5a57ee9b871f28a4e9a0b3d489e7ca0a8686f11d..0000000000000000000000000000000000000000 --- a/code/mipsstrops.lisp +++ /dev/null @@ -1,186 +0,0 @@ -;;; -*- Log: Code.Log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; 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))))))) - -(defun %sp-find-character-with-attribute (string start end table mask) - (declare (type (simple-array (unsigned-byte 8) (256)) table) - (simple-string 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." - (do ((index start (1+ index))) - ((>= index end) nil) - (declare (fixnum index)) - (unless (zerop (logand (aref table (char-code (schar string 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 (simple-string string) - (fixnum start end mask) - (type (array (unsigned-byte 8) (256)) table)) - (do ((index (1- end) (1- index))) - ((< index start) nil) - (declare (fixnum index)) - (unless (zerop (logand (aref table (char-code (schar string 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) - (simple-string string) - (base-character character)) - (do ((index start (1+ index))) - ((>= index end) nil) - (declare (fixnum index)) - (when (char= (schar string index) character) - (return index)))) - -(defun %sp-reverse-find-character (string start end character) - (declare (simple-string string)) - (declare (fixnum start end)) - "%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." - (do ((index (1- end) (1- index)) - (terminus (1- start))) - ((= index terminus) nil) - (declare (fixnum terminus index)) - (if (char= (char string index) character) - (return index)))) - -(defun %sp-skip-character (string start end character) - (declare (simple-string string)) - (declare (fixnum start end)) - "%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." - (do ((index start (1+ index))) - ((= index end) nil) - (declare (fixnum index)) - (if (char/= (char string index) character) - (return index)))) - -(defun %sp-reverse-skip-character (string start end character) - (declare (simple-string string)) - (declare (fixnum start end)) - "%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." - (do ((index (1- end) (1- index)) - (terminus (1- start))) - ((= index terminus) nil) - (declare (fixnum terminus index)) - (if (char/= (char string 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." - (do ((index2 start2 (1+ index2))) - ((= index2 end2) nil) - (if (do ((index1 start1 (1+ index1)) - (index2 index2 (1+ index2))) - ((= index1 end1) t) - (if (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 f6b13dffd571703acf2b129c7f1ce3d74c11439c..0000000000000000000000000000000000000000 --- a/code/misc.lisp +++ /dev/null @@ -1,136 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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). -;;; ********************************************************************** -;;; -;;; Assorted miscellaneous functions for Spice Lisp. -;;; -;;; 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)) - - -(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." - (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 :mach :ibm-rt-pc :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." - (cond ((atom x) (memq x *features*)) - ((eq (car x) ':not) (not (featurep (cadr x)))) - ((eq (car x) ':and) - (every #'featurep (cdr x))) - ((eq (car x) ':or) - (some #'featurep (cdr x))) - (t nil))) - - - -;;; 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-type () - "Returns a string describing the type of the local machine." - "IBM RT PC") - -(defun machine-version () - "Returns a string describing the version of the local machine." - (let ((version (system:%primitive 16bit-system-ref - (int-sap - (+ (ash clc::romp-data-base 16) - clc::floating-point-hardware-available)) - 1))) - (if (or (not (= (logand version clc::float-mc68881) 0)) - (not (= (logand version clc::float-afpa) 0))) - "IBM RT PC/APC" - "IBM RT PC"))) - -(defun machine-instance () - "Returns a string giving the name of the local machine." - (mach::unix-gethostname)) - -(defun software-type () - "Returns a string describing the supporting software." - "MACH/4.3BSD") - -(defun software-version () - "Returns a string describing version of the supporting software." - NIL) - -(defun short-site-name () - "Returns a string with the abbreviated site name." - "CMU-CSD") - -(defun long-site-name () - "Returns a string with the long form of the site name." - "Carnegie-Mellon University Computer Science Department") - - - -;;;; Dribble stuff: - -(defun dribble (&optional pathname &key (if-exists :append)) - "With a file name as an argument, dribble opens the file and - sends a record of the output to that file. Without an - argument, it closes the open dribble file." - (if pathname - (with-open-file (f pathname :direction :output :if-exists if-exists - :if-does-not-exist :create) - (catch 'dribble-punt - (let ((*terminal-io* - (make-two-way-stream - (make-echo-stream *terminal-io* f) - (make-broadcast-stream *terminal-io* f)))) - (%top-level)))) - (throw 'dribble-punt nil))) diff --git a/code/package.lisp b/code/package.lisp deleted file mode 100644 index f0fe36a0792f9348efa9f7e2e8272633266bc662..0000000000000000000000000000000000000000 --- a/code/package.lisp +++ /dev/null @@ -1,1101 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Package stuff and stuff like that. -;;; -;;; Re-Written by Rob MacLachlan. Earlier version written by -;;; Lee Schumacher. Apropos & iteration macros courtesy of Skef Wholey. -;;; -(in-package 'lisp) -(export '(package packagep *package* make-package in-package find-package - package-name package-nicknames rename-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 - do-external-symbols do-all-symbols apropos apropos-list)) - - -(in-package "EXTENSIONS") -(export '(*keyword-package* *lisp-package*)) -(in-package 'lisp) - - -(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)))))) - "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. - -(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 (%primitive 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 (rem (+ ,index-var ,h2) ,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 (%primitive 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. - -;;; Instead of using slow, silly successor functions, we make the iteration -;;; guys be big PROG's. Yea! - -(eval-when (compile load eval) - -(defun make-do-symbols-vars () - `(,(gensym) ; index - ,(gensym) ; hash - ,(gensym) ; hash-vector - ,(gensym))) ; terminus - -(defun make-do-symbols-code (vars var hash-table exit-form forms) - (let ((index (first vars)) - (hash-vector (second vars)) - (hash (third vars)) - (terminus (fourth vars)) - (TOP (gensym))) - `((setq ,index 0) - (setq ,hash-vector (package-hashtable-table ,hash-table)) - (setq ,hash (package-hashtable-hash ,hash-table)) - (setq ,terminus (length (the simple-vector ,hash-vector))) - ,TOP - (if (= (the fixnum ,index) (the fixnum ,terminus)) - ,exit-form) - (when (> (the fixnum (aref (the (simple-array (unsigned-byte 8)) ,hash) - ,index)) - 1) - (setq ,var (svref ,hash-vector ,index)) - ,@forms) - (incf ,index) - (go ,TOP)))) - -); eval-when (compile load eval) - -(defmacro do-symbols ((var &optional (package '*package*) result-form) - &body (code decls)) - "Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* - Executes the Forms at least once for each symbol accessible in the given - Package with Var bound to the current symbol." - (let* ((DONE-INTERNAL (gensym)) - (DONE-EXTERNAL (gensym)) - (NEXT-INHERIT (gensym)) - (vars (make-do-symbols-vars)) - (n-package (gensym)) - (shadowed (gensym)) - (inherits (gensym)) - (this-inherit (gensym))) - `(prog* ((,n-package (package-or-lose ,package)) - (,shadowed (package-shadowing-symbols ,n-package)) - (,inherits (package-use-list ,n-package)) - ,var ,@vars ,this-inherit) - ,@decls - ,@(make-do-symbols-code - vars var `(package-internal-symbols ,n-package) - `(go ,DONE-INTERNAL) - code) - ,DONE-INTERNAL - - ,@(make-do-symbols-code - vars var `(package-external-symbols ,n-package) - `(go ,DONE-EXTERNAL) - code) - ,DONE-EXTERNAL - - ,NEXT-INHERIT - (when (null ,inherits) - (setq ,var nil) - (return ,result-form)) - - (setq ,this-inherit (package-external-symbols (car ,inherits))) - ,@(make-do-symbols-code - vars var this-inherit - `(progn - (setq ,inherits (cdr ,inherits)) - (go ,NEXT-INHERIT)) - `((when (or (not ,shadowed) - (eq (find-symbol (symbol-name ,var) ,n-package) ,var)) - ,@code)))))) - -(defmacro do-external-symbols ((var &optional (package '*package*) result-form) - &body (code decls)) - "Do-External-Symbols (Var [Package [Result-Form]]) - {Declaration}* {Tag | Statement}* - Executes the Forms once for each external symbol in the given Package with - Var bound to the current symbol." - (let ((vars (make-do-symbols-vars)) - (n-package (gensym))) - `(prog ((,n-package (package-or-lose ,package)) - ,var ,@vars) - ,@decls - ,@(make-do-symbols-code - vars var `(package-external-symbols ,n-package) - `(return (progn (setq ,var nil) ,result-form)) - code)))) - -(defmacro do-all-symbols ((var &optional result-form) - &body (code decls)) - "Do-All-Symbols (Var [Result-Form]) {Declaration}* {Tag | Statement}* - Executes the Forms once for each symbol in each package with Var bound - to the current symbol." - (let* ((PACKAGE-LOOP (gensym)) - (TAG (gensym)) - (package-list (gensym)) - (vars (make-do-symbols-vars)) - (internal-code (make-do-symbols-code - vars var `(package-internal-symbols (car ,package-list)) - `(go ,TAG) - code)) - (external-code (make-do-symbols-code - vars var `(package-external-symbols (car ,package-list)) - `(progn (setq ,package-list (cdr ,package-list)) - (go ,PACKAGE-LOOP)) - code))) - `(prog (,package-list ,var ,@vars) - ,@decls - (setq ,package-list (list-all-packages)) - ,PACKAGE-LOOP - (when (null ,package-list) - (setq ,var nil) - (return ,result-form)) - ,@internal-code - ,TAG - ,@external-code))) - -;;; 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 '("LISP")) 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))) - -;;; In-Package -- Public -;;; -;;; Like Make-Package, only different. -;;; -(defun 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)))))) - -;;; 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." - (check-type package 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*) - (setf (package-name package) name) - (setf (gethash name *package-names*) package) - (dolist (n (package-nicknames package)) - (remhash n *package-names*)) - (setf (package-nicknames package) ()) - (enter-new-nicknames package nicknames) - package)) - -;;; 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)))) - (%primitive c::set-package symbol package) - (cond ((eq package *keyword-package*) - (add-symbol (package-external-symbols package) symbol) - (set 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 (%primitive 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 (%primitive 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) - (delete 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) - (%primitive c::set-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) (%primitive c::set-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) - (delete 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 (sym (symbol-listify symbols)) - (let ((name (symbol-name sym))) - (multiple-value-bind (s w) (find-symbol name package) - (when (or (not w) (eq w :inherited)) - (setq s (make-symbol name)) - (%primitive c::set-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) - (delete 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) - (delete 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) - (%primitive c::set-package symbol pkg)) - ;; - ;; External symbols same, only go in external table. - (dolist (symbol (third spec)) - (add-symbol external symbol) - (%primitive c::set-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: - (in-package "SYSTEM") - (in-package "USER") - (in-package "DEBUG") - - ;; 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 50db34cc69fa6846915a35b18423b7104a4be9fc..0000000000000000000000000000000000000000 --- a/code/parse-time.lisp +++ /dev/null @@ -1,574 +0,0 @@ -;;; -*- Mode: Lisp; Package: Extensions; Log: code.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). -;;; ********************************************************************** - -;;; 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 20) -(defparameter month-table-size 30) -(defparameter zone-table-size 10) -(defparameter special-table-size 10) - -(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" . 5) ("cst" . 6) - ("cdt" . 6) ("mst" . 7) - ("mdt" . 7) ("pst" . 8) - ("pdt" . 8)) - *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. - -(defun convert-to-unitime (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) - (decoded-time-zone parsed-values))) - -;;; 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 (string) - (and (simple-string-p string) (gethash string *zone-strings*))) - -(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) - (parts-list nil)) - ((eq string-index end) (nreverse parts-list)) - (let ((next-char (char string 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))) - (push numeric-value parts-list) - (setf string-index scan-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 (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)) - (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/pmax-disassem.lisp b/code/pmax-disassem.lisp deleted file mode 100644 index ca3ab2184360892efd2ed8534794d513ffe248ac..0000000000000000000000000000000000000000 --- a/code/pmax-disassem.lisp +++ /dev/null @@ -1,473 +0,0 @@ -;;; -*- Mode: Lisp; Package: MIPS -*- -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-disassem.lisp,v 1.11 1990/02/24 17:07:35 wlott 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 - -(defparameter register-name-style :lisp - "The register name style: :c, :lisp, :raw") - -(defvar *c-register-names* - '#("ZERO" "$AT" "$V0" "$V1" "$A0" "$A1" "$A2" "$A3" - "$T0" "$T1" "$T2" "$T3" "$T4" "$T5" "$T6" "$T7" - "$S0" "$S1" "$S2" "$S3" "$S4" "$S5" "$S6" "$S7" - "$T8" "$T9" "$K0" "$K1" "$GP" "$SP" "$S8" "$RA")) - -(defvar *lisp-register-names* - '#("$ZERO" "$LIP" "$NL0" "$NL1" "$NL2" "$NL3" "$NL4" "$NARGS" - "$A0" "$A1" "$A2" "$A3" "$A4" "$A5" "$CNAME" "$LEXENV" - "$ARGS" "$OLDCONT" "$LRA" "$L0" "$NULL" "$BSP" "$CONT" "$CSP" - "$FLAGS" "$ALLOC" "$K0" "$K1" "$L1" "$NSP" "$CODE" "$L2")) - -(defvar *raw-register-names* - '#("$R0" "$R1" "$R2" "$R3" "$R4" "$R5" "$R6" "$R7" - "$R8" "$R9" "$R10" "$R12" "$R13" "$R14" "$R15" - "$R16" "$R17" "$R18" "$R19" "$R20" "$R21" "$R22" "$R23" - "$R24" "$R25" "$R26" "$R27" "$R28" "$R29" "$R30" "$R31")) - -(defun register-name (register-number) - (unless (<= 0 register-number 31) - (error "Illegal register number!")) - (let ((register-names (ecase register-name-style - (:c *c-register-names*) - (:lisp *lisp-register-names*) - (:raw *raw-register-names*)))) - (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 c::null-offset) (string= name "ADDI") - (eq register-name-style :lisp)) - ;; 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))) -(proclaim '(type *mips-instructions* 'simple-vector)) - -(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))) -(proclaim '(type *mips-special-instructions* 'simple-vector)) - -(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))) -(proclaim '(type *mips-bcond-instructions* 'simple-vector)) - -(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)))))) diff --git a/code/pprint.lisp b/code/pprint.lisp deleted file mode 100644 index 5eddd974bba763aab8daef4eb7a931b220eeed06..0000000000000000000000000000000000000000 --- a/code/pprint.lisp +++ /dev/null @@ -1,90 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; CMU Common Lisp pretty printer. -;;; Written by Skef Wholey. -;;; Modified by Todd Kaufmann, Bill Chiles, Rob Maclachlan, William Lott. -;;; - -(in-package "LISP") -(export '(pprint)) - - -(in-package "EXTENSIONS") -(export '(grindef)) -(in-package "LISP") -#| -(defun pprin1 (object &optional stream) - "Prettily outputs the Object to the Stream slashifying special characters." - (xp::prin1 object stream) - (values)) - -(defun pprinc (object &optional stream) - "Prettily outputs the Object to the Stream without slashifying." - (xp::princ object stream) - (values)) -|# - -(defun pprint (object &optional stream) - "Prettily outputs the Object preceded by a newline and followed by a space." - (xp::pprint object stream) - (values)) - -;;; OUTPUT-PRETTY-OBJECT is called by WRITE, PRIN1, PRINC, and their associated -;;; ...-TO-STRING forms when *print-pretty* is non-nil. Calling this when -;;; *print-pretty* is nil could cause XP and our system to recursively call -;;; each other for a very long time. Stream has already been set correctly -;;; according the semantics in the manual with respect to t and nil. -;;; -(defun output-pretty-object (object stream) - (assert *print-pretty*) - (typecase object - ((or list structure vector array) - (xp::basic-write object stream)) - (t (let ((*print-pretty* nil)) - (output-object object stream))))) - -(defun pretty-lambda-to-defun (name lambda &optional arglist) - `(defun ,name ,(or arglist (cadr lambda)) - ,@(if (and (null (cdddr lambda)) (listp (caddr lambda)) - (eq (caaddr lambda) 'block)) - (cddr (caddr lambda)) - (cddr lambda)))) - -(defmacro grindef (function-name) - "Prettily prints the definition of the function whose name is Function-Name." - (if (and (symbolp function-name) (fboundp function-name)) - (let ((stuff (symbol-function function-name))) - (if (and (listp stuff) (listp (cdr stuff))) - (case (car stuff) - (lambda `(pprint ',(pretty-lambda-to-defun function-name stuff))) - (macro `(pprint ',(pretty-lambda-to-defun function-name (cdr stuff) - '(&rest **macroarg**)))) - (t `(pprint '(setf (symbol-function ,function-name) ',stuff)))) - `(pprint '(setf (symbol-function ,function-name) ',stuff)))) - nil)) - - -;;; Tab-Over prints the specified number of spaces on *Standard-Output*. -;;; Taken from the old pretty printer. Needed by some function in filesys. -(defconstant maximum-pp-indentation 70) -(defconstant pp-indentation-string (make-string 70 :initial-element #\space)) - -(defun tab-over (indent-pos) - (write-string pp-indentation-string *standard-output* - :start 0 - :end (min indent-pos maximum-pp-indentation))) - -;;; Initialize Water's pretty printer. -(defun pprint-init () - (xp::install :shadow nil) - (define-print-dispatch (cons (and symbol (satisfies fboundp))) - ((:priority 5) (:table *print-dispatch*)) - #'fill-style)) - diff --git a/code/pred.lisp b/code/pred.lisp deleted file mode 100644 index e761efc6a1adaf0372fb4dd3de7790d50d3d3d5e..0000000000000000000000000000000000000000 --- a/code/pred.lisp +++ /dev/null @@ -1,603 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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). -;;; ********************************************************************** -;;; -;;; Predicate functions for Spice Lisp. -;;; The type predicates are implementation-specific. A different version -;;; of this file will be required for implementations with different -;;; data representations. -;;; -;;; Written and currently maintained by Scott Fahlman. -;;; Based on an earlier version by Joe Ginder. -;;; -(in-package 'lisp) -(export '(typep 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 - functionp compiled-function-p commonp eq eql equal equalp not - type-of - ;; Names of types... - array atom bignum bit bit-vector character common - compiled-function complex cons double-float - fixnum float function integer keyword list long-float nil - null number ratio rational sequence short-float signed-byte - simple-array simple-bit-vector simple-string simple-vector - single-float standard-char string string-char symbol t - unsigned-byte vector structure satisfies)) - -(in-package "EXTENSIONS") -(export '(structurep fixnump bignump bitp ratiop)) -(in-package "LISP") - - -;;; Data type predicates. - -;;; Translation from type keywords to specific predicates. Assumes that -;;; the following are named structures and need no special type hackery: -;;; PATHNAME, STREAM, READTABLE, PACKAGE, HASHTABLE, RANDOM-STATE. - -(defparameter type-pred-alist - '((keyword . keywordp) - (common . commonp) - (null . null) - (cons . consp) - (list . listp) - (symbol . symbolp) - (array . arrayp) - (vector . vectorp) - (bit-vector . bit-vector-p) - (string . stringp) - (sequence . sequencep) - (simple-array . simple-array-p) - (c::structure-vector . simple-vector-p) - (simple-vector . simple-vector-p) - (simple-string . simple-string-p) - (simple-bit-vector . simple-bit-vector-p) - (function . functionp) - (compiled-function . compiled-function-p) - (character . characterp) - (number . numberp) - (rational . rationalp) - (float . floatp) - (string-char . %string-char-p) - (integer . integerp) - (ratio . ratiop) - (short-float . short-float-p) - (standard-char . %standard-char-p) - (fixnum . fixnump) - (complex . complexp) -; (single-float . single-float-p) - (single-float . short-float-p) - (bignum . bignump) - (double-float . double-float-p) - (bit . bitp) - (long-float . long-float-p) - (structure . structurep) - (atom . atom))) - - -;;;; TYPE-OF and auxiliary functions. - -(defun type-of (object) - "Returns the type of OBJECT as a type-specifier. - Since objects may be of more than one type, the choice is somewhat - arbitrary and may be implementation-dependent." - (if (null object) 'symbol - (case (%primitive get-type object) - (#.%+-fixnum-type 'fixnum) - (#.%bignum-type 'bignum) - (#.%ratio-type 'ratio) - ((#.%short-+-float-type #.%short---float-type) 'short-float) - (#.%long-float-type 'long-float) - (#.%complex-type 'complex) - (#.%string-type `(simple-string ,(%primitive vector-length object))) - (#.%bit-vector-type - `(simple-bit-vector ,(%primitive vector-length object))) - (#.%integer-vector-type (type-of-i-vector object)) - (#.%general-vector-type (type-of-g-vector object)) - (#.%array-type (type-of-array object)) - (#.%function-type 'function) - (#.%symbol-type 'symbol) - (#.%list-type 'cons) - (#.%string-char-type 'string-char) - (#.%bitsy-char-type 'character) - (#.%--fixnum-type 'fixnum) - (t 'random)))) - -;;; %String-Char-P is called by typep when the type specification -;;; is string-char. The CL string-char-p does not do the right thing. -(defun %string-char-p (x) - (and (characterp x) - (< (the fixnum (char-int x)) char-code-limit))) - -;;; Create the list-style description of a G-vector. - -(defun type-of-g-vector (object) - (cond ((structurep object) (svref object 0)) - (t `(simple-vector ,(%primitive vector-length object))))) - -;;; I-Vector-Element-Type -- Internal -;;; -;;; Return a type specifier for the element type of an I-Vector. -;;; -(defun i-vector-element-type (object) - (let ((ac (%primitive get-vector-access-code object))) - (if (< 0 ac 6) - (svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536) - (mod 4294967296)) - ac) - (error "Invalid I-Vector access code: ~S" ac)))) - -;;; Create the list-style description of an I-vector. - -(defun type-of-i-vector (object) - `(simple-array ,(i-vector-element-type object) - ,(%primitive vector-length object))) - - -;;; Create the list-style description of an array. - -(defun type-of-array (object) - (with-array-data ((data-vector object) (start) (end)) - (declare (ignore start end)) - (let ((rank (- (the fixnum (%primitive header-length object)) - %array-first-dim-slot)) - (length (%primitive header-ref object %array-length-slot))) - (declare (fixnum rank length)) - (if (= rank 1) - (typecase data-vector - (simple-bit-vector `(bit-vector ,length)) - (simple-string `(string ,length)) - (simple-vector `(vector t ,length)) - (t `(vector ,(i-vector-element-type data-vector) ,length))) - `(array - ,(typecase data-vector - (simple-bit-vector '(mod 2)) - (simple-string 'string-char) - (simple-vector 't) - (t (i-vector-element-type data-vector))) - ,(array-dimensions object)))))) - -;;;; TYPEP and auxiliary functions. - -(defun %typep (object type) - (let ((type (type-expand type)) - temp) - (cond ((symbolp type) - (cond ((or (eq type t) (eq type '*)) t) - ((eq type 'nil) nil) - ((setq temp (assq type type-pred-alist)) - (funcall (cdr temp) object)) - (t (structure-typep object type)))) - ((listp type) - ;; This handles list-style type specifiers. - (case (car type) - (vector (and (vectorp object) - (vector-eltype object (cadr type)) - (test-length object (caddr type)))) - (simple-vector (and (simple-vector-p object) - (test-length object (cadr type)))) - (string (and (stringp object) - (test-length object (cadr type)))) - (simple-string (and (simple-string-p object) - (test-length object (cadr type)))) - (bit-vector (and (bit-vector-p object) - (test-length object (cadr type)))) - (simple-bit-vector (and (simple-bit-vector-p object) - (test-length object (cadr type)))) - (array (array-typep object type)) - (simple-array (and (not (array-header-p object)) - (array-typep object type))) - (satisfies (funcall (cadr type) object)) - (member (member object (cdr type))) - (not (not (typep object (cadr type)))) - (or (dolist (x (cdr type) nil) - (if (typep object x) (return t)))) - (and (dolist (x (cdr type) t) - (if (not (typep object x)) (return nil)))) - (integer (and (integerp object) (test-limits object type))) - (rational (and (rationalp object) (test-limits object type))) - (float (and (floatp object) (test-limits object type))) - (short-float (and (short-float-p object) - (test-limits object type))) - (single-float (and (single-float-p object) - (test-limits object type))) - (double-float (and (double-float-p object) - (test-limits object type))) - (long-float (and (long-float-p object) - (test-limits object type))) - (mod (and (integerp object) - (>= object 0) - (< object (cadr type)))) - (signed-byte - (and (integerp object) - (let ((n (cadr type))) - (or (not n) (eq n '*) - (> n (integer-length object)))))) - (unsigned-byte - (and (integerp object) - (not (minusp object)) - (let ((n (cadr type))) - (or (not n) (eq n '*) - (>= n (integer-length object)))))) - (complex (and (numberp object) - (or (not (cdr type)) - (typep (realpart object) (cadr type))))) - (t (error "~S -- Illegal type specifier to TYPEP." type)))) - (t (error "~S -- Illegal type specifier to TYPEP." type))))) - -(defun typep (obj type) - "Returns T if OBJECT is of the specified TYPE, otherwise NIL." - (declare (notinline %typep)) - (%typep obj type)) - - -;;; Given that the object is a vector of some sort, and that we've already -;;; verified that it matches CAR of TYPE, see if the rest of the type -;;; specifier wins. Mild hack: Eltype Nil means either type not supplied -;;; or was Nil. Any vector can hold objects of type Nil, since there aren't -;;; any, so (vector nil) is the same as (vector *). -;;; -(defun vector-eltype (object eltype) - (let ((data (if (array-header-p object) - (with-array-data ((data object) (start) (end)) - (declare (ignore start end)) - data) - object)) - (eltype (type-expand eltype))) - (case eltype - ((t) (simple-vector-p data)) - (string-char (simple-string-p data)) - (bit (simple-bit-vector-p data)) - ((* nil) t) - (t - (subtypep eltype - (cond ((simple-vector-p data) t) - ((simple-string-p data) 'string-char) - ((simple-bit-vector-p data) 'bit) - (t - (i-vector-element-type data)))))))) - - -;;; Test sequence for specified length. - -(defun test-length (object length) - (or (null length) - (eq length '*) - (= length (length object)))) - - -;;; See if object satisfies the specifier for an array. - -(defun array-typep (object type) - (and (arrayp object) - (vector-eltype object (cadr type)) - (if (cddr type) - (let ((dims (third type))) - (cond ((eq dims '*) t) - ((numberp dims) - (and (vectorp object) - (= (the fixnum (length (the vector object))) - (the fixnum dims)))) - (t - (dotimes (i (array-rank object) (null dims)) - (when (null dims) (return nil)) - (let ((dim (pop dims))) - (unless (or (eq dim '*) - (= dim (array-dimension object i))) - (return nil))))))) - t))) - - -;;; Test whether a number falls within the specified limits. - -(defun test-limits (object type) - (let ((low (cadr type)) - (high (caddr type))) - (and (cond ((null low) t) - ((eq low '*) t) - ((numberp low) (>= object low)) - ((and (consp low) (numberp (car low))) - (> object (car low))) - (t nil)) - (cond ((null high) t) - ((eq high '*) t) - ((numberp high) (<= object high)) - ((and (consp high) (numberp (car high))) - (< object (car high))) - (t nil))))) - - -;;; Structure-Typep -- Internal -;;; -;;; This is called by Typep if the type-specifier is a symbol and is not one of -;;; the built-in Lisp types. If it's a structure, see if it's that type, or if -;;; it includes that type. -;;; -(defun structure-typep (object type) - (declare (optimize speed)) - (let ((type (type-expand type))) - (if (symbolp type) - (let ((info (info type defined-structure-info type))) - (if info - (and (structurep object) - (let ((obj-name (%primitive header-ref object 0))) - (or (eq obj-name type) - (if (memq obj-name (c::dd-included-by info)) - t nil)))) - (error "~S is an unknown type specifier." type))) - (error "~S is an unknown type specifier." type)))) - - -;;;; Assorted mumble-P type predicates. - -(defun commonp (object) - "Returns T if object is a legal Common-Lisp type, NIL if object is any - sort of implementation-dependent or internal type." - (or (structurep object) - (let ((type-spec (type-of object))) - (if (listp type-spec) (setq type-spec (car type-spec))) - (when (memq type-spec - '(character fixnum short-float single-float double-float - long-float vector string simple-vector - simple-string bignum ratio complex - compiled-function array symbol cons)) - T)))) - -(defun bit-vector-p (object) - "Returns T if the object is a bit vector, else returns NIL." - (bit-vector-p object)) - -;;; The following definitions are trivial because the compiler open-codes -;;; all of these. - -(defun null (object) - "Returns T if the object is NIL, else returns NIL." - (null object)) - -(defun not (object) - "Returns T if the object is NIL, else returns NIL." - (null object)) - -(defun symbolp (object) - "Returns T if the object is a symbol, else returns NIL." - (symbolp object)) - -(defun atom (object) - "Returns T if the object is not a cons, else returns NIL. - Note that (ATOM NIL) => T." - (atom object)) - -(defun consp (object) - "Returns T if the object is a cons cell, else returns NIL. - Note that (CONSP NIL) => NIL." - (consp object)) - -(defun listp (object) - "Returns T if the object is a cons cell or NIL, else returns NIL." - (listp object)) - -(defun numberp (object) - "Returns T if the object is any kind of number." - (numberp object)) - -(defun integerp (object) - "Returns T if the object is an integer (fixnum or bignum), else - returns NIL." - (integerp object)) - -(defun rationalp (object) - "Returns T if the object is an integer or a ratio, else returns NIL." - (rationalp object)) - -(defun floatp (object) - "Returns T if the object is a floating-point number, else returns NIL." - (floatp object)) - -(defun complexp (object) - "Returns T if the object is a complex number, else returns NIL." - (complexp object)) - -(defun %standard-char-p (x) - (and (characterp x) (standard-char-p x))) - -(defun characterp (object) - "Returns T if the object is a character, else returns NIL." - (characterp object)) - -(defun stringp (object) - "Returns T if the object is a string, else returns NIL." - (stringp object)) - -(defun simple-string-p (object) - "Returns T if the object is a simple string, else returns NIL." - (simple-string-p object)) - -(defun vectorp (object) - "Returns T if the object is any kind of vector, else returns NIL." - (vectorp object)) - -(defun simple-array-p (object) - "Returns T if the object is a simple array, else returns NIL." - (and (arrayp object) (not (array-header-p object)))) - -(defun simple-vector-p (object) - "Returns T if the object is a simple vector, else returns NIL." - (simple-vector-p object)) - -(defun simple-bit-vector-p (object) - "Returns T if the object is a simple bit vector, else returns NIL." - (simple-bit-vector-p object)) - -(defun arrayp (object) - "Returns T if the argument is any kind of array, else returns NIL." - (arrayp object)) - -(defun functionp (object) - "Returns T if the object is a function, suitable for use by FUNCALL - or APPLY, else returns NIL." - (functionp object)) - -(defun compiled-function-p (object) - "Returns T if the object is a compiled function object, else returns NIL." - (compiled-function-p object)) - -;;; ### Dummy definition until we figure out what to really do... -(defun clos::funcallable-instance-p (object) - (declare (ignore object)) - nil) - -(defun sequencep (object) - "Returns T if object is a sequence, NIL otherwise." - (typep object 'sequence)) - - -;;; The following are not defined at user level, but are necessary for -;;; internal use by TYPEP. - -(defun structurep (object) - (structurep object)) - -(defun fixnump (object) - (fixnump object)) - -(defun bignump (object) - (bignump object)) - -(defun bitp (object) - (typep object 'bit)) - -(defun short-float-p (object) - (typep object 'short-float)) - -(defun single-float-p (object) - (typep object 'single-float)) - -(defun double-float-p (object) - (typep object 'double-float)) - -(defun long-float-p (object) - (typep object 'long-float)) - -(defun ratiop (object) - (ratiop object)) - -;;; Some silly internal things for tenser array hacking: - -(defun array-header-p (object) - (array-header-p object)) - -;;;; Equality Predicates. - -(defun eq (x y) - "Returns T if X and Y are the same object, else returns NIL." - (eq x y)) - -(defun eql (x y) - "Returns T if X and Y are EQ, or if they are numbers of the same - type and precisely equal value, or if they are characters and - are CHAR=, else returns NIL." - (eql x y)) - -(defun equal (x y) - "Returns T if X and Y are EQL or if they are structured components - whose elements are EQUAL. Strings and bit-vectors are EQUAL if they - are the same length and have indentical components. Other arrays must be - EQ to be EQUAL." - (cond ((eql x y) t) - ((consp x) - (and (consp y) - (equal (car x) (car y)) - (equal (cdr x) (cdr y)))) - ((stringp x) - (and (stringp y) (string= x y))) - ((pathnamep x) - (and (pathnamep y) - (do* ((i 1 (1+ i)) - (len (length x))) - ((>= i len) t) - (declare (fixnum i len)) - (let ((x-el (svref x i)) - (y-el (svref y i))) - (if (and (simple-vector-p x-el) - (simple-vector-p y-el)) - (let ((lx (length x-el)) - (ly (length y-el))) - (declare (fixnum lx ly)) - (if (/= lx ly) (return nil)) - (do ((i 0 (1+ i))) - ((>= i lx)) - (declare (fixnum i)) - (if (not (equal (svref x-el i) (svref y-el i))) - (return-from equal nil)))) - (unless (or (eql x-el y-el) - (equal x-el y-el)) - (return nil))))))) - ((bit-vector-p x) - (and (bit-vector-p y) - (= (the fixnum (length x)) - (the fixnum (length y))) - (do ((i 0 (1+ i)) - (length (length x))) - ((= i length) t) - (declare (fixnum i)) - (or (= (the fixnum (bit x i)) - (the fixnum (bit y i))) - (return nil))))) - (t nil))) - - -(defun equalp (x y) - "Just like EQUAL, but more liberal in several respects. - Numbers may be of different types, as long as the values are identical - after coercion. Characters may differ in alphabetic case. Vectors and - arrays must have identical dimensions and EQUALP elements, but may differ - in their type restriction." - (cond ((eql x y) t) - ((characterp x) (char-equal x y)) - ((numberp x) (and (numberp y) (= x y))) - ((consp x) - (and (consp y) - (equalp (car x) (car y)) - (equalp (cdr x) (cdr y)))) - ((vectorp x) - (let ((length (length x))) - (declare (fixnum length)) - (and (vectorp y) - (= length (the fixnum (length y))) - (dotimes (i length t) - (let ((x-el (aref x i)) - (y-el (aref y i))) - (unless (or (eql x-el y-el) - (equalp x-el y-el)) - (return nil))))))) - ((arrayp x) - (let ((rank (array-rank x)) - (len (%primitive header-ref x %array-length-slot))) - (declare (fixnum rank len)) - (and (arrayp y) - (= (the fixnum (array-rank y)) rank) - (dotimes (i rank t) - (unless (= (the fixnum (array-dimension x i)) - (the fixnum (array-dimension y i))) - (return nil))) - (with-array-data ((x-vec x) (x-start) (end)) - (declare (ignore end)) - (with-array-data ((y-vec y) (y-start) (end)) - (declare (ignore end)) - (do ((i x-start (1+ i)) - (j y-start (1+ j)) - (count len (1- count))) - ((zerop count) t) - (declare (fixnum i j count)) - (let ((x-el (aref x-vec i)) - (y-el (aref y-vec j))) - (unless (or (eql x-el y-el) - (equalp x-el y-el)) - (return nil))))))))) - (t nil))) diff --git a/code/print.lisp b/code/print.lisp deleted file mode 100644 index ac33b3ec2bf7ca94ee8a1c4db88da397cf5f9c2b..0000000000000000000000000000000000000000 --- a/code/print.lisp +++ /dev/null @@ -1,1261 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; CMU Common Lisp printer. -;;; -;;; Written by Neal Feinberg, Bill Maddox, Steven Handerson, and Skef Wholey. -;;; Modified by various CMU Common Lisp maintainers. -;;; - -(in-package "LISP") - -(export '(*print-escape* *print-pretty* *print-circle* *print-base* - *print-radix* *print-case* *print-level* *print-length* - *print-array* *print-gensym* write prin1 print princ - write-to-string prin1-to-string princ-to-string)) - -(defvar *print-escape* T - "Flag which indicates that slashification is on. See the manual") -(defvar *print-pretty* T - "Flag which indicates that pretty printing is to be used") -(defvar *print-base* 10. - "The output base for integers and rationals.") -(defvar *print-radix* () - "This flag requests to verify base when printing rationals.") -(defvar *print-level* () - "How many levels deep to print. Unlimited if null.") -(defvar *print-length* () - "How many elements to print on each level. Unlimited if null.") -(defvar *print-circle* () - "Whether to worry about circular list structures. See the manual.") -(defvar *print-case* ':upcase - "What kind of case the printer should use by default") -(defvar *print-array* T - "Whether the array should print it's guts out") -(defvar *print-gensym* T - "If true, symbols with no home package are printed with a #: prefix. - If false, no prefix is printed.") - - -;;; Imported from reader. -;;; -(proclaim '(special *read-default-float-format*)) - -;;; From the package system. -;;; -(proclaim '(special *package* *keyword-package*)) - - -;;; DOSTRING -- Internal. -;;; -;;; This macro returns code which maps over a string, binding VARIABLE to each -;;; successive character in the string INIT-FORM, and executing BODY with -;;; the variable so bound. This function used to be part of Common Lisp, but -;;; is no more. It lives on in the printer, though. -;;; -(defmacro dostring ((variable init-form terminate-form) &rest body) - (let ((str (gensym)) - (end (gensym)) - (index (gensym))) - `(let* ((,str ,init-form) - (,end (length (the string ,str))) - (,index 0)) - (declare (fixnum ,index ,end)) - (loop - (when (= ,index ,end) (return ,terminate-form)) - (let ((,variable (char ,str ,index))) - ,@body) - (incf ,index))))) - - - -;;;; Printing Functions - -(proclaim '(inline setup-printer-state)) - -(defvar *previous-case* () - "What the previous case selection the printer was set to.") - -;;; This variable contains the current definition of one of three symbol -;;; printers. SETUP-PRINTER-STATE sets this variable. -;;; -(defvar *internal-symbol-output-function* nil) - -;;; SETUP-PRINTER-STATE -- Internal. -;;; -;;; This function sets the internal global symbol -;;; *internal-symbol-output-function* to the right function depending on the -;;; value of *print-case*. See the manual for details. The print buffer -;;; stream is also reset. -;;; -(defun setup-printer-state () - (unless (eq *print-case* *previous-case*) - (setq *previous-case* *print-case*) - (setq *internal-symbol-output-function* - (case *print-case* - (:upcase #'output-uppercase-symbol) - (:downcase #'output-lowercase-symbol) - (:capitalize #'output-capitalize-symbol) - (T (let ((bad-case *print-case*)) - (setq *print-case* :upcase) - (Error "Invalid *print-case* value: ~s" bad-case))))))) - - -(defun write (object &key - ((:stream stream) *standard-output*) - ((:escape *print-escape*) *print-escape*) - ((:radix *print-radix*) *print-radix*) - ((:base *print-base*) *print-base*) - ((:circle *print-circle*) *print-circle*) - ((:pretty *print-pretty*) *print-pretty*) - ((:level *print-level*) *print-level*) - ((:length *print-length*) *print-length*) - ((:case *print-case*) *print-case*) - ((:array *print-array*) *print-array*) - ((:gensym *print-gensym*) *print-gensym*)) - "Outputs OBJECT to the specified stream, defaulting to *standard-output*" - (setup-printer-state) - (let ((stream (out-synonym-of stream))) - (if *print-pretty* - (output-pretty-object object stream) - (output-object object stream))) - object) - -(defun prin1 (object &optional stream) - "Outputs a mostly READable printed representation of OBJECT on the specified - stream." - (let ((stream (out-synonym-of stream))) - (setup-printer-state) - (let ((*print-escape* T)) - (if *print-pretty* - (output-pretty-object object stream) - (output-object object stream))) - object)) - -(defun princ (object &optional stream) - "Outputs an asthetic but not READable printed representation of OBJECT on the - specified stream." - (let ((stream (out-synonym-of stream))) - (setup-printer-state) - (let ((*print-escape* NIL)) - (if *print-pretty* - (output-pretty-object object stream) - (output-object object stream))) - object)) - -(defun print (object &optional stream) - "Outputs a terpri, the mostly READable printed represenation of OBJECT, and - space to the stream." - (let ((stream (out-synonym-of stream))) - (terpri stream) - (prin1 object stream) - (write-char #\space stream) - object)) - -(defun write-to-string (object &key - ((:escape *print-escape*) *print-escape*) - ((:radix *print-radix*) *print-radix*) - ((:base *print-base*) *print-base*) - ((:circle *print-circle*) *print-circle*) - ((:pretty *print-pretty*) *print-pretty*) - ((:level *print-level*) *print-level*) - ((:length *print-length*) *print-length*) - ((:case *print-case*) *print-case*) - ((:array *print-array*) *print-array*) - ((:gensym *print-gensym*) *print-gensym*)) - "Returns the printed representation of OBJECT as a string." - (stringify-object object *print-escape*)) - -(defun prin1-to-string (object) - "Returns the printed representation of OBJECT as a string with - slashification on." - (stringify-object object t)) - -(defun princ-to-string (object) - "Returns the printed representation of OBJECT as a string with - slashification off." - (stringify-object object nil)) - -(defvar *print-string-stream* (make-string-output-stream) - "Holds the string stream for the x-TO-STRING functions.") - -(defvar *in-stringify-object* () - "T if in the middle of stringify-object.") - -;;; STRINGIFY-OBJECT -- Internal. -;;; -;;; This produces the printed representation of an object as a string. The -;;; few ...-TO-STRING functions above call this. -;;; -(defun stringify-object (object &optional (*print-escape* nil)) - (let ((stream (if *in-stringify-object* - (make-string-output-stream) - *print-string-stream*)) - (*in-stringify-object* t)) - (setup-printer-state) - (if *print-pretty* - (output-pretty-object object stream) - (output-object object stream 0)) - (get-output-stream-string stream))) - - - -;;;; Central Print Functions. - -;;; OUTPUT-OBJECT -- Internal. -;;; -;;; This takes an object and outputs its printed representation to stream, -;;; which typically is the internal print stream. This function is called -;;; recursively by the sub-functions which know how to print structures which -;;; can contain other lisp objects. -;;; -(defun output-object (object stream &optional (currlevel 0)) - "Outputs a string which is the printed representation of the given object." - ;; First check and make sure we aren't too deep - (declare (fixnum currlevel)) - (if (and (not (null *print-level*)) - (not (= *print-level* 0)) - (>= currlevel (the fixnum *print-level*))) - (write-char #\# stream) - (typecase object - (symbol - (if *print-escape* - (output-symbol object stream) - (case *print-case* - (:upcase (write-string (symbol-name object) stream)) - (:downcase - (let ((name (symbol-name object))) - (declare (simple-string name)) - (dotimes (i (length name)) - (write-char (char-downcase (char name i)) stream)))) - (:capitalize - (write-string (string-capitalize (symbol-name object)) - stream))))) - ;; If a list, go through element by element, being careful - ;; about not running over the printlength - (list - (output-list object stream (1+ currlevel))) - (string - (if *print-escape* - (quote-string object stream) - (write-string object stream))) - (integer - (output-integer object stream)) - (float - (output-float object stream)) - (ratio - (output-ratio object stream)) - (complex - (output-complex object stream)) - (structure - (output-structure object stream currlevel)) - (character - (output-character object stream)) - (vector - (output-vector object stream)) - (array - (output-array object stream (1+ currlevel))) - (t (output-random object stream))))) - - - -;;;; Symbol Printing Subfunctions - -(defun output-symbol (object stream) - (let ((package (symbol-package object)) - (name (symbol-name object))) - (cond - ;; If the symbol's home package is the current one, then a - ;; prefix is never necessary. - ((eq package *package*)) - ;; If the symbol is in the keyword package, output a colon. - ((eq package *keyword-package*) - (write-char #\: stream)) - ;; Uninterned symbols print with a leading #:. - ((null package) - (when *print-gensym* (write-string "#:" stream))) - (t - (let ((found (car (memq package (package-use-list *package*))))) - (multiple-value-bind (symbol externalp) - (find-external-symbol name package) - ;; If the symbol's home package is in our use list and is an external - ;; symbol there, then it needs no qualification. - (unless (and found externalp (eq symbol object)) - (multiple-value-bind (symbol accessible) - (find-symbol name *package*) - ;; If we can find the symbol by looking it up, it need not be - ;; qualified. This can happen if the symbol has been inherited - ;; from a package other than its home package. - (unless (and accessible (eq symbol object)) - (funcall *internal-symbol-output-function* - (package-name package) - stream) - (if externalp - (write-char #\: stream) - (write-string "::" stream))))))))) - (funcall *internal-symbol-output-function* name stream))) - - - -;;;; Escaping symbols: - -;;; When we print symbols we have to figure out if they need to be -;;; printed with escape characters. This isn't a whole lot easier than -;;; reading symbols in the first place. -;;; -;;; For each character, the value of the corresponding element is a fixnum -;;; with bits set corresponding to attributes that the character has. This -;;; is also used by the character printer. -;;; -(defvar character-attributes - (make-array char-code-limit :element-type '(unsigned-byte 8) - :initial-element 0)) - -(eval-when (compile load eval) - -;;; Constants which are a bit-mask for each interesting character attribute. -;;; -(defconstant number-attribute #b10) ; A numeric digit. -(defconstant letter-attribute #b100) ; A upper-case letter. -(defconstant sign-attribute #b1000) ; +- -(defconstant extension-attribute #b10000) ; ^_ -(defconstant dot-attribute #b100000) ; . -(defconstant slash-attribute #b1000000) ; / -(defconstant other-attribute #b1) ; Anything else legal. -(defconstant funny-attribute #b10000000) ; Anything illegal. - -(defconstant attribute-names - '((number . number-attribute) (letter . letter-attribute) - (sign . sign-attribute) (extension . extension-attribute) - (dot . dot-attribute) (slash . slash-attribute) - (other . other-attribute) (funny . funny-attribute))) - -); Eval-When (compile load eval) - -(flet ((set-bit (char bit) - (let ((code (char-code char))) - (setf (aref character-attributes code) - (logior bit (aref character-attributes code)))))) - - (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\} - #\? #\< #\>)) - (set-bit char other-attribute)) - - (dotimes (i 10) - (set-bit (digit-char i) number-attribute)) - - (do ((code (char-code #\A) (1+ code)) - (end (char-code #\Z))) - ((> code end)) - (declare (fixnum code end)) - (set-bit (code-char code) letter-attribute)) - - (set-bit #\- sign-attribute) - (set-bit #\+ sign-attribute) - (set-bit #\^ extension-attribute) - (set-bit #\_ extension-attribute) - (set-bit #\. dot-attribute) - (set-bit #\/ slash-attribute) - - ;; Make anything not explicitly allowed funny... - (dotimes (i char-code-limit) - (when (zerop (aref character-attributes i)) - (setf (aref character-attributes i) funny-attribute)))) - -;;; For each character, the value of the corresponding element is the lowest -;;; base in which that character is a digit. -;;; -(defvar digit-bases - (make-array char-code-limit :element-type '(mod 37) :initial-element 36)) - -(dotimes (i 36) - (let ((char (digit-char i 36))) - (setf (aref digit-bases (char-code char)) i))) - - -;;; SYMBOL-QUOTEP -- Internal -;;; -;;; A FSM-like thingie that determines whether a symbol is a potential -;;; number or has evil characters in it. -;;; -(defun symbol-quotep (name) - (declare (simple-string name)) - (macrolet ((advance (tag &optional (at-end t)) - `(progn - (when (= index len) - ,(if at-end '(go TEST-SIGN) '(return nil))) - (setq current (schar name index) - code (char-code current) - bits (aref attributes code)) - (incf index) - (go ,tag))) - (test (&rest attributes) - `(not (zerop - (the fixnum - (logand - (logior ,@(mapcar - #'(lambda (x) - (or (cdr (assoc x attribute-names)) - (error "Blast!"))) - attributes)) - bits))))) - (digitp () - `(< (the fixnum (aref bases code)) base))) - - (prog ((len (length name)) - (attributes character-attributes) - (bases digit-bases) - (base *print-base*) - (index 0) - (bits 0) - (code 0) - current) - (declare (fixnum len base index bits code)) - (advance START t) - - TEST-SIGN ; At end, see if it is a sign... - (return (not (test sign))) - - OTHER ; Not potential number, see if funny chars... - (return (not (null (%primitive find-character-with-attribute - name (1- index) len - attributes funny-attribute)))) - START - (when (digitp) - (if (test letter) - (advance LAST-DIGIT-ALPHA) - (advance DIGIT))) - (when (test letter number other slash) (advance OTHER nil)) - (when (char= current #\.) (advance DOT-FOUND)) - (when (test sign extension) (advance START-STUFF nil)) - (return t) - - DOT-FOUND ; Leading dots... - (when (test letter) (advance START-DOT-MARKER nil)) - (when (digitp) (advance DOT-DIGIT)) - (when (test number other) (advance OTHER nil)) - (when (test extension slash sign) (advance START-DOT-STUFF nil)) - (when (char= current #\.) (advance DOT-FOUND)) - (return t) - - START-STUFF ; Leading stuff before any dot or digit. - (when (digitp) - (if (test letter) - (advance LAST-DIGIT-ALPHA) - (advance DIGIT))) - (when (test number other) (advance OTHER nil)) - (when (test letter) (advance START-MARKER nil)) - (when (char= current #\.) (advance START-DOT-STUFF nil)) - (when (test sign extension slash) (advance START-STUFF nil)) - (return t) - - START-MARKER ; Number marker in leading stuff... - (when (test letter) (advance OTHER nil)) - (go START-STUFF) - - START-DOT-STUFF ; Leading stuff containing dot w/o digit... - (when (test letter) (advance START-DOT-STUFF nil)) - (when (digitp) (advance DOT-DIGIT)) - (when (test sign extension dot slash) (advance START-DOT-STUFF nil)) - (when (test number other) (advance OTHER nil)) - (return t) - - START-DOT-MARKER ; Number marker in leading stuff w/ dot.. - ;; Leading stuff containing dot w/o digit followed by letter... - (when (test letter) (advance OTHER nil)) - (go START-DOT-STUFF) - - DOT-DIGIT ; In a thing with dots... - (when (test letter) (advance DOT-MARKER)) - (when (digitp) (advance DOT-DIGIT)) - (when (test number other) (advance OTHER nil)) - (when (test sign extension dot slash) (advance DOT-DIGIT)) - (return t) - - DOT-MARKER ; Number maker in number with dot... - (when (test letter) (advance OTHER nil)) - (go DOT-DIGIT) - - LAST-DIGIT-ALPHA ; Previous char is a letter digit... - (when (or (digitp) (test sign slash)) - (advance ALPHA-DIGIT)) - (when (test letter number other dot) (advance OTHER nil)) - (return t) - - ALPHA-DIGIT ; Seen a digit which is a letter... - (when (or (digitp) (test sign slash)) - (if (test letter) - (advance LAST-DIGIT-ALPHA) - (advance ALPHA-DIGIT))) - (when (test letter) (advance ALPHA-MARKER)) - (when (test number other dot) (advance OTHER nil)) - (return t) - - ALPHA-MARKER ; Number marker in number with alpha digit... - (when (test letter) (advance OTHER nil)) - (go ALPHA-DIGIT) - - DIGIT ; Seen only real numeric digits... - (when (digitp) - (if (test letter) - (advance ALPHA-DIGIT) - (advance DIGIT))) - (when (test number other) (advance OTHER nil)) - (when (test letter) (advance MARKER)) - (when (test extension slash sign) (advance DIGIT)) - (when (char= current #\.) (advance DOT-DIGIT)) - (return t) - - MARKER ; Number marker in a numeric number... - (when (test letter) (advance OTHER nil)) - (go DIGIT)))) - -;;;; Pathname hackery - -;;; This function takes the pname of a symbol and adds slashes and/or -;;; vertical bars to it to make it readable again. -;;; Special quoting characters are currently vertical bar and slash who's -;;; role in life are to specially quote symbols. Funny symbol characters -;;; are those who need special slashification when they are to be printed -;;; so they can be read in again. These currently include such characters -;;; as hash signs, colons of various sorts, etc. -;;; Now there are three different version: UPPERCASE, lowercase and Captialize. -;;; Check out the manual under the entry for *print-case* for details. - -(eval-when (compile eval) -(defmacro symbol-quote-char-p (char) - `(or (char= ,char #\\) (char= ,char #\|))) -); eval-when (compile eval) - -(defun output-uppercase-symbol (pname stream) - (declare (simple-string pname)) - (cond ((symbol-quotep pname) - (write-char #\| stream) - (dostring (char pname) - ;;If it needs slashing, do it. - (if (symbol-quote-char-p char) - (write-char #\\ stream)) - (write-char char stream)) - (write-char #\| stream)) - (t - (write-string pname stream)))) - -;;; See documentation for output-symbol-uppercase (above). -;;; -(defun output-lowercase-symbol (pname stream) - (declare (simple-string pname)) - (cond ((symbol-quotep pname) - (write-char #\| stream) - (dostring (char pname) - (if (symbol-quote-char-p char) - (write-char #\\ stream)) - (write-char char stream)) - (write-char #\| stream)) - (t - (dostring (char pname) - (write-char (char-downcase char) stream))))) - - -(defun output-capitalize-symbol (pname stream) - (declare (simple-string pname)) - (cond - ((symbol-quotep pname) - (write-char #\| stream) - (dostring (char pname) - (if (symbol-quote-char-p char) - (write-char #\\ stream)) - (write-char char stream)) - (write-char #\| stream)) - (t - (do ((index 0 (1+ index)) - (pname-length (length (the string pname))) - (prev-not-alpha t)) - ((= index pname-length)) - (declare (fixnum index pname-length)) - (let ((char (char pname index))) - (write-char (if prev-not-alpha char (char-downcase char)) stream) - (setq prev-not-alpha (not (alpha-char-p char)))))))) - - - -;;;; Recursive Datatype Printing Subfunctions - -(defun output-list (list stream &optional (currlevel 0)) - (write-char #\( stream) - (do ((list list (cdr list)) - (currlength 0 (1+ currlength))) - ((or (null list) - (and (not (null *print-length*)) - (>= currlength (the fixnum *print-length*)))) - (if (not (null list)) (write-string " ..." stream)) - (write-char #\) stream)) - (declare (fixnum currlength)) - ;;If we are not printing the first object, we should space first. - (if (> currlength 0) (write-char #\space stream)) - ;;Print whatever the car of the list is, at this level. - (output-object (car list) stream currlevel) - (cond ((not (or (consp (cdr list)) - (null (cdr list)))) - (write-string " . " stream) - (output-object (cdr list) stream currlevel) - (write-char #\) stream) - (return ()))))) - -(defun output-vector (vector stream &optional (currlevel 0)) - (declare (fixnum currlevel)) - (cond ((not *print-array*) - (output-terse-array vector stream currlevel)) - (T - (if (bit-vector-p vector) - (write-string "#*" stream) - (write-string "#(" stream)) - (do ((currlength 0 (1+ currlength)) - (vlength (length (the vector vector))) - (not-bit-vector-p (not (bit-vector-p vector)))) - ((or (and (not (null *print-length*)) - (>= currlength (the fixnum *print-length*))) - (= currlength vlength)) - (if (not (= currlength vlength)) (write-string " ..." stream)) - (if not-bit-vector-p - (write-char #\) stream))) - (declare (fixnum currlength vlength)) - ;;Put a space before every element except the first - ;; and not in bit vectors. - (if (and (> currlength 0) not-bit-vector-p) - (write-char #\space stream)) - ;;Output an element of the vector - (output-object (aref vector currlength) stream currlevel))))) - -(defun output-array (array stream &optional (currlevel 0)) - "Outputs the printed representation of any array in either the #< or #A form." - (let ((rank (array-rank array))) - (cond ((not *print-array*) - (output-terse-array array stream rank)) - (T - (output-array-guts array rank stream currlevel))))) - -;;; Master function for outputing the #A form of an array -;;; -(defun output-array-guts (array rank stream currlevel) - (write-char #\# stream) - (let ((*print-base* 10)) - (output-integer rank stream)) - (write-char #\A stream) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (sub-output-array-guts data (array-dimensions array) - stream currlevel start))) - -;;; Some Ideas stolen from Skef Wholey. -;;; Helping function for above. -(defun sub-output-array-guts (array dimensions stream currlevel index) - (declare (fixnum currlevel index)) - (cond ((null dimensions) - (output-object (aref array index) stream currlevel) - (1+ index)) - ((and (not (null *print-level*)) - (>= currlevel (the fixnum *print-level*))) - (write-char #\# stream) - index) - (t - (write-char #\( stream) - (do ((index index) - (times 0 (1+ times)) - (limit (pop dimensions))) - ((or (= times limit) - (and (not (null *print-length*)) - (= times *print-length*))) - (if (not (= times limit)) - (write-string " ...)" stream) - (write-char #\) stream)) - index) - (declare (fixnum index times limit)) - (if (not (zerop times)) (write-char #\space stream)) - (setq index - (sub-output-array-guts array dimensions - stream (1+ currlevel) index)))))) - -;;; Used to output the #< form of any array. -;;; -(defun output-terse-array (array stream rank) - (write-string "#<" stream) - (cond ((vectorp array) - (if (bit-vector-p array) - (write-string "Bit-vector" stream) - (write-string "Vector" stream))) - (T - (write-string "Array, rank " stream) - (output-integer rank stream))) - (finish-random array stream)) - - -;;; Structure Printing. These days we can always pass the buck to the Defstruct -;;; code. - -(defun output-structure (structure stream currlevel) - (funcall (or (info type printer (svref structure 0)) - #'c::default-structure-print) - structure stream currlevel)) - - -;;;; Functions to help print strings. - -;;; QUOTE-STRING -- Internal. -;;; -;;; This function outputs a string quoting characters sufficiently, so someone -;;; can read it in again. Basically, put a slash in front of an character -;;; satisfying FROB. -;;; -(defun quote-string (string stream) - (macrolet ((frob (char) - ;; Probably should look at readtable, but just do this for now. - `(or (char= ,char #\\) - (char= ,char #\")))) - (write-char #\" stream) - (dostring (char string) - (when (frob char) (write-char #\\ stream)) - (write-char char stream)) - (write-char #\" stream))) - - -(defun whitespace-char-p (char) - "Determines whether or not the character is considered whitespace." - (or (char= char #\space) - (char= char #\tab) - (char= char #\return) - (char= char #\linefeed))) - -;;;; Integer, ratio, complex printing. - -(defun output-integer (integer stream) - (cond ((not (and (fixnump *print-base*) (> (the fixnum *print-base*) 1))) - (let ((obase *print-base*)) - (setq *print-base* 10.) - (error "~A is not a reasonable value for *Print-Base*." obase))) - ;; Otherwise print the base - (T (cond ((and (not (= *print-base* 10.)) - *print-radix*) - ;; First print leading base information, if any. - (write-char #\# stream) - (write-char (case *print-base* - (2. #\b) - (8. #\o) - (16. #\x) - (T (let ((fixbase *print-base*) - (*print-base* 10.) - (*print-radix* ())) - (sub-output-integer fixbase stream)) - #\r)) - stream))) - ;; Then output a minus sign if the number is negative, then output - ;; the absolute value of the number. - (cond ((bignump integer) (print-bignum integer stream)) - ((< integer 0) - (write-char #\- stream) - (sub-output-integer (- integer) stream)) - (T (sub-output-integer integer stream))) - ;; Print any trailing base information, if any. - (if (and (= *print-base* 10.) *print-radix*) - (write-char #\. stream))))) - -(defun sub-output-integer (integer stream) - (let ((quotient ()) - (remainder ())) - ;; Recurse until you have all the digits pushed on the stack. - (if (not (zerop (multiple-value-setq (quotient remainder) - (truncate integer *print-base*)))) - (sub-output-integer quotient stream)) - ;; Then as each recursive call unwinds, turn the digit (in remainder) - ;; into a character and output the character. - (write-char (int-char (if (and (> remainder 9.) - (> *print-base* 10.)) - (+ (char-int #\A) (- remainder 10.)) - (+ (char-int #\0) remainder))) - stream))) - - -(defun output-ratio (ratio stream) - (when *print-radix* - (write-char #\# stream) - (case *print-base* - (2 (write-char #\b stream)) - (8 (write-char #\o stream)) - (16 (write-char #\x stream)) - (t (write *print-base* :stream stream :radix nil :base 10))) - (write-char #\r stream)) - (let ((*print-radix* nil)) - (output-integer (numerator ratio) stream) - (write-char #\/ stream) - (output-integer (denominator ratio) stream))) - -(defun output-complex (complex stream) - (write-string "#C(" stream) - (output-object (realpart complex) stream) - (write-char #\space stream) - (output-object (imagpart complex) stream) - (write-char #\) stream)) - - - -;;;; Bignum printing - -;;; Written by Steven Handerson -;;; (based on Skef's idea) - -;;; BIGNUM-FIXNUM-DIVIDE-INPLACE wants the divisor to be of integer-length 19 -;;; or less. 1- the ideal power of the base for a divisor. -;;; -(defparameter *fixnum-power--1* - '#(NIL NIL 17 10 8 7 6 5 5 4 4 4 4 4 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 - 2)) - -;;; The base raised to the ideal power. -;;; -(defparameter *base-power* - '#(NIL NIL 262144 177147 262144 390625 279936 117649 262144 59049 100000 - 161051 248832 371293 38416 50625 65536 83521 104976 130321 160000 - 194481 234256 279841 331776 390625 456976 19683 21952 24389 27000 - 29791 32768 35937 39304 42875)) - -(defun print-bignum (big stream) - (bignum-print-aux (cond ((minusp big) - (write-char #\- stream) - (- big)) - (t (copy-xnum big))) - stream) - big) - -(defun bignum-print-aux (big stream) - (multiple-value-bind (newbig fix) - (bignum-fixnum-divide-inplace - big (aref *base-power* *print-base*)) - (if (fixnump newbig) - (sub-output-integer newbig stream) - (bignum-print-aux newbig stream)) - (do ((zeros (aref *fixnum-power--1* *print-base*) (1- zeros)) - (base-power *print-base* (* base-power *print-base*))) - ((> base-power fix) - (dotimes (i zeros) (write-char #\0 stream)) - (sub-output-integer fix stream))))) - - - -;;;; Floating Point printing -;;; -;;; Written by Bill Maddox -;;; -;;; -;;; -;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of -;;; the work for all printing of floating point numbers in the printer and in -;;; FORMAT. It converts a floating point number to a string in a free or -;;; fixed format with no exponent. The interpretation of the arguments is as -;;; follows: -;;; -;;; X - The floating point number to convert, which must not be -;;; negative. -;;; WIDTH - The preferred field width, used to determine the number -;;; of fraction digits to produce if the FDIGITS parameter -;;; is unspecified or NIL. If the non-fraction digits and the -;;; decimal point alone exceed this width, no fraction digits -;;; will be produced unless a non-NIL value of FDIGITS has been -;;; specified. Field overflow is not considerd an error at this -;;; level. -;;; FDIGITS - The number of fractional digits to produce. Insignificant -;;; trailing zeroes may be introduced as needed. May be -;;; unspecified or NIL, in which case as many digits as possible -;;; are generated, subject to the constraint that there are no -;;; trailing zeroes. -;;; SCALE - If this parameter is specified or non-NIL, then the number -;;; printed is (* x (expt 10 scale)). This scaling is exact, -;;; and cannot lose precision. -;;; FMIN - This parameter, if specified or non-NIL, is the minimum -;;; number of fraction digits which will be produced, regardless -;;; of the value of WIDTH or FDIGITS. This feature is used by -;;; the ~E format directive to prevent complete loss of -;;; significance in the printed value due to a bogus choice of -;;; scale factor. -;;; -;;; Most of the optional arguments are for the benefit for FORMAT and are not -;;; used by the printer. -;;; -;;; Returns: -;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) -;;; where the results have the following interpretation: -;;; -;;; DIGIT-STRING - The decimal representation of X, with decimal point. -;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. -;;; LEADING-POINT - True if the first character of DIGIT-STRING is the -;;; decimal point. -;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the -;;; decimal point. -;;; POINT-POS - The position of the digit preceding the decimal -;;; point. Zero indicates point before first digit. -;;; -;;; WARNING: For efficiency, there is a single string object *digit-string* -;;; which is modified destructively and returned as the value of -;;; FLONUM-TO-STRING. Thus the returned value is not valid across multiple -;;; calls. -;;; -;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy. -;;; Specifically, the decimal number printed is the closest possible -;;; approximation to the true value of the binary number to be printed from -;;; among all decimal representations with the same number of digits. In -;;; free-format output, i.e. with the number of digits unconstrained, it is -;;; guaranteed that all the information is preserved, so that a properly- -;;; rounding reader can reconstruct the original binary number, bit-for-bit, -;;; from its printed decimal representation. Furthermore, only as many digits -;;; as necessary to satisfy this condition will be printed. -;;; -;;; -;;; FLOAT-STRING actually generates the digits for positive numbers. The -;;; algorithm is essentially that of algorithm Dragon4 in "How to Print -;;; Floating-Point Numbers Accurately" by Steele and White. The current -;;; (draft) version of this paper may be found in [CMUC]<steele>tradix.press. -;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING -;;; THE PAPER! - -(defvar *digits* "0123456789") - -(defvar *digit-string* - (make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t)) - -(defun flonum-to-string (x &optional width fdigits scale fmin) - (cond ((zerop x) - ;;zero is a special case which float-string cannot handle - (if fdigits - (let ((s (make-string (1+ fdigits) :initial-element #\0))) - (setf (schar s 0) #\.) - (values s (length s) t (zerop fdigits) 0)) - (values "." 1 t t 0))) - (t - (setf (fill-pointer *digit-string*) 0) - (multiple-value-bind (sig exp) - (integer-decode-float x) - (if (typep x 'short-float) - ;;20 and 53 are the number of bits of information in the - ;;significand, less sign, of a short float and a long float - ;;respectively. - (float-string sig exp 20 width fdigits scale fmin) - (float-string sig exp 53 width fdigits scale fmin)))))) - -(defun float-string (fraction exponent precision width fdigits scale fmin) - (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0) - (digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high) - ;;Represent fraction as r/s, error bounds as m+/s and m-/s. - ;;Rational arithmetic avoids loss of precision in subsequent calculations. - (cond ((> exponent 0) - (setq r (ash fraction exponent)) - (setq m- (ash 1 exponent)) - (setq m+ m-)) - ((< exponent 0) - (setq s (ash 1 (- exponent))))) - ;;adjust the error bounds m+ and m- for unequal gaps - (when (= fraction (ash 1 precision)) - (setq m+ (ash m+ 1)) - (setq r (ash r 1)) - (setq s (ash s 1))) - ;;scale value by requested amount, and update error bounds - (when scale - (if (minusp scale) - (let ((scale-factor (expt 10 (- scale)))) - (setq s (* s scale-factor))) - (let ((scale-factor (expt 10 scale))) - (setq r (* r scale-factor)) - (setq m+ (* m+ scale-factor)) - (setq m- (* m- scale-factor))))) - ;;scale r and s and compute initial k, the base 10 logarithm of r - (do () - ((>= r (ceiling s 10))) - (decf k) - (setq r (* r 10)) - (setq m- (* m- 10)) - (setq m+ (* m+ 10))) - (do ()(nil) - (do () - ((< (+ (ash r 1) m+) (ash s 1))) - (setq s (* s 10)) - (incf k)) - ;;determine number of fraction digits to generate - (cond (fdigits - ;;use specified number of fraction digits - (setq cutoff (- fdigits)) - ;;don't allow less than fmin fraction digits - (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))) - (width - ;;use as many fraction digits as width will permit - ;;but force at least fmin digits even if width will be exceeded - (if (< k 0) - (setq cutoff (- 1 width)) - (setq cutoff (1+ (- k width)))) - (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))) - ;;If we decided to cut off digit generation before precision has - ;;been exhausted, rounding the last digit may cause a carry propagation. - ;;We can prevent this, preserving left-to-right digit generation, with - ;;a few magical adjustments to m- and m+. Of course, correct rounding - ;;is also preserved. - (when (or fdigits width) - (let ((a (- cutoff k)) - (y s)) - (if (>= a 0) - (dotimes (i a) (setq y (* y 10))) - (dotimes (i (- a)) (setq y (ceiling y 10)))) - (setq m- (max y m-)) - (setq m+ (max y m+)) - (when (= m+ y) (setq roundup t)))) - (when (< (+ (ash r 1) m+) (ash s 1)) (return))) - ;;zero-fill before fraction if no integer part - (when (< k 0) - (setq decpnt digits) - (vector-push-extend #\. *digit-string*) - (dotimes (i (- k)) - (incf digits) (vector-push-extend #\0 *digit-string*))) - ;;generate the significant digits - (do ()(nil) - (decf k) - (when (= k -1) - (vector-push-extend #\. *digit-string*) - (setq decpnt digits)) - (multiple-value-setq (u r) (truncate (* r 10) s)) - (setq m- (* m- 10)) - (setq m+ (* m+ 10)) - (setq low (< (ash r 1) m-)) - (if roundup - (setq high (>= (ash r 1) (- (ash s 1) m+))) - (setq high (> (ash r 1) (- (ash s 1) m+)))) - ;;stop when either precision is exhausted or we have printed as many - ;;fraction digits as permitted - (when (or low high (and cutoff (<= k cutoff))) (return)) - (vector-push-extend (char *digits* u) *digit-string*) - (incf digits)) - ;;if cutoff occured before first digit, then no digits generated at all - (when (or (not cutoff) (>= k cutoff)) - ;;last digit may need rounding - (vector-push-extend (char *digits* - (cond ((and low (not high)) u) - ((and high (not low)) (1+ u)) - (t (if (<= (ash r 1) s) u (1+ u))))) - *digit-string*) - (incf digits)) - ;;zero-fill after integer part if no fraction - (when (>= k 0) - (dotimes (i k) (incf digits) (vector-push-extend #\0 *digit-string*)) - (vector-push-extend #\. *digit-string*) - (setq decpnt digits)) - ;;add trailing zeroes to pad fraction if fdigits specified - (when fdigits - (dotimes (i (- fdigits (- digits decpnt))) - (incf digits) - (vector-push-extend #\0 *digit-string*))) - ;;all done - (values *digit-string* (1+ digits) (= decpnt 0) (= decpnt digits) decpnt))) - - -(defconstant short-log10-of-2 0.30103s0) - -;;; Given a non-negative floating point number, SCALE-EXPONENT returns a -;;; new floating point number Z in the range (0.1, 1.0] and and exponent -;;; E such that Z * 10^E is (approximately) equal to the original number. -;;; There may be some loss of precision due the floating point representation. - - -;;; -(defun scale-exponent (x) - (if (typep x 'short-float) - (scale-expt-aux x 0.0s0 1.0s0 1.0s1 1.0s-1 short-log10-of-2) - (scale-expt-aux x 0.0l0 1.0l0 %long-float-ten - %long-float-one-tenth long-log10-of-2))) - - -(defun scale-expt-aux (x zero one ten one-tenth log10-of-2) - (multiple-value-bind (sig exponent) - (decode-float x) - (declare (ignore sig)) - (if (= x zero) - (values zero 1) - (let* ((ex (round (* exponent log10-of-2))) - (x (if (minusp ex) ;For the end ranges. - (* x ten (expt ten (- -1 ex))) - (/ x ten (expt ten (1- ex)))))) - (do ((d ten (* d ten)) - (y x (/ x d)) - (ex ex (1+ ex))) - ((< y one) - (do ((m ten (* m ten)) - (z y (* z m)) - (ex ex (1- ex))) - ((>= z one-tenth) (values z ex))))))))) - - -;;;; Entry point for the float printer. - -;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC, -;;; etc. The argument is printed free-format, in either exponential or -;;; non-exponential notation, depending on its magnitude. -;;; -;;; NOTE: When a number is to be printed in exponential format, it is scaled -;;; in floating point. Since precision may be lost in this process, the -;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost. The -;;; difficulty is that FLONUM-TO-STRING performs extensive computations with -;;; integers of similar magnitude to that of the number being printed. For -;;; large exponents, the bignums really get out of hand. When we switch to -;;; IEEE format for long floats, this will significantly restrict the magnitude -;;; of the largest allowable float. This combined with microcoded bignum -;;; arithmetic might make it attractive to handle exponential notation with -;;; the same accuracy as non-exponential notation, using the method described -;;; in the Steele and White paper. - -(defun output-float (x stream) - (if (typep x 'short-float) - (output-float-aux x stream 1.0s-3 1.0s7) - (output-float-aux x stream %long-float1l-3 %long-float1l7))) - - -(defun output-float-aux (x stream e-min e-max) - (cond ((zerop x) - (write-string "0.0" stream) - (if (and (not (typep x *read-default-float-format*)) - (not (and (eq *read-default-float-format* 'single-float) - (typep x 'short-float)))) - (write-string (if (typep x 'short-float) "s0" "L0") stream))) - (t (when (minusp x) - (write-char #\- stream) - (setq x (- x))) - (if (and (>= x e-min) (< x e-max)) - ;;free format - (multiple-value-bind (str len lpoint tpoint) - (flonum-to-string x) - (declare (ignore len)) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - (if (and (not (typep x *read-default-float-format*)) - (not (and (eq *read-default-float-format* - 'single-float) - (typep x 'short-float)))) - (write-string (if (typep x 'short-float) "s0" "L0") - stream))) - ;;exponential format - (multiple-value-bind (f ex) - (scale-exponent x) - (multiple-value-bind (str len lpoint tpoint) - (flonum-to-string f nil nil 1) - (declare (ignore len)) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - (write-char (if (typep x *read-default-float-format*) - #\E - (if (typep x 'short-float) #\S #\L)) - stream) - ;;must subtract 1 from exponent here, due to - ;;the scale factor of 1 in call to FLONUM-TO-STRING - (unless (minusp (1- ex)) (write-char #\+ stream)) - (output-integer (1- ex) stream))))))) - - -;;;; Output Character - -;;; FUNNY-CHARACTER-CHAR-P returns a predicate which determines whether a -;;; character must be slashified when being output. -;;; -(defmacro funny-character-char-p (char) - `(and (not (zerop (char-bits ,char))) - (not (zerop (logand (aref character-attributes (char-code ,char)) - funny-attribute))))) - -;;; OUTPUT-CHARACTER -- Internal -;;; -;;; If *print-escape* is false, just do a WRITE-CHAR, otherwise output -;;; any bits and then the character or name, escaping if necessary. In -;;; either case, we blast the bits or font before writing the character -;;; itself to the stream. -;;; -(defun output-character (char stream) - (let ((base (make-char char))) - (if *print-escape* - (let ((name (char-name base))) - (write-string "#\\" stream) - (macrolet ((frob (key string) - `(when (char-bit char ,key) - (write-string ,string stream)))) - (frob :control "CONTROL-") - (frob :meta "META-") - (frob :super "SUPER-") - (frob :hyper "HYPER-")) - (cond (name (write-string name stream)) - (t - (when (funny-character-char-p char) - (write-char #\\ stream)) - (write-char base stream)))) - (write-char base stream)))) - - - -;;;; Random and Miscellaneous Print Subfunctions - - -;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed -;;; representation of function objects. It is called from OUTPUT-RANDOM -;;; below. - -(defun output-function-object (subr stream) - (let ((name (%primitive header-ref subr %function-name-slot))) - (case (%primitive get-vector-subtype subr) - (#.%function-entry-subtype - (if (stringp name) - (format stream "Internal Function ~S" name) - (format stream "Function ~S" name))) - (#.%function-closure-subtype - (if (eval:interpreted-function-p subr) - (multiple-value-bind - (def ignore name) - (eval:interpreted-function-lambda-expression subr) - (declare (ignore ignore)) - (let ((*print-level* 3)) - (format stream "Interpreted Function ~S" (or name def)))) - (format stream "Closure ~S" - (%primitive header-ref name %function-name-slot)))) - (#.%function-closure-entry-subtype - (format stream "Closure Entry ~S" name)) - (#.%function-constants-subtype - (format stream "Function Constants ~S" name)) - (#.%function-value-cell-subtype - (assert (= %function-value-cell-value-slot %function-name-slot)) - (format stream "Indirect Value Cell ~S" name)) - #| - (#.%function-funcallable-instance-subtype - (format stream "Funcallable Instance ~S" name)) - |# - (t (error "Unknown function subtype."))))) - - -;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below. -;;; It outputs the numerical value of the low 28 bits of -;;; RANDOM-OBJECT, enclosed in braces, followed by the closing -;;; angle-bracket (">") random objects have at the end. This -;;; is used to distringuish random objects of the same type. - -(defun finish-random (random-object stream) - (write-string " {" stream) - (let ((*print-base* 16)) - (output-integer (%primitive make-fixnum random-object) stream)) - (write-string "}>" stream)) - -;;; Functions Objects and other implmentation specific objects -;;; are output here. - -(defun output-random (object stream) - (write-string "#<" stream) - (if (compiled-function-p object) - (output-function-object object stream) - (let ((type (%primitive get-type object))) - (write-string "Pointer into Hell, level " stream) - (sub-output-integer type stream))) - (finish-random object stream)) diff --git a/code/purify.lisp b/code/purify.lisp deleted file mode 100644 index c41786d68c7c357b7527a3b70044455bb9a1c51f..0000000000000000000000000000000000000000 --- a/code/purify.lisp +++ /dev/null @@ -1,536 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Storage purifier for Spice Lisp. -;;; Written by Rob MacLachlan and Skef Wholey. -;;; -;;; The function Purify, defined herein, puts as much of the Lisp system as -;;; possible into Read-Only and Static spaces so that subsequent garbage -;;; collections are quicker. This is done by frobbing the free-pointers for -;;; spaces so that new objects are put in static or read-only space as -;;; appropiate, then doing a GC. -;;; -;;; We also transport all of the dynamic symbols in Lisp code so we -;;; can do clever things that improve locality in the resulting Lisp. -;;; Some constant conses and g-vectors are also transported in macrocode -;;; so that we can put them in read-only space. -;;; -(in-package 'lisp) - -(defun purify (&key root-structures) - (declare (special lisp-environment-list)) - (setq lisp-environment-list NIL) - (write-string "[Doing purification: ") - (force-output) - (setq *already-maybe-gcing* t) - ;; - ;; Find GC stack fixups before we go around trashing vector headers. - (let ((fixups (gc-grovel-stack))) - ;; - ;; Move symbols to static space, constants to read-only space. - (localify root-structures) - ;; - ;; Move everything else to either static or read-only space, depending - ;; on type. - (%primitive clear-registers) - (%primitive purify) - (gc-fixup-stack fixups)) - - (setq *already-maybe-gcing* nil) - (setq *need-to-collect-garbage* nil) - (write-line "done]") - nil) - -;;;; Localify - -(defconstant marked-bit #b001) -(defconstant worthwhile-bit #b010) -(defconstant referenced-bit #b100) - -(eval-when (compile eval) -;;; Peek, Poke -- Internal -;;; -;;; Read or write the cell at a location without doing any type-checking or -;;; anything silly like that. -;;; -(defmacro peek (x) - `(%primitive read-control-stack ,x)) -(defmacro poke (x val) - `(%primitive write-control-stack ,x ,val)) - -;;; Symbol-Bits -- Internal -;;; -;;; There is a whole 32 bits at the end of every symbol, which until -;;; now, was unused. We will use the low 16 to annotate some stuff about -;;; how symbols are referenced. -;;; -(defmacro symbol-bits (sym) - `(get ,sym 'purify-symbol-bits 0)) - -(defsetf symbol-bits (sym) (val) - `(let ((space (%primitive get-allocation-space))) - (%primitive set-allocation-space %dynamic-space) - (prog1 (setf (get ,sym 'purify-symbol-bits) ,val) - (%primitive set-allocation-space space)))) - -;;; Do-Allocated-Symbols -- Internal -;;; -;;; Iterate over all the symbols allocated in some space. -;;; -(defmacro do-allocated-symbols ((symbol space) &body forms) - `(let* ((old-alloc-space (%primitive get-allocation-space))) - (%primitive set-allocation-space %dynamic-space) - (let* ((index (+ (ash %symbol-type %alloc-ref-type-shift) - (ash ,space %alloc-ref-space-shift))) - (alloc-table (int-sap %fixnum-alloctable-address)) - (end (+ (logior (%primitive 16bit-system-ref alloc-table (1+ index)) - (ash (logand %type-space-mask - (%primitive 16bit-system-ref alloc-table index)) - 16)) - (ash ,space %space-shift)))) - (declare (fixnum end)) - (do ((base (ash ,space %space-shift) (+ base %symbol-length))) - ((= base end)) - (declare (fixnum base)) - (let ((,symbol (%primitive make-immediate-type base %symbol-type))) - (%primitive set-allocation-space old-alloc-space) - ,@forms - (%primitive set-allocation-space %dynamic-space)))) - (%primitive set-allocation-space old-alloc-space))) - -;;; Inlinep -- Internal -;;; -;;; Return true if symbol appears to be the name of a function likely -;;; to be coded inline. -;;; -(defmacro inlinep (sym) - #|Accesses global vars, so can't work.... - `(or (info function source-transform ,sym) - (let ((info (info function info ,sym))) - (and info - (or (c::function-info-templates info) - (c::function-info-ir2-convert info))))) - |# - nil) - - -;;; Next-Symbol, Next-Cons -- Internal -;;; -;;; Return the object allocated after the supplied one. -;;; -(defmacro next-symbol (sym) - `(%primitive make-immediate-type (+ (%primitive make-fixnum ,sym) %symbol-length) - %symbol-type)) -(defmacro next-cons (cons) - `(%primitive make-immediate-type (+ (%primitive make-fixnum ,cons) %cons-length) - %list-type)) - -;;; Purep -- Internal -;;; -;;; True if Obj is either not dynamic or has already been transported. -;;; -(defmacro purep (obj) - `(or (>= (%primitive get-space ,obj) %static-space) - (let ((type (%primitive get-type ,obj))) - (declare (fixnum type)) - (or (< type %first-pointer-type) - (> type %last-pointer-type) - (= (%primitive get-type (peek ,obj)) %gc-forward-type))))) - -;;; Free-Pointer-Location -- Internal -;;; -;;; Return the SAP which points to the location of the free-pointer -;;; for the specifed type and space in the alloc table. -;;; -(defmacro free-pointer-location (type space) - `(+ %fixnum-alloctable-address - (%primitive lsh ,type (1+ %alloc-ref-type-shift)) - (%primitive lsh ,space (1+ %alloc-ref-space-shift)))) - -;;; Transport-Symbol -- Internal -;;; -;;; If Sym is impure, copy it into static space and put a GC forward in the -;;; old symbol. Return True only if we actually did something. -;;; -(defmacro transport-symbol (sym) - `(unless (purep ,sym) - (let ((new-sym (%primitive alloc-symbol (symbol-name ,sym)))) - (when (boundp ,sym) - (setf (symbol-value new-sym) (symbol-value ,sym))) - (when (fboundp ,sym) - (setf (symbol-function new-sym) (symbol-function ,sym))) - (setf (symbol-plist new-sym) (symbol-plist ,sym)) - (%primitive set-package new-sym (symbol-package ,sym)) - (poke ,sym (%primitive make-immediate-type new-sym %gc-forward-type)) - t))) - -;;; Copy-G-Vector -- Internal -;;; -;;; Copy a G-Vector into the current allocation space, and forward -;;; the old object. Return the new object. If an EQ hashtable, -;;; change the subtype, otherwise preserve it. -;;; -(defmacro copy-g-vector (object) - `(let* ((len (length ,object)) - (new (%primitive alloc-g-vector len nil)) - (st (%primitive get-vector-subtype ,object))) - (dotimes (i len) - (setf (svref new i) (svref ,object i))) - (%primitive set-vector-subtype new - (case st - ((2 3) 4) - (t st))) - (poke ,object (%primitive make-immediate-type new %gc-forward-type)) - new)) - - -;;; Scavenge-Symbols -- Internal -;;; -;;; Scan through static symbol space doing a Transport-Function on -;;; the definition of every Fbound symbol between the free pointer -;;; and our clean pointer. The free pointer can move during the process -;;; due to symbols being transported. -;;; -(defmacro scavenge-symbols () - `(do ((free-ptr (peek free-ptr-loc) (peek free-ptr-loc))) - ((eq clean-ptr free-ptr)) - (when (fboundp clean-ptr) - (transport-function (symbol-function clean-ptr))) - (setq clean-ptr (next-symbol clean-ptr)))) -); eval-when (compile eval) - -;;; Mark-Function -- Internal -;;; -;;; Set the referenced bit in any symbol constants, and call -;;; Mark-If-Worthwhile on any which are not marked. -;;; -(defun mark-function (fun) - (let ((len (%primitive header-length fun))) - (do ((i %function-constants-constants-offset (1+ i))) - ((= i len)) - (let ((el (%primitive header-ref fun i))) - (when (symbolp el) - (let ((bits (symbol-bits el))) - (setf (symbol-bits el) (logior referenced-bit bits)) - (when (zerop (logand marked-bit bits)) - (mark-if-worthwhile el)))))))) - - -;;; Mark-If-Worthwhile -- Internal -;;; -;;; Mark the symbol if it is not already marked. If it is appears to -;;; be a symbol likely to be used at runtime, we set the worthwhile -;;; bit as well. -;;; -(defun mark-if-worthwhile (sym) - (when (zerop (logand (symbol-bits sym) marked-bit)) - ;; - ;; Mark it so we know we have been here... - (setf (symbol-bits sym) (logior marked-bit (symbol-bits sym))) - ;; - ;; If fbound and not an open-coded function, walk the function. - (when (and (fboundp sym) (not (inlinep sym))) - (setf (symbol-bits sym) - (logior worthwhile-bit (symbol-bits sym))) - (mark-function (symbol-function sym))) - ;; - ;; If bound and not a inline constant, or neither bound nor fbound, - ;; but has a plist, mark as worthwhile. - (when (if (boundp sym) - (not (and (constantp sym) - (let ((val (symbol-value sym))) - (or (characterp val) (numberp val) (eq sym val))))) - (and (not (fboundp sym)) - (not (null (cddr (symbol-plist sym)))))) - (setf (symbol-bits sym) - (logior worthwhile-bit (symbol-bits sym)))))) - - -;;; Transport-And-Scavenge -- Internal -;;; -;;; Transport a symbol and then scavenge to completion. -;;; -(defun transport-and-scavenge (symbol) - (let* ((free-ptr-loc (free-pointer-location %symbol-type %static-space)) - (clean-ptr (peek free-ptr-loc))) - (transport-symbol symbol) - (scavenge-symbols))) - - -;;; Transport-Function -- Internal -;;; -;;; Grovel the constants of a function object, transporting things -;;; that look useful. If a symbol has the worthwhile bit set, we move it. We -;;; transport conses and g-vectors here so that they can go into read-only -;;; space. If a constant is a compiled function, we recurse on it. -;;; -(defun transport-function (fun) - (unless (purep fun) - (let ((def (ecase (%primitive get-vector-subtype fun) - ((#.%function-entry-subtype #.%function-closure-entry-subtype) - (transport-function-object fun) - (%primitive header-ref fun %function-entry-constants-slot)) - (#.%function-closure-subtype - (let ((entry (%primitive header-ref fun - %function-name-slot))) - (unless (purep entry) - (transport-function-object entry) - (%primitive header-ref entry - %function-entry-constants-slot)))) - (#.%function-funcallable-instance-subtype - nil)))) - (when (and def (not (purep def))) - (let ((length (%primitive header-length def))) - (transport-function-object def) - (do ((i 0 ;%function-constants-constants-offset - (1+ i))) - ((= i length)) - (let ((const (%primitive header-ref def i))) - (typecase const - (symbol - (unless (zerop (logand worthwhile-bit (symbol-bits const))) - (transport-symbol const))) - (cons - (transport-cons const)) - (compiled-function - (transport-function const)) - (simple-vector - (transport-g-vector const t)))))))))) - - -;;; TRANSPORT-FUNCTION-OBJECT -- Internal -;;; -;;; Copy a function object into read-only space. This only moves the -;;; function (entry or constants) object itself, and lets GC scavenge. -;;; -(defun transport-function-object (fun) - (%primitive set-allocation-space %read-only-space) - (let* ((len (%primitive header-length fun)) - (res (%primitive alloc-function len))) - (%primitive set-vector-subtype res (%primitive get-vector-subtype fun)) - (dotimes (i len) - (%primitive header-set res i (%primitive header-ref fun i))) - (poke fun (%primitive make-immediate-type res %gc-forward-type))) - (%primitive set-allocation-space %static-space)) - - -;;; Transport-Cons -- Internal -;;; -;;; Transport a cons and any list structure attached to it into read-only -;;; space and scavenge to completion. -;;; -(defun transport-cons (cons) - (unless (purep cons) - (%primitive set-allocation-space %read-only-space) - (let* ((free-ptr-loc (free-pointer-location %list-type %read-only-space)) - (clean-ptr (peek free-ptr-loc))) - (loop - (loop - (let ((new (cons (car cons) (cdr cons)))) - (poke cons (%primitive make-immediate-type new %gc-forward-type)) - (setq cons (cdr cons)) - (when (or (atom cons) (purep cons)) (return nil)))) - (let ((free-ptr (peek free-ptr-loc))) - (loop - (when (eq clean-ptr free-ptr) - (%primitive set-allocation-space %static-space) - (return-from transport-cons nil)) - (setq cons (car clean-ptr)) - (setq clean-ptr (next-cons clean-ptr)) - (unless (or (atom cons) (purep cons)) (return nil)))))))) - -;;; Transport-G-Vector -- Internal -;;; -;;; Transport a G-Vector into static or read-only space. We only bother -;;; with the top level, and leave the rest to GC. -;;; -(defun transport-g-vector (vec &optional read-only) - (unless (purep vec) - (when read-only - (%primitive set-allocation-space %read-only-space)) - (copy-g-vector vec) - (when read-only - (%primitive set-allocation-space %static-space)))) - -;;; Transport-Root -- Internal -;;; -;;; Descend into lists, simple-vectors and compiled functions, transporting -;;; any useful symbols we run into, and scavenging to completion after each. We -;;; transport simple-vectors now so that we don't lose on circular or highly -;;; shared structures. -;;; -(defun transport-root (object) - (unless (purep object) - (typecase object - (symbol - (unless (zerop (logand worthwhile-bit (symbol-bits object))) - (transport-and-scavenge object))) - (simple-vector - (let ((new (copy-g-vector object))) - (dotimes (i (length new)) - (transport-root (svref new i))))) - (cons - (transport-root (car object)) - (transport-root (cdr object))) - (compiled-function - (transport-function object))))) - -;;; Localify -- Internal -;;; -;;; This function goes GC-Like stuff at lisp level to try to increase -;;; the locality in a purified core image. The basic idea is to do a -;;; breadth-first walk of the function objects, moving interesting symbols -;;; into static space. -;;; -(defun localify (root-structures) - (%primitive set-allocation-space %static-space) - ;; - ;; Mark interesting symbols, and those referenced by their definitions. - (do-allocated-symbols (sym %dynamic-space) - (setf (symbol-bits sym) 0)) - (do-allocated-symbols (sym %dynamic-space) - (mark-if-worthwhile sym)) - ;; - ;; Move interesting symbols referenced by the root structures. - (dolist (x root-structures) - (transport-root x)) - ;; - ;; Treat interesting unreferenced symbols as roots... - (do-allocated-symbols (sym %dynamic-space) - (unless (purep sym) - (let ((bits (symbol-bits sym))) - (when (and (zerop (logand referenced-bit bits)) - (not (zerop (logand worthwhile-bit bits)))) - (transport-and-scavenge sym))))) - ;; - ;; Treat referenced symbols as roots... - (do-allocated-symbols (sym %dynamic-space) - (unless (or (purep sym) - (zerop (logand referenced-bit (symbol-bits sym)))) - (transport-and-scavenge sym))) - ;; - ;; Do anything else that wants to be done... - (do-allocated-symbols (sym %dynamic-space) - ;; - ;; Move some types of variable value... - (when (boundp sym) - (let ((val (symbol-value sym))) - (cond ((purep val)) - #|Accesses global vars, so can't work... - ((eq (info variable kind sym) :constant) - (typecase val - (cons (transport-cons val)) - (simple-vector (transport-g-vector val t)))) - |# - ))) - ;; - ;; Move any interned symbol that's left... - (unless (or (purep sym) (not (symbol-package sym))) - (transport-and-scavenge sym))) - - ;; - ;; Reset the bits... - (remprop nil 'purify-symbol-bits) - - (do-allocated-symbols (sym %static-space) - (remprop sym 'purify-symbol-bits)) - - (do-allocated-symbols (sym %dynamic-space) - (remprop sym 'purify-symbol-bits)) - - (%primitive set-allocation-space %dynamic-space)) -); Compiler-Let - -;;;; Save-Stand-Alone-Lisp -;;; -;;; A stand-alone is a lisp that has had everything that doesn't pertain -;;; to a particular application GC'ed away. This can result in a drastic -;;; size reduction, but tends make the Lisp unusable for anything else and -;;; hard to debug in. We do this by blowing away all symbols not directly -;;; referenced and doing a GC. We also blow away random debug info. - - -;;; Save-Stand-Alone-Lisp -- Public -;;; -(defun save-stand-alone-lisp (file root-function) - "Write into File a core file which contains only objects referenced - by Root-Function or needed for the basic system. Root-Function - is called when the core file is resumed. Root-Function should be - a symbol rather than an actual function object." - (let ((all-packages (list-all-packages))) - (fresh-line) - (write-string "[Nuking useless stuff") - (force-output) - ;; - ;; Mark all external symbols so that we can find them later... - (dolist (p all-packages) - (do-external-symbols (s p) - (setf (symbol-bits s) 1))) - ;; - ;; Nuke all hashtables in packages... - (dolist (p all-packages) - (make-package-hashtable 10 (package-internal-symbols p)) - (make-package-hashtable 10 (package-external-symbols p))) - #| - ;; - ;; Nuke random garbage on all symbols... - (do-allocated-symbols (s %dynamic-space) - ;; - ;; Nuke arglists on functions... - (when (fboundp s) - (let ((fun (symbol-function s))) - (cond ((compiled-function-p fun) - (%primitive header-set fun %function-arg-names-slot ())) - ((and (consp fun) (compiled-function-p (cdr fun))) - (%primitive header-set (cdr fun) %function-arg-names-slot - ())))) - - ;; - ;; Nuke unnecessary properties... - (when (symbol-plist s) - (dolist (p garbage-properties) - (when (get s p) - (remprop s p)))))) - |# - - (write-string "] -[GC'ing it away") - (force-output) - ;; - ;; GC it away.... - (gc nil) - (write-string "]") - ;; - ;; Rebuild packages... - (write-string "] -[Rebuilding packages") - (force-output) - (do-allocated-symbols (s %dynamic-space) - (let ((p (symbol-package s))) - (cond ((null p)) - ((zerop (symbol-bits s)) - (add-symbol (package-internal-symbols p) s)) - (t - (add-symbol (package-external-symbols p) s) - (setf (symbol-bits s) 0))) - (remprop s 'purify-symbol-bits))) - (do-allocated-symbols (s %static-space) - (let ((p (symbol-package s))) - (cond ((null p)) - ((zerop (symbol-bits s)) - (add-symbol (package-internal-symbols p) s)) - (t - (add-symbol (package-external-symbols p) s) - (setf (symbol-bits s) 0))) - (remprop s 'purify-symbol-bits))) - (write-line "]") - (purify :root-structures (list root-function)) - (if (save file) - (quit) - (funcall root-function)))) diff --git a/code/query.lisp b/code/query.lisp deleted file mode 100644 index c5ca1b451f28a507f55a0bd2662f3f1edfd10c29..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 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). -;;; ********************************************************************** -;;; -;;; 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. -;;; -;;; This prints the message, if any, and reads characters from *QUERY-IO* until -;;; any of "y", "Y", or <newline> are seen as an affirmative, or either "n" or -;;; "N" is seen as a negative answer. It ignores preceding whitespace and asks -;;; again if other characters are seen. -;;; -(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 any of y, Y, or <newline> are seen as an - affirmative, or either n or N is seen as a negative answer. - It ignores preceding whitespace and asks again if other characters - are seen." - (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 "") :ignore-and-warn (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 9bfbe8841fa9d409e163e665c3ba1e62125bdc3a..0000000000000000000000000000000000000000 --- a/code/rand.lisp +++ /dev/null @@ -1,128 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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). -;;; ********************************************************************** -;;; -;;; 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 134217726) -(defconstant random-max 54) -(defvar rand-seed 0) -(defvar *random-state*) - -(defstruct (random-state (:constructor make-random-object)) - (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)))) - -;;; 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 random-init () - (setq *random-state* - (make-random-object :seed - (make-array (1+ random-max) :initial-contents - '(45117816 133464727 86324180 99419799 68851957 87250180 - 52971860 84081967 30854110 121122797 70449044 18801152 - 45149898 15881380 27398356 117706009 49915564 80620628 - 120974070 98193932 43883764 53717012 100954825 82579490 - 17280729 118523949 42282975 127220348 6288263 56575578 - 2474156 47934425 561006 21989698 74046730 105055318 - 113363907 48749716 78183593 109613585 37323232 65101428 - 46453209 76906562 5371267 86544820 33922642 60765033 - 41889257 77176406 38775255 78514879 72553872 66916641 - 100613180))))) - -(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 (typecase arg - (short-float %short-float-mantissa-length) - (single-float %single-float-mantissa-length) - (double-float %double-float-mantissa-length) - (long-float %long-float-mantissa-length)))) - (* 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 717b6c4f8ed637e42de5aa8318b1da342be0b6e7..0000000000000000000000000000000000000000 --- a/code/reader.lisp +++ /dev/null @@ -1,1304 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Spice Lisp Reader -;;; Written by David Dill -;;; Package system interface by Lee Schumacher. -;;; Runs in the standard Spice Lisp environment. -;;; -(in-package 'lisp) -(export '(readtable 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*)) - -;;;Random global variables - -(defvar *read-default-float-format* 'single-float "Float format for 1.0E1") - -(defvar *readtable* () "Variable bound to current readtable.") - - - -;;;; Readtable implementation. - -;;; The readtable is a structure with three components: the -;;; CHARACTER-ATTRIBUTE-TABLE is a vector of 128 integers for describing the -;;; character type. Conceptually, there are 4 distinct "primary" character -;;; attributes (WHITESPACE, TERMINATING-MACRO, ESCAPE, and CONSTITUENT -- -;;; non-terminating macros have the attribute CONSTITUENT, and the symbol -;;; reader is implemented as a non-terminating macro), and a number of -;;; "secondary" attributes that are used by the function READ-QUALIFIED-TOKEN, -;;; which apply only when the primary attribute is CONSTITUENT. In order to -;;; make the READ-QUALIFIED-TOKEN fast, all this information is stored in the -;;; character attribute table by having different varieties of constituents. -;;; In order to conform with the white pages, the primary attributes should be -;;; moved by SET-SYNTAX-FROM-CHARACTER and SET-MACRO-CHARACTER, while the -;;; secondary attributes are constant properties of the characters (as long as -;;; they are constituents). - - -;;; The CHARACTER-MACRO-TABLE is a vector of 128 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. Finally, there is a -;;; DISPATCH-TABLES entry, which is an alist from dispatch characters to -;;; vectors of 128 functions, for use in defining dispatching macros (like -;;; #-macro). - -(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)) - "Readtable is a data structure that maps characters into syntax - types for the Common Lisp expression reader." - (character-attribute-table (make-character-attribute-table) :type simple-vector) - (character-macro-table (make-character-macro-table) :type simple-vector) - (dispatch-tables () :type list)) - - - -;;;; 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) - (defconstant sharp-sign 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-int ,char))) - -(defun set-cat-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (the simple-vector (character-attribute-table rt)) - (char-int char)) - newvalue)) - -(defmacro get-cmt-entry (char rt) - `(elt (the simple-vector (character-macro-table ,rt)) - (char-int ,char))) - -(defun set-cmt-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (the simple-vector (character-macro-table rt)) - (char-int char)) - newvalue)) - -(defun make-character-attribute-table () - (make-array 256 :element-type t :initial-element #.constituent)) - -(defun make-character-macro-table () - (make-array 256 :element-type t - :initial-element #'undefined-macro-char)) - -(defun undefined-macro-char (ignore char) - (declare (ignore ignore)) - (error "Undefined read-macro character ~S" char)) - - -;;; The character attribute table is a 128-long 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. - -(defvar secondary-attribute-table ()) - -(defun set-secondary-attribute (char attribute) - (setf (elt (the simple-vector secondary-attribute-table) (char-int char)) - attribute)) - - -(defun init-secondary-attribute-table () - (setq secondary-attribute-table - (make-array 128 :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-int #\0) (1+ i))) - ((> i (char-int #\9))) - (set-secondary-attribute (int-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-int ,char))) - - - -;;;; Readtable operations. - -(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) - "A copy is made of from-readtable and place into to-readtable." - (if (null from-readtable) (setq from-readtable std-lisp-readtable)) - (if (null to-readtable) (setq 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." - (if (null from-readtable) (setq 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) - NIL)) - -(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 *readtable*)) - "Returns the function associated with the specified char - which is a macro character. The optional readtable argument - defaults to the current readtable." - (when (null rt) (setf 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-int 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 (int-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 *real-eof-errorp* () - "Value checked by reader if recursivep is true.") -(defvar *real-eof-value* () - "Eof-value used for eof-value if recursivep is true.") - -(defvar right-paren-whitespace t - "Flag that READ uses to tell when it's ok to treat right parens as - whitespace.") - -;; Alist for sharp-equal. Used to keep track of objects with labels assigned -;; that have been completly read. -(defvar sharp-equal-alist ()) - -;; Alist for sharp-sharp. Assoc's a number with a symbol produced by gensym. -;; Used by sharp-sharp as an unforgeable label, instead of the number. -(defvar sharp-sharp-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 ()) - (recursivep ())) - "Reads from stream and returns the object read, preserving the whitespace - that followed the object." - (let ((*real-eof-value* *real-eof-value*) - (*real-eof-errorp* *real-eof-errorp*)) - (if recursivep - (setq eof-errorp *real-eof-errorp* - eof-value *real-eof-value*) - (setq *real-eof-value* eof-value - *real-eof-errorp* eof-errorp - ;; The scope of these two lists is the top level read, so they - ;; have to be reset here. - sharp-equal-alist nil - sharp-sharp-alist nil)) - (progn - ;;loop for repeating when a macro returns nothing. - (do ((char (read-char stream nil eof-object) - (read-char stream nil eof-object))) - (()) - (cond ((eofp char) - (if eof-errorp - (error "Unexpected end-of-file encountered.") - (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)))))))))) - -(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))) - -(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) - (error "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 #\) ) - (error "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) - (error "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 (ig1 ig2) - (declare (ignore ig1 ig2)) - (if right-paren-whitespace - (values) - (error "Unmatched right parenthesis."))) - -(defun internal-read-extended-token (stream firstchar - &aux (escape-appearedp nil)) - ;;read the string up to the next delimiter. Leaves resulting token - ;;in read-buffer, returns a flag that is true if an escape (\\) - ;;appeared, meaning that it has to be a symbol. - ;;needs to have package hacks added. - (reset-read-buffer) - (do ((char firstchar (read-char stream nil eof-object))) - ;;for now, treat #\: as a constituent: - ;; does this cond need same fix as the top-level read did ?? - ((cond ((eofp char) t) - ((token-delimiterp char) - (unread-char char stream) - t) - (t nil)) - escape-appearedp) - (cond ((escapep char) - ;;it can't be a number, even if it's 1\23. - (setq escape-appearedp t) - ;;read next char here, so it won't be upper-casified. - (let ((nextchar (read-char stream nil eof-object))) - (if (eofp nextchar) - (error "End-of-file after escape character.") - (ouch-read-buffer nextchar)))) - (t (ouch-read-buffer (char-upcase char)))))) - - - -;;;; Character classes. - -;;; return the character class for a char -;;; -(defmacro char-class (char attable) - `(let ((att (svref ,attable (char-int ,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-int ,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-int ,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. - -#| -(defmacro backup-char (char stream) - `(if ,char (unread-char ,char ,stream))) -|# - -(defvar *read-suppress* nil - "Suppresses most interpreting of the reader when T") - -(defvar *read-base* 10 - "The radix that Lisp reads numbers in.") - -(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). - (if *read-suppress* - (internal-read-extended-token stream firstchar) - (let ((attribute-table (character-attribute-table *readtable*)) - (package *package*) - (colons 0) - (possibly-rational t) - (possibly-float t)) - (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-upcase char)) - (setq char (read-char stream nil nil)) - (unless char (return (make-integer))) - (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))) - (#.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)))) - (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)))) - (#.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 (error "Dot context error.")) - (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-dot (go DOTS)) - (#.delimiter (error "Dot context error.")) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - EXPONENT - (ouch-read-buffer (char-upcase 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-upcase 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 (error "Too many dots.")) - (case (char-class char attribute-table) - (#.constituent-dot (go DOTS)) - (#.delimiter (unread-char char stream) (error "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-upcase 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))) - (if nextchar - (ouch-read-buffer nextchar) - (error "End-of-file after escape character."))) - (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))) - (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 - (cond ((zerop colons) - (setq colons 1) - (setq package (find-package (read-buffer-to-string))) - (unless package (error "Package ~S not found." - (read-buffer-to-string)))) - (t (error "Too many colons in ~S" (read-buffer-to-string)))) - (reset-read-buffer) - (setq char (read-char stream nil nil)) - (unless char (error "End of file encountered after reading a colon.")) - (case (char-class char attribute-table) - (#.delimiter (unread-char char stream) - (error "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 (error "End of file encountered after reading a colon.")) - (case (char-class char attribute-table) - (#.delimiter (unread-char char stream) - (error "Illegal terminating character after a colon, ~S" - char)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (error "To many colons after ~S:" - (package-name package))) - (t (go SYMBOL))) - RETURN-SYMBOL - (if (or (zerop colons) (= colons 2) (eq package *keyword-package*)) - (return (intern* read-buffer ouch-ptr package)) - (multiple-value-bind (symbol test) - (find-symbol* read-buffer ouch-ptr package) - (cond ((eq test :external) (return symbol)) - ((null test) - (error "Symbol ~S not found in the ~A package." - (read-buffer-to-string) (package-name package))) - (t (cerror "use symbol anyway." - "The symbol ~S is not external in the ~A package." - (read-buffer-to-string) (package-name package)) - (return symbol))))))))) - - -(defun read-extended-token (stream &optional (*readtable* *readtable*)) - ;;for semi-external use: returns 2 values: the string for the token, - ;;and a flag for whether there was an escape char. - (let ((firstch (read-char stream nil nil t))) - (if firstch - (let ((escape-appearedp (internal-read-extended-token stream firstch))) - (values (read-buffer-to-string) escape-appearedp)) - (values "" 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 () - "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* - (error "~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 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) - (let ((fgcd (gcd number divisor))) - (when (/= fgcd 1) - (setq number (truncate number fgcd)) - (setq divisor (truncate divisor fgcd)))) - (when (= divisor 1) - (return-from make-float-aux (coerce number float-format))) - (let ((float-digits (case float-format - ((short-float single-float) 37) - ((double-float long-float) 307) - (t 307))) - (digits (round (integer-length number) (log 10 2)))) - (cond ((<= digits float-digits) - (/ (coerce number float-format) - (coerce divisor float-format))) - (T (let ((adj-amount (expt 10 (- digits float-digits)))) - (/ (coerce (round number adj-amount) float-format) - (coerce (round divisor adj-amount) 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 128 :initial-element #'dispatch-char-error)) - -(defun dispatch-char-error (ig1 sub-char ig2) - (declare (ignore ig1 ig2)) - (error "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. - (let ((dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (setf (elt (the simple-vector (cdr dpair)) - (char-int sub-char)) - function) - (error "~S is not a dispatch char." disp-char)))) - -(defun get-dispatch-macro-character (disp-char sub-char - &optional (rt *readtable*)) - "Returns the macro character function for sub-char under disp-char - or nil if there is no associated function." - (when (null rt) (setf rt *readtable*)) - (let ((dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (elt (the simple-vector (cdr dpair)) - (char-int 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) - (error "End-of-file inside dispatch character.") - (setq sub-char 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-int sub-char)) - stream sub-char (if numargp numarg nil)) - (error "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 (length string)) - 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)) - (if (null end) (setq 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) (coerce string 'simple-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 (length string)) - (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." - (declare (fixnum end)) - (if (null end) (setq 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 fe1cb60608e2952381b3715c95a2bc3ca71cc01a..0000000000000000000000000000000000000000 --- a/code/remote.lisp +++ /dev/null @@ -1,363 +0,0 @@ -;;; -*- Log: code.log; Package: wire -*- -;;; -;;; ********************************************************************** -;;; 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 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)) - (mach: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)) - (format stream "#<Requst server 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/run-program.lisp b/code/run-program.lisp deleted file mode 100644 index 3668edab64b665bb3b5e58019c94112a4faee42e..0000000000000000000000000000000000000000 --- a/code/run-program.lisp +++ /dev/null @@ -1,651 +0,0 @@ -;;; -*- Package: Extensions; Log: code.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). -;;; ********************************************************************** -;;; -;;; RUN-PROGRAM and friends. Factilty 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. - -(ext:def-c-pointer *wait (unsigned-byte 32)) - -(ext:def-c-routine ("wait3" c-wait3) - (int) - (status *wait :out) - (options int) - (rusage 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 mach:sigstop) - (eql signal mach:sigtstp) - (eql signal mach:sigttin) - (eql signal mach: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. - ) - -(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 - (unless (or (eq (process-status proc) :running) - (and check-for-stopped - (eq (process-status proc) :stopped))) - (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) - (mach:with-trap-arg-block mach::int1 pgrp - (multiple-value-bind - (wonp error) - (mach:unix-ioctl (system:fd-stream-fd (ext:process-pty proc)) - mach:TIOCGPGRP - (lisp::alien-value-sap mach::int1)) - (unless wonp - (error "TIOCPGRP ioctl failed: ~S" - (mach:get-unix-error-msg error))) - (system:alien-access (mach::int1-int (system:alien-value pgrp)))))) - -;;; 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) - (mach:unix-killpg pid signal) - (mach:unix-kill pid signal)) - (cond ((not okay) - (values nil errno)) - ((and (eql pid (process-pid proc)) - (= (unix-signal-number signal) mach: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 should be the handler for sigchld signals that RUN-PROGRAM establishes. -;;; -;;; Since interrupts are so broken in the current RT system, we don't turn on -;;; sigchld signals for now. We call this by hand whenever we need to check -;;; the status of a process. -;;; -(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 (mach:unix-open master-name - mach:o_rdwr - #o666))) - (when master-fd - (let* ((slave-name (format nil "/dev/tty~C~X" char digit)) - (slave-fd (mach:unix-open slave-name - mach:o_rdwr - #o666))) - (when slave-fd - ; Maybe put a vhangup here? - (mach:unix-ioctl slave-fd - mach:TIOCGETP - (system:alien-sap mach:sgtty)) - (setf (system:alien-access (mach::sgtty-flags mach:sgtty)) - #o6300) ; XTABS|EVENP|ODDP - (mach:unix-ioctl slave-fd - mach:TIOCSETP - (system:alien-sap mach:sgtty)) - (mach:unix-ioctl master-fd - mach:TIOCGETP - (system:alien-sap mach:sgtty)) - (setf (system:alien-access (mach::sgtty-flags mach:sgtty)) - (logand (system:alien-access (mach::sgtty-flags mach:sgtty)) - (lognot 8))) ; ~ECHO - (mach:unix-ioctl master-fd - mach:TIOCSETP - (system:alien-sap mach:sgtty)) - (return-from find-a-pty - (values master-fd - slave-fd - slave-name)))) - (mach:unix-close master-fd))))) - (error "Could not find a pty.")) - -;;; OPEN-PTY -- internal -;;; -(defun open-pty (pty) - (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 (won new-fd) (mach:unix-dup master) - (unless won - (error "Could not MACH:UNIX-DUP ~D: ~A" - master (mach:get-unix-error-msg new-fd))) - (push new-fd *close-on-error*) - (copy-descriptor-to-stream new-fd pty))) - (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)) - (mach:unix-exit 2)))) - ;; Put us in our own pgrp. - (mach:unix-setpgrp 0 (mach:unix-getpid)) - ;; If we want a pty, set it up. - (when pty-name - (let ((old-tty (mach:unix-open "/dev/tty" mach:o_rdwr 0))) - (when old-tty - (mach:unix-ioctl old-tty mach:TIOCNOTTY 0) - (mach:unix-close old-tty))) - (let ((new-tty (mach:unix-open pty-name mach:o_rdwr 0))) - (when new-tty - (mach:unix-dup2 new-tty 0) - (mach:unix-dup2 new-tty 1) - (mach:unix-dup2 new-tty 2)))) - ;; Setup the three standard descriptors. - (when stdin - (mach:unix-dup2 stdin 0)) - (when stdout - (mach:unix-dup2 stdout 1)) - (when stderr - (mach:unix-dup2 stderr 2)) - ;; Close all other descriptors. - (do ((fd (1- (mach:unix-getdtablesize)) - (1- fd))) - ((= fd 3)) - (mach:unix-close fd)) - ;; Do the before-execve - (when before-execve - (funcall before-execve)) - ;; Exec the program - (mach:unix-execve pfile args env)) - ;; If exec returns, we lose. - (mach: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 spesified 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 spesified 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 - spesified 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 mach: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:"))))) - (multiple-value-bind - (stdin input-stream) - (get-descriptor-for input :direction :input - :if-does-not-exist if-input-does-not-exist) - (multiple-value-bind - (stdout output-stream) - (get-descriptor-for output :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 :direction :output - :if-exists if-error-exists)) - (multiple-value-bind (pty-name pty-stream) - (open-pty pty) - ;; 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) - (mach:unix-fork) - (cond ((zerop child-pid) - ;; We are the child. Note: setup-child NEVER returns - (setup-child pfile args env stdin stdout stderr - pty-name before-execve)) - ((null child-pid) - ;; This should only happen if the bozo has too - ;; many running procs. - (error "Could not fork child process: ~A" - (mach:get-unix-error-msg errno))) - (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)) - (push proc *active-processes*)))))))))) - (dolist (fd *close-in-parent*) - (mach:unix-close fd)) - (unless proc - (dolist (fd *close-on-error*) - (mach: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) - (let ((string (make-string 256)) - handler) - (setf handler - (system:add-fd-handler descriptor :input - #'(lambda (fd) - (declare (ignore fd)) - (loop - (multiple-value-bind - (result readable/errno) - (mach:unix-select (1+ descriptor) (ash 1 descriptor) - 0 0 0) - (cond ((null result) - (error "Could not select on sub-process: ~A" - (mach:get-unix-error-msg readable/errno))) - ((zerop result) - (return)))) - (multiple-value-bind - (count errno) - (mach:unix-read descriptor - string - (length string)) - (cond ((or (and (null count) - (eql errno mach:eio)) - (eql count 0)) - (system:remove-fd-handler handler) - (mach:unix-close descriptor) - (return)) - ((null count) - (system:remove-fd-handler handler) - (error "Could not read input from sub-process: ~A" - (mach:get-unix-error-msg errno))) - (t - (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 &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) - (mach:unix-open "/dev/null" - (case direction - (:input mach:o_rdonly) - (:output mach:o_wronly) - (t mach:o_rdwr)) - #o666) - (unless fd - (error "Could not open \"/dev/null\": ~A" - (mach:get-unix-error-msg errno))) - (push fd *close-in-parent*) - (values fd nil))) - ((eq object :stream) - (multiple-value-bind - (read-fd write-fd) - (mach:unix-pipe) - (unless read-fd - (error "Could not create pipe: ~A" - (mach: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 - (mach:unix-close read-fd) - (mach:unix-close write-fd) - (error "Direction must be either :INPUT or :OUTPUT, not ~S" - direction))))) - ((stringp object) - (with-open-stream (file (apply #'open object keys)) - (multiple-value-bind (won fd) - (mach:unix-dup (system:fd-stream-fd file)) - (cond (won - (push fd *close-in-parent*) - (values fd nil)) - (t - (error "Could not duplicate file descriptor: ~A" - (mach:get-unix-error-msg fd))))))) - ((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 (mach:unix-open name - (logior mach:o_rdwr - mach:o_creat - mach:o_excl) - #o666))) - (mach:unix-unlink name) - (when fd - (let ((newline (string #\Newline))) - (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (mach:unix-write fd line 0 (length line)) - (if no-cr - (return) - (mach:unix-write fd newline 0 1))))) - (mach:unix-lseek fd 0 mach:l_set) - (push fd *close-in-parent*) - (return (values fd nil)))))) - (:output - (multiple-value-bind (read-fd write-fd) - (mach:unix-pipe) - (unless read-fd - (error "Cound not create pipe: ~A" - (mach:get-unix-error-msg write-fd))) - (copy-descriptor-to-stream read-fd object) - (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/save.lisp b/code/save.lisp deleted file mode 100644 index bc6926cb2a008337c7fffe156022800931a7729e..0000000000000000000000000000000000000000 --- a/code/save.lisp +++ /dev/null @@ -1,114 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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). -;;; ********************************************************************** -;;; -;;; Spice Lisp routines to suspend a process and create a core file. -;;; -;;; Written David B. McDonald. -;;; -;;;********************************************************************** -;;; -;;; To see the format of Spice Lisp core files look at the document -;;; prva:<slisp.docs>core.mss. -(in-package "LISP") - -(in-package "EXTENSIONS") -(export '(*environment-list*)) -(defvar *environment-list* nil) -(in-package "LISP") - - -(proclaim '(special *task-self*)) - -(defconstant save-block-size (* 64 1024) - "Amount to write for each call to write. This is due to RFS limitations.") - -(defvar lisp-environment-list) -(defvar original-lisp-environment) - -;;;; Global state: - -(defun save (file) - "Save the current lisp core image in a core file. When it returns in - the current process, the number of bytes written is returned. - When the saved core image is resumed, Nil is returned." - (declare (optimize (speed 3) (safety 0))) - (format t "~&[Building saved core image: ") - (finish-output) - (let ((size-to-allocate (* (current-space-usage) 2))) - (declare (fixnum size-to-allocate)) - (let* ((addr (int-sap (gr-call* mach::vm_allocate *task-self* - 0 size-to-allocate t))) - (byte-size (%primitive save *current-alien-free-pointer* - NIL addr))) - (cond ((null byte-size) - (mach::vm_deallocate *task-self* addr size-to-allocate) - (error "Save failed.")) - ((eq byte-size T) - (dolist (f *before-save-initializations*) (funcall f)) - (dolist (f *after-save-initializations*) (funcall f)) - (reinit) - (setq original-lisp-environment lisp-environment-list) - (let ((result nil)) - (dolist (ele lisp-environment-list - (setf *environment-list* result)) - (let ((=pos (position #\= (the simple-string ele)))) - ;; - ;; This is dubious since all the strings have an =. - ;; What if one doesn't? What does that mean? - (when =pos - (push (cons (intern (string-upcase (subseq ele 0 =pos)) - *keyword-package*) - (subseq ele (1+ =pos))) - result))))) - NIL) - (T - (format t "~D bytes.~%" byte-size) - (format t "Writing to file: ~A~%" file) - (finish-output) - (multiple-value-bind (fd err) (mach:unix-creat file #o644) - (if (null fd) - (error "Failed to open file ~A, unix error: ~A" - file (mach:get-unix-error-msg err))) - - (do ((left byte-size (- left save-block-size)) - (index 0 (+ index save-block-size))) - ((< left save-block-size) - (when (> left 0) - (multiple-value-bind (res err) - (mach:unix-write fd addr index left) - (if (null res) - (error "Failed to write file ~A, unix error: ~A" - file (mach:get-unix-error-msg err)))))) - (declare (fixnum left index)) - (multiple-value-bind (res err) - (mach:unix-write fd addr index - save-block-size) - (if (null res) - (error "Failed to write file ~A, unix error: ~A" - file (mach:get-unix-error-msg err))))) - (multiple-value-bind (res err) (mach:unix-close fd) - (if (null res) - (error "Failed to close file ~A, unix error: ~A" - file (mach:get-unix-error-msg err))))) - (format t "done.]~%") - (mach::vm_deallocate *task-self* addr size-to-allocate) - (finish-output) - byte-size))))) - -(defun current-space-usage () - (declare (optimize (speed 3) (safety 0))) - (do ((sum 0) - (type 0 (1+ type))) - ((> type %last-pointer-type) sum) - (declare (fixnum type sum)) - (if (not (or (eq type %short-+-float-type) (eq type %short---float-type))) - (multiple-value-bind (dyn stat ro) (space-usage type) - (declare (fixnum dyn stat ro)) - (setq sum (+ sum dyn stat ro)))))) diff --git a/code/search-list.lisp b/code/search-list.lisp deleted file mode 100644 index ffa7c6244a28a82bc677d9df8c8961cffb9fe72f..0000000000000000000000000000000000000000 --- a/code/search-list.lisp +++ /dev/null @@ -1,154 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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). -;;; ********************************************************************** -;;; -;;; 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) - (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 10f16043e626c49efebcd264617a9bb8b04b00ef..0000000000000000000000000000000000000000 --- a/code/seq.lisp +++ /dev/null @@ -1,2267 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; 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 (type) - "Returns the broad class of which TYPE is a specific subclass." - `(if (atom ,type) ,type (car ,type))) - -) ; eval-when - - - -(defun make-sequence-of-type (type length) - "Returns a sequence of the given TYPE and LENGTH." - (declare (fixnum length)) - (case (type-specifier type) - (list (make-list length)) - ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) - ((string simple-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))) - ((bit-vector simple-bit-vector) - (make-array length :element-type '(mod 2))) - (t (error "~S is a bad type specifier for sequence functions." type)))) - -(defun elt (sequence index) - "Returns the element of SEQUENCE specified by INDEX." - (if (listp sequence) - (if (< index 0) - (error "~S: index too small." index) - (do ((count index (1- count))) - ((= count 0) (car sequence)) - (declare (fixnum count)) - (if (atom sequence) - (error "~S: index too large." index) - (setq sequence (cdr sequence))))) - (aref sequence index))) - -(defun %setelt (sequence index newval) - "Store NEWVAL as the component of SEQUENCE specified by INDEX." - (if (listp sequence) - (if (< index 0) - (error "~S: index too small." index) - (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))))) - (setf (aref sequence index) newval))) - -(defun length (sequence) - "Returns an integer that is the length of SEQUENCE." - (%primitive length sequence)) - -(defun list-length* (sequence) - (do ((count 0 (1+ count))) - ((atom sequence) count) - (declare (fixnum count)) - (setq sequence (cdr 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 (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." - (unless target-end (setq target-end (length target-sequence))) - (unless source-end (setq 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 output-type-spec) - (list (apply #'concat-to-list* sequences)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector) - (apply #'concat-to-simple* output-type-spec sequences)) - (t (error "~S: invalid output type specification." output-type-spec)))) - -;;; 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 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) - (map-to-simple output-type-spec function sequences)) - (t (error "~S: invalid output type specifier." output-type-spec))))) - - -;;; 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 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 (,ref ,sequence index))))) - -(defmacro mumble-reduce-from-end (function sequence 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 (,ref ,sequence index) value)))) - -(defmacro list-reduce (function sequence 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 (car sequence)) - (funcall ,function value (car sequence)))) - ((= count (the fixnum ,end)) value) - (declare (fixnum count))))) - -(defmacro list-reduce-from-end (function sequence 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 (car sequence)) - (funcall ,function (car sequence) value))) - ((= count (the fixnum ,end)) value) - (declare (fixnum count))))) - -) - -(defun reduce (function sequence &key from-end (start 0) - end (initial-value nil ivp)) - "The specified Sequence is ``reduced'' using the given Function. - See manual for details." - (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (cond ((= (the fixnum end) start) - (if ivp initial-value (funcall function))) - ((listp sequence) - (if from-end - (list-reduce-from-end function sequence start end initial-value ivp) - (list-reduce function sequence start end initial-value ivp))) - (from-end - (when (not ivp) - (setq end (1- (the fixnum end))) - (setq initial-value (aref sequence end))) - (mumble-reduce-from-end function sequence start end initial-value aref)) - (t - (when (not ivp) - (setq initial-value (aref sequence start)) - (setq start (1+ start))) - (mumble-reduce function sequence 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 (%primitive float-short object)) - ((single-float float) (%primitive float-single object)) - ((double-float long-float) (%primitive float-long 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 output-type-spec) - ((simple-string 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 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 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 output-type-spec) - (list (vector-to-list* object)) - ((simple-string 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 output-type-spec) - (list (vector-to-list* object)) - (simple-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 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 output-type-spec) - (list (vector-to-list* object)) - ((simple-string 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 (,(case src-type - (:list 'list-length*) - (:vector 'length)) - 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 (%primitive header-ref object - %array-fill-pointer-slot))) - (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 (%primitive header-ref object - %array-fill-pointer-slot))) - (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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) - (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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) - (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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) - (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* (,@(if reverse? '((sequence (reverse (the list 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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) - (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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) - (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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) - (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 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 (apply-key key elt) old)) - (funcall test (apply-key key elt) old))) - (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 (apply-key key elt) old)) - (funcall test (apply-key key elt) old))) - (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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence)) - (old (apply-key key old))) - (declare (fixnum length)) - (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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence)) - test-not - old) - (declare (fixnum length)) - (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)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence)) - test-not - old) - (declare (fixnum length)) - (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)) - (when (null end) (setf end (length sequence))) - (let ((incrementer 1)) - (declare (fixnum incrementer)) - (if from-end - (psetq start (1- end) - end (1- start) - incrementer -1)) - (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)) - (nvector-substitute* new old sequence incrementer - 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 (apply-key key (car list)) old)) - (funcall test (apply-key key (car list)) old)) - (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 (apply-key key (aref sequence index)) old)) - (funcall test (apply-key key (aref sequence index)) old)) - (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)) - (when (null end) (setf end (length sequence))) - (let ((incrementer 1)) - (declare (fixnum incrementer)) - (if from-end - (psetq start (1- end) - end (1- start) - incrementer -1)) - (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)) - (nvector-substitute-if* new test sequence incrementer - 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 end count)) - (when (null end) (setf end (length sequence))) - (let ((incrementer 1)) - (if from-end - (psetq start (1- end) - end (1- start) - incrementer -1)) - (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)) - (nvector-substitute-if-not* new test sequence incrementer - 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)) - (when (null end) (setf end (length sequence))) - (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)) - (when (null end) (setf end (length sequence))) - (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)) - (when (null end) (setf end (length sequence))) - (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)) - (when (null end) (setf end (length sequence))) - (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)) - (when (null end) (setf end (length sequence))) - (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)) - (when (null end) (setf end (length sequence))) - (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)) - (when (null end) (setf end (length sequence))) - (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) - `(setq ,sequence - (if from-end - (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1) - (reverse (the list ,sequence))) - (nthcdr ,start ,sequence)))) - -) - -;;; 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 ((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)) - (when (null end1) (setf end1 (length sequence1))) - (when (null end2) (setf end2 (length sequence2))) - (let ((length1 (length sequence1)) - (length2 (length sequence2))) - (declare (fixnum length1 length2)) - (match-vars - (seq-dispatch sequence1 - (progn (matchify-list sequence1 start1 length1 end1) - (seq-dispatch sequence2 - (progn (matchify-list sequence2 start2 length2 end2) - (list-list-mismatch)) - (list-mumble-mismatch))) - (seq-dispatch sequence2 - (progn (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)) - (when (null end1) (setf end1 (length sequence1))) - (when (null end2) (setf end2 (length sequence2))) - (seq-dispatch sequence2 - (list-search sequence2 sequence1) - (vector-search sequence2 sequence1))) diff --git a/code/serve-event.lisp b/code/serve-event.lisp deleted file mode 100644 index c6ac2df640ec3aad4b186c213016683f06c04899..0000000000000000000000000000000000000000 --- a/code/serve-event.lisp +++ /dev/null @@ -1,376 +0,0 @@ -;;; -*- Log: code.log; Package: LISP -*- - -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; SYSTEM:SERVE-EVENT, now in it's own file. -;;; -;;; Re-written by William Lott, July 1989 - January 1990. -;;; -;;; ********************************************************************** - -(in-package "SYSTEM") - -(export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor - serve-event serve-all-events wait-until-fd-usable)) - -(in-package "EXTENSIONS") - -(export '(*display-event-handlers*)) - -(in-package "LISP") - - - -;;;; MACH Message receiving noise. - -(defvar *in-server* NIL - "*In-server* is set to T when the SIGMSG interrupt has been enabled - in Server.") - -(defvar server-unique-object (cons 1 2) - "Object thrown by the message interrupt handler.") - -(defconstant server-message-size 4096) -(defalien server-message server-message (bytes server-message-size) 0) - -(define-alien-stack server-message server-message (bytes server-message-size)) - -(defrecord server-message - (msg mach:msg #.(record-size 'mach:msg))) - -;;; Grab-message-loop calls the appropiate handler for an IPC message. -(defun grab-message-loop () - (let ((done-any nil)) - (loop - (if (eql (server-grab-message) - mach:rcv-timed-out) - (return done-any) - (setf done-any t))))) - - -(defun server-grab-message () - (with-stack-alien (sm server-message) - (alien-bind ((msg (server-message-msg (alien-value sm)))) - (setf (alien-access (mach:msg-msgsize (alien-value msg))) - server-message-size) - (setf (alien-access (mach:msg-localport (alien-value msg))) - mach::port-enabled) - (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0))) - (when (eql gr mach:rcv-timed-out) - (return-from server-grab-message gr)) - (unless (eql gr mach:rcv-success) - (gr-error 'mach:msg-receive gr)) - (let* ((server-message (alien-value sm)) - (port (alien-access (mach:msg-localport (alien-value msg)))) - (id (alien-access (mach:msg-id (alien-value msg)))) - (x (gethash port *port-table*)) - (set (cdr x))) - (unless x - (error "~D is not known to server (operation: ~D)." port id)) - (let ((gr (funcall (gethash id (object-set-table set) - (object-set-default-handler set)) - (car x)))) - (unless (eql gr mach:kern-success) - (gr-error 'server gr))))))) - mach:kern-success) - - -;;;; File descriptor IO noise. - -(defstruct (handler - (:print-function %print-handler) - (:constructor make-handler (direction descriptor function))) - direction ; Either :input or :output - descriptor ; File descriptor this handler is tied to. - active ; T iff this handler is running. - function ; Function to call. - bogus ; T if this descriptor is bogus. - ) - -(defun %print-handler (handler stream depth) - (declare (ignore depth)) - (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>" - (handler-direction handler) - (handler-bogus handler) - (handler-descriptor handler) - (handler-function handler))) - -(defvar *descriptor-handlers* nil - "List of all the currently active handlers for file descriptors") - - -;;; ADD-FD-HANDLER -- public -;;; -;;; Add a new handler to *descriptor-handlers*. -;;; -(defun add-fd-handler (fd direction function) - "Arange to call FUNCTION whenever FD is usable. DIRECTION should be - either :INPUT or :OUTPUT. The value returned should be passed to - SYSTEM:REMOVE-FD-HANDLER when it is no longer needed." - (assert (member direction '(:input :output)) - (direction) - "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction) - (let ((handler (make-handler direction fd function))) - (push handler *descriptor-handlers*) - handler)) - -;;; REMOVE-FD-HANDLER -- public -;;; -;;; Remove an old handler from *descriptor-handlers*. -;;; -(defun remove-fd-handler (handler) - "Removes HANDLER from the list of active handlers." - (setf *descriptor-handlers* - (delete handler *descriptor-handlers* - :test #'eq))) - -;;; INVALIDATE-DESCRIPTOR -- public -;;; -;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em. -;;; -(defun invalidate-descriptor (fd) - "Remove any handers refering to fd. This should only be used when attempting - to recover from a detected inconsistancy." - (setf *descriptor-handlers* - (delete fd *descriptor-handlers* - :key #'handler-descriptor))) - -;;; WITH-FD-HANDLER -- Public. -;;; -;;; Add the handler to *descriptor-handlers* for the duration of BODY. -;;; -(defmacro with-fd-handler ((fd direction function) &rest body) - "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY. - DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to - use, and FUNCTION is the function to call whenever FD is usable." - (let ((handler (gensym))) - `(let (,handler) - (unwind-protect - (progn - (setf ,handler (add-fd-handler ,fd ,direction ,function)) - ,@body) - (when ,handler - (remove-fd-handler ,handler)))))) - -;;; WAIT-UNTIL-FD-USABLE -- Public. -;;; -;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is -;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will -;;; timeout at the correct time irrespective of how many events are handled in -;;; the meantime. -;;; -(defun wait-until-fd-usable (fd direction &optional timeout) - "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or - :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving - up." - (let (usable - (stop-at (if timeout - (multiple-value-bind (okay sec usec) - (mach:unix-gettimeofday) - (declare (ignore okay)) - (+ (* 1000000 timeout sec) usec))))) - (with-fd-handler (fd direction #'(lambda (fd) - (declare (ignore fd)) - (setf usable t))) - (loop - (serve-event timeout) - - (when usable - (return t)) - - (when timeout - (multiple-value-bind (okay sec usec) - (mach:unix-gettimeofday) - (declare (ignore okay)) - (let ((now (+ (* sec 1000000) usec))) - (if (> now stop-at) - (return nil) - (setq timeout - (/ (- stop-at now) - 1000000)))))))))) - -;;; CALC-MASKS -- Internal. -;;; -;;; Return the correct masks to use for UNIX-SELECT. The four return values -;;; are: fd count, read mask, write mask, and exception mask. The exception -;;; mask is currently unused. -;;; -(defun calc-masks () - (let ((count 0) - (read-mask 0) - (write-mask 0) - (except-mask 0)) - (dolist (handler *descriptor-handlers*) - (unless (or (handler-active handler) - (handler-bogus handler)) - (let ((fd (handler-descriptor handler))) - (case (handler-direction handler) - (:input - (setf read-mask (logior read-mask (ash 1 fd)))) - (:output - (setf write-mask (logior write-mask (ash 1 fd))))) - (if (> fd count) - (setf count fd))))) - (values (1+ count) - read-mask - write-mask - except-mask))) - -;;; HANDLER-DESCRIPTORS-ERROR -- Internal. -;;; -;;; First, get a list and mark bad file descriptors. Then signal an error -;;; offering a few restarts. -;;; -(defun handler-descriptors-error () - (let ((bogus-handlers nil)) - (dolist (handler *descriptor-handlers*) - (unless (or (handler-bogus handler) - (mach:unix-fstat (handler-descriptor handler))) - (setf (handler-bogus handler) t) - (push handler bogus-handlers))) - (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P." - bogus-handlers (length bogus-handlers)) - (remove-them () :report "Remove bogus handlers." - (setf *descriptor-handlers* - (delete-if #'handler-bogus *descriptor-handlers*))) - (retry-them () :report "Retry bogus handlers." - (dolist (handler bogus-handlers) - (setf (handler-bogus handler) nil))) - (continue () :report "Go on, leaving handlers marked as bogus.")))) - - - -;;;; Serve-all-events, serve-event, and friends. - -(defvar *display-event-handlers* nil - "This is an alist mapping displays to user functions to be called when - SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify - this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display - should be represented here only once.") - -;;; SERVE-ALL-EVENTS -- public -;;; -;;; Wait for up to timeout seconds for an event to happen. Make sure all -;;; pending events are processed before returning. -;;; -(defun serve-all-events (&optional timeout) - "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If - SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout - 0 until all events have been served. SERVE-ALL-EVENTS returns T if - SERVE-EVENT did something and NIL if not." - (do ((res nil) - (sval (serve-event timeout) (serve-event 0))) - ((null sval) res) - (setq res t))) - - -;;; SERVE-EVENT -- public -;;; -;;; Serve a single event. -;;; -(defun serve-event (&optional timeout) - "Receive on all ports and Xevents and dispatch to the appropriate handler - function. If timeout is specified, server will wait the specified time (in - seconds) and then return, otherwise it will wait until something happens. - Server returns T if something happened and NIL otherwise." - ;; First, check any X displays for any pending events. - (dolist (d/h *display-event-handlers*) - (let ((d (car d/h))) - (when (xlib::event-listen d) - (handler-bind ((error #'(lambda (condx) - (declare (ignore condx)) - (flush-display-events d)))) - (funcall (cdr d/h) d)) - (return-from serve-event t)))) - ;; Next, wait for something to happen. - (multiple-value-bind - (value readable writeable) - (wait-for-event timeout) - ;; Now see what it was (if anything) - (cond ((eq value server-unique-object) - ;; The interrupt handler fired. - (grab-message-loop) - t) - ((numberp value) - (unless (zerop value) - ;; Check the descriptors. - (let ((result nil)) - (dolist (handler *descriptor-handlers*) - (when (not (zerop (logand (ash 1 (handler-descriptor handler)) - (case (handler-direction handler) - (:input readable) - (:output writeable))))) - (unwind-protect - (progn - ;; Doesn't work -- ACK - ;(setf (handler-active handler) t) - (funcall (handler-function handler) - (handler-descriptor handler))) - (setf (handler-active handler) nil)) - (macrolet ((frob (var) - `(setf ,var - (logand (lognot (ash 1 - (handler-descriptor - handler))) - ,var)))) - (case (handler-direction handler) - (:input (frob readable)) - (:output (frob writeable)))) - (setf result t))) - result))) - ((eql readable mach:eintr) - ;; We did an interrupt. - t) - (t - ;; One of the file descriptors is bad. - (handler-descriptors-error) - nil)))) - -;;; WAIT-FOR-EVENT -- internal -;;; -;;; Wait for something to happen. -;;; -(defun wait-for-event (&optional timeout) - "Wait for an something to show up on one of the file descriptors or a message - interupt to fire. Timeout is in seconds." - (let (old-mask) - (multiple-value-bind (timeout-sec timeout-usec) - (if timeout - (truncate (round (* timeout 1000000)) 1000000) - (values nil 0)) - (multiple-value-bind (count read-mask write-mask except-mask) - (calc-masks) - (catch 'server-catch - (unwind-protect - (progn - ;; Block message interrupts. - (multiple-value-bind - (noise mask) - (mach:unix-sigsetmask (mach:sigmask :sigmsg)) - (declare (ignore noise)) - (setf old-mask mask)) - ;; Check for any pending messages, because we are only signaled - ;; for newly arived messages. This must be done after the - ;; unix-sigsetmask. - (when (grab-message-loop) - (return-from wait-for-event t)) - ;; Indicate that we are in the server. - (let ((*in-server* t)) - ;; Establish the interrupt handlers. - (enable-interrupt mach:sigmsg #'ih-sigmsg) - ;; Enable all interrupts. - (mach:unix-sigsetmask 0) - ;; Do the select. - (mach:unix-select count read-mask write-mask except-mask - timeout-sec timeout-usec))) - ;; Restore interrupt handler state. - (mach:unix-sigsetmask (mach:sigmask :sigmsg)) - (default-interrupt mach:sigmsg) - (mach:unix-sigsetmask old-mask))))))) - - diff --git a/code/sharpm.lisp b/code/sharpm.lisp deleted file mode 100644 index 65338fd9a021abc31fefcdca8d9d54a4e5808cf7..0000000000000000000000000000000000000000 --- a/code/sharpm.lisp +++ /dev/null @@ -1,456 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Spice Lisp Interim Sharp Macro -;;; Written by David Dill -;;; Runs in the standard Spice Lisp environment. -;;; This uses the special std-lisp-readtable, which is internal to READER.LISP -;;; -;;; **************************************************************** -(in-package 'lisp) - - -;;; declared in READ.LISP - -(proclaim '(special *read-suppress* std-lisp-readtable *bq-vector-flag*)) - -(defun sharp-backslash (stream backslash font) - (unread-char backslash stream) - (let* ((*readtable* std-lisp-readtable) - (bitnames ()) - (charstring (read-extended-token stream))) - (declare (simple-string charstring)) - (when *read-suppress* (return-from sharp-backslash nil)) - ;;find bit name prefixes - (do ((i (position #\- charstring) (position #\- charstring))) - ((or (null i) (zerop (the fixnum i)))) - (let ((bitname (string-upcase (subseq charstring 0 i)))) - (setq charstring (subseq charstring (1+ (the fixnum i)))) - ;;* symbols in alist are a kludge to circumvent xc bogosity. - (let ((expansion (cdr (assoc bitname '(("C" . CONTROL) - ("M" . META) - ("H" . HYPER) - ("S" . SUPER)) - :test #'equal)))) - (if expansion (setq bitname (symbol-name expansion))) - (cond ((member bitname '("CONTROL" "META" "HYPER" "SUPER") - :test #'EQUAL) - (if (not (member bitname bitnames :test #'EQUAL)) - (push bitname bitnames) - (error - "Redundant bit name in character name: ~A" - bitname))) - (t (error - "Meaningless bit name in character name: ~A" - bitname)))))) - ;;build un-hyphenated char, add specified bits: - (let ((char (if (= (the fixnum (length charstring)) 1) - (char charstring 0) - (name-char charstring)))) - (cond (char - (if font - (setq char (make-char char 0 font))) - (if (member "CONTROL" bitnames :test #'EQUAL) - (setq char (set-char-bit char :control t))) - (if (member "META" bitnames :test #'EQUAL) - (setq char (set-char-bit char :meta t))) - (if (member "HYPER" bitnames :test #'EQUAL) - (setq char (set-char-bit char :hyper t))) - (if (member "SUPER" bitnames :test #'EQUAL) - (setq char (set-char-bit char :super t))) - char) - (t (error "Meaningless character name ~A" - charstring)))))) - -(defun sharp-quote (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - ;; 4th arg tells read that this is a recrusive call. - `(function ,(read stream () () t))) - -(defun sharp-left-paren (stream ignore length) - (declare (ignore ignore)) - (declare (special *backquote-count*)) - (let* ((list (read-list stream nil)) - (listlength (length list))) - (declare (list list) - (fixnum listlength)) - (cond (*read-suppress*) - ((zerop *backquote-count*) - (if length - (cond ((> listlength (the fixnum length)) - (error - "Vector longer than specified length: #~S~S" - length list)) - (t - (fill (the simple-vector - (replace (the simple-vector (make-array length)) - list)) - (car (last list)) - :start listlength))) - (coerce list 'vector))) - (t (cons *bq-vector-flag* list))))) - -(defun sharp-star (stream ignore numarg) - (declare (ignore ignore)) - (multiple-value-bind (bstring escape-appearedp) - (read-extended-token stream) - (declare (simple-string bstring)) - (cond (*read-suppress*) - (escape-appearedp - (error "Escape character appeared after #*")) - ((and numarg (zerop (length bstring)) (not (zerop numarg))) - (error "You have to give a little bit for non-zero #* bit-vectors.")) - ((or (null numarg) (>= (the fixnum numarg) (length bstring))) - (let* ((len1 (length bstring)) - (last1 (1- len1)) - (len2 (or numarg len1)) - (bvec (make-array len2 :element-type 'bit - :initial-element 0))) - (declare (fixnum len1 last1 len2)) - (do ((i 0 (1+ i)) - (char ())) - ((= i len2)) - (declare (fixnum i)) - (setq char (elt bstring (if (< i len1) i last1))) - (setf (elt bvec i) - (cond ((char= char #\0) 0) - ((char= char #\1) 1) - (t - (error "Illegal element given for ~ - bitvector #~A*~A" - numarg bstring))))) - bvec)) - (t - (error "Bit vector is longer than specified length #~A*~A" - numarg bstring))))) - - -(defun sharp-colon (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (when *read-suppress* - (read stream () () t) - (return-from sharp-colon nil)) - (let ((token (read-extended-token stream))) - (declare (simple-string token)) - (cond (*read-suppress*) - ((find #\: token) - (error "Symbol following #: contains a #\: ~S" token)) - ((eql (length token) 0) - (let ((ch (read-char stream nil nil t))) - (if ch - (error "Illegal terminating character after a colon, ~S." ch) - (error "Illegal terminating character after a colon.")))) - (T (make-symbol token))))) - -(defun sharp-dot (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (let ((token (read stream () () t))) - (unless *read-suppress* (eval token)))) - -(defun sharp-comma (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (let ((token (read stream () () t))) - (unless *read-suppress* (eval token)))) - -(defun sharp-R (stream ignore radix) - (declare (ignore ignore)) - (multiple-value-bind (token escape-appearedp) - (read-extended-token stream) - (declare (simple-string token)) - (when *read-suppress* (return-from sharp-R nil)) - (let ((numval 0) (denval 0) (resttok 0) (toklength (length token)) - (sign 1)) - (declare (fixnum toklength)) - (if escape-appearedp - (error "Escape character appears in number.")) - ;;look for leading sign - (let ((firstchar (elt token 0))) - (cond ((char= firstchar #\-) - (setq sign -1) - (setq resttok 1)) - ((char= firstchar #\+) - (setq resttok 1)))) - ;;read numerator - (do ((position resttok (1+ position)) - (dig ())) - ((or (>= position toklength) - (not (setq dig (digit-char-p (elt token position) radix)))) - (setq resttok position)) - (setq numval (+ (* numval radix) dig))) - ;;see if we're at the end. - (cond ((>= resttok toklength) - ;;just return numerator -- that's all there is. - (* numval sign)) - ((char= (elt token resttok) #\/) - ;;it's a ratio. - (do ((position (1+ resttok) (1+ position)) - (dig ()) - (retval ())) - ((cond ((>= position toklength) - (setq retval (/ (* numval sign) denval))) - ((not (setq dig (digit-char-p (elt token position) - radix))) - ;;there's bogus stuff at the end - (error - "Illegal digits ~S for radix ~S" token radix) - (setq retval (/ (* numval sign) denval))) - ;;continue looping - (t nil)) - retval) - (setq denval (+ (* denval radix) dig)))) - ;;it's bogus - (t (error - "Illegal digits ~S for radix ~S" token radix))))))) - -(defun sharp-B (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (sharp-r stream nil 2)) - -(defun sharp-O (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (sharp-r stream nil 8)) - -(defun sharp-X (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (sharp-r stream nil 16)) - -(defun sharp-A (stream ignore dimensions) - (declare (ignore ignore)) - (when *read-suppress* - (read stream () () t) - (return-from sharp-A nil)) - (unless dimensions (error "No dimensions argument to #A.")) - (unless (and (integerp dimensions) (>= dimensions 0)) - (error "Dimensions argument to #A not a non-negative integer: ~S" - dimensions)) - (if (> dimensions 0) - (let ((dlist (make-list dimensions)) - (init-list - (if (char= (read-char stream t) #\( #|)|#) - (read-list stream nil) - (error "Array values must be a list.")))) - (do ((dl dlist (cdr dl)) - (il init-list (car il))) - ;; I think the nreverse is causing the problem. - ((null dl)) - (if (listp il) - (rplaca dl (length il)) - (error - "Initial contents for #A is inconsistent with ~ - dimensions: #~SA~S" dimensions init-list))) - (make-array dlist :initial-contents init-list)) - (make-array nil :initial-element (read stream t nil t)))) - - -(defun sharp-S (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - ;;this needs to know about defstruct implementation - (when *read-suppress* - (read stream () () t) - (return-from sharp-S nil)) - (let ((body - (if (char= (read-char stream t) #\( ) - (read-list stream nil) - (error "Non-list following #S")))) - (cond ((listp body) - (unless (symbolp (car body)) - (error "Structure type is not a symbol: ~S" (car body))) - (let ((defstruct (info type defined-structure-info (car body)))) - (unless defstruct - (error "~S is not a defined structure type." (car body))) - (unless (c::dd-constructor defstruct) - (error "The ~S structure does not have a default constructor." (car body))) - (do ((arg (cdr body) (cddr arg)) - (res ())) - ((endp arg) (apply (c::dd-constructor defstruct) res)) - (push (cadr arg) res) - (push (intern (string (car arg)) *keyword-package*) res)))) - (t (error "Non-list following #S: ~S" body)))))) - -(defmacro int-subst-array (new old array rank var-list) - (if (> rank (array-rank array)) - (let ((new-list (nreverse var-list))) - `(if (eq ,old (aref ,array ,@new-list)) - (setf (aref ,array ,@new-list) ,new))) - (let ((newvar (gensym))) - `(dotimes (,newvar (array-dimension ,array ,rank)) - (int-subst-array ,new ,old ,array (1+ ,rank) - (push ,newvar ,var-list)))))) - -(defmacro subst-array (new old array) - `(int-subst-array ,new ,old ,array 0 nil)) - -(defvar sharp-cons-table () - "Holds the cons cells seen already by circle-subst") - -;; This function is the same as nsubst, except that it checks for circular -;; lists. the first arg is an alist of the things to be replaced assoc'd with -;; the things to replace them. -(defun circle-subst (old-new-alist tree) - (cond ((and (atom tree) - (not (and (arrayp tree) - (eq (array-element-type tree) t)))) - (let ((pair (assq tree old-new-alist))) - (if pair (cdr pair) tree))) - ((null (gethash tree sharp-cons-table)) - (setf (gethash tree sharp-cons-table) t) - (cond ((simple-vector-p tree) - (do ((i 0 (1+ i)) - (len (length tree))) - ((>= i len)) - (declare (fixnum i len)) - (setf (svref tree i) - (circle-subst old-new-alist (svref tree i)))) - tree) - ((arrayp tree) - (with-array-data ((data tree) (start) (end)) - (declare (fixnum start end)) - (do ((i start (1+ i))) - ((>= i end)) - (setf (aref data i) - (circle-subst old-new-alist (aref data i))))) - tree) - (T (let ((a (circle-subst old-new-alist (car tree))) - (d (circle-subst old-new-alist (cdr tree)))) - (if (eq a (car tree)) - tree - (rplaca tree a)) - (if (eq d (cdr tree)) - tree - (rplacd tree d))) - tree))) - (t tree))) - -;; Sharp-equal works as follows. When a label is assigned -;; (ie when #= is called) a symbol (ref) is gensym'd and -;; a cons cell whose car is the label, and cdr is the symbol -;; is put on the sharp-sharp alist. When sharp-sharp encounters -;; a reference to a label it returns the symbol assoc'd with the label. -;; When an object has been read then a cons cell whose car is the symbol -;; and cdr is the object is pushed onto the sharp-sharp-alist. Then -;; for each cons cell on the sharp-sharp-alist, the current object is searched -;; and where a symbol eq to the car of the current cons cell is found, -;; the object is substituted in. -(defun sharp-equal (stream ignore label &aux (ref (gensym))) - (declare (ignore ignore)) - (declare (special sharp-equal-alist sharp-sharp-alist)) - (when *read-suppress* (return-from sharp-equal (values))) - (unless (integerp label) - (error "non-integer label #~S=" label)) - (push (cons label ref) sharp-sharp-alist) - (let ((obj (read stream () () t))) - (push (cons ref obj) sharp-equal-alist) - (clrhash sharp-cons-table) - (circle-subst sharp-equal-alist obj))) - -(defun sharp-sharp (ignore1 ignore2 label) - (declare (ignore ignore1 ignore2)) - (declare (special sharp-equal-alist sharp-sharp-alist)) - (when *read-suppress* (return-from sharp-sharp nil)) - (if (integerp label) - (let ((pair (assoc label sharp-sharp-alist))) - (if pair - (let ((ret-obj (cdr (assoc (cdr pair) sharp-equal-alist)))) - (if ret-obj ret-obj - (cdr pair))) - (error "Object is not labelled #~S#" label))) - (error "Non-integer label #~S#" label))) - -(defun sharp-plus (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (cond (*read-suppress* - (read stream () () t) - (values)) - ((featurep (let ((*package* *keyword-package*)) - (read stream () () t))) - (read stream () () t)) - (t (let ((*read-suppress* t)) - (read stream () () t) - (values))))) - -(defun sharp-minus (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (cond (*read-suppress* - (read stream () () t) - (values)) - ((not (featurep (let ((*package* *keyword-package*)) - (read stream () () t)))) - (read stream () () t)) - (t (let ((*read-suppress* t)) - (read stream () () t) - (values))))) - -(defun sharp-C (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - ;;next thing better be a list of two numbers. - (let ((cnum (read stream () () t))) - (when *read-suppress* (return-from sharp-c nil)) - (if (= (length cnum) 2) - (complex (car cnum) (cadr cnum)) - (error "Illegal complex number format" cnum)))) - -(defun sharp-vertical-bar (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (prepare-for-fast-read-char stream - (do ((level 1) - (prev (fast-read-char) char) - (char (fast-read-char) (fast-read-char))) - (()) - (cond ((and (char= prev #\|) (char= char #\#)) - (setq level (1- level)) - (when (zerop level) - (done-with-fast-read-char) - (return (values))) - (setq char (fast-read-char))) - ((and (char= prev #\#) (char= char #\|)) - (setq char (fast-read-char)) - (setq level (1+ level))))))) - -(defun sharp-illegal (ignore1 sub-char ignore2) - (declare (ignore ignore1 ignore2)) - (error "Illegal sharp character ~S" sub-char)) - - -(defun sharp-init () - (declare (special std-lisp-readtable)) - (setq sharp-cons-table (make-hash-table :size 50)) - (let ((*readtable* std-lisp-readtable)) - (make-dispatch-macro-character #\#) - (set-dispatch-macro-character #\# #\\ #'sharp-backslash) - (set-dispatch-macro-character #\# #\' #'sharp-quote) - (set-dispatch-macro-character #\# #\( #'sharp-left-paren) - (set-dispatch-macro-character #\# #\* #'sharp-star) - (set-dispatch-macro-character #\# #\: #'sharp-colon) - (set-dispatch-macro-character #\# #\. #'sharp-dot) - (set-dispatch-macro-character #\# #\, #'sharp-comma) - (set-dispatch-macro-character #\# #\R #'sharp-R) - (set-dispatch-macro-character #\# #\r #'sharp-R) - (set-dispatch-macro-character #\# #\B #'sharp-B) - (set-dispatch-macro-character #\# #\b #'sharp-B) - (set-dispatch-macro-character #\# #\O #'sharp-O) - (set-dispatch-macro-character #\# #\o #'sharp-O) - (set-dispatch-macro-character #\# #\X #'sharp-X) - (set-dispatch-macro-character #\# #\x #'sharp-X) - (set-dispatch-macro-character #\# #\A #'sharp-A) - (set-dispatch-macro-character #\# #\a #'sharp-A) - (set-dispatch-macro-character #\# #\S #'sharp-S) - (set-dispatch-macro-character #\# #\s #'sharp-S) - (set-dispatch-macro-character #\# #\= #'sharp-equal) - (set-dispatch-macro-character #\# #\# #'sharp-sharp) - (set-dispatch-macro-character #\# #\+ #'sharp-plus) - (set-dispatch-macro-character #\# #\- #'sharp-minus) - (set-dispatch-macro-character #\# #\C #'sharp-C) - (set-dispatch-macro-character #\# #\c #'sharp-C) - (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar) - (set-dispatch-macro-character #\# #\tab #'sharp-illegal) - (set-dispatch-macro-character #\# #\ #'sharp-illegal) - (set-dispatch-macro-character #\# #\) #'sharp-illegal) - (set-dispatch-macro-character #\# #\< #'sharp-illegal) - (set-dispatch-macro-character #\# #\form #'sharp-illegal) - (set-dispatch-macro-character #\# #\return #'sharp-illegal))) diff --git a/code/sort.lisp b/code/sort.lisp deleted file mode 100644 index c1183a566d3e73f81d982c8bae986060160b1ad9..0000000000000000000000000000000000000000 --- a/code/sort.lisp +++ /dev/null @@ -1,442 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; 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/stream.lisp b/code/stream.lisp deleted file mode 100644 index a59b834844a3a47da9dde811e78c9d20e495c311..0000000000000000000000000000000000000000 --- a/code/stream.lisp +++ /dev/null @@ -1,1050 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Stream functions for Spice Lisp. -;;; Written by Skef Wholey and Rob MacLachlan. -;;; -;;; This file contains the machine-independent stream functions. Another -;;; file (VAXIO, SPIO, or VMIO) contains functions used by this file for -;;; a specific machine. -;;; -(in-package "LISP") - -(export '(make-broadcast-stream make-synonym-stream - make-broadcast-stream make-concatenated-stream make-two-way-stream - make-echo-stream make-string-input-stream make-string-output-stream - get-output-stream-string stream-element-type input-stream-p - output-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 *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) - -;;;; 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 true if any input waiting. -;;; :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. -;;; -;;; 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 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 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 (%primitive 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) - (declare (simple-string str)) - (if (= index in-buffer-length) - (values str eofp) - (values (prog1 - (concatenate 'simple-string - (subseq buffer index in-buffer-length) - str) - (setf (stream-in-index stream) in-buffer-length)) - 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) - (funcall (stream-misc stream) stream :listen)))) - -(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)) - (if (listen stream) (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 (eql (%primitive get-vector-access-code in-buffer) 3)) - (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) - -(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) - -(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) - (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) - (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) - (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 - ;; And write to this one - output-stream) - -(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) - (,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 (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) - -(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 nil) - (declare (simple-string 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. - (when result - (do ((current (cdr current) (cdr current)) - (new "")) - ((or (not eofp) (null current)) - (return-from concatenated-readline (values result eofp))) - (declare (simple-string new)) - (setf (concatenated-stream-current stream) current) - (let ((this (car current))) - (multiple-value-setq (new eofp) - (read-line this nil nil)) - (if new - (setq result (concatenate 'simple-string result new)) - (setq eofp t))))))))) - -(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 (or (/= (the fixnum (stream-in-index current)) in-buffer-length) - (funcall misc current :listen))) - (: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)))) - - -(macrolet ((in-fun (name fun out-slot &rest args) - `(defun ,name (stream ,@args) - (let* ((in (two-way-stream-input-stream stream)) - (out (two-way-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 (/= (the fixnum (stream-in-index in)) in-buffer-length) - (funcall in-method in :listen))) - (:read-line - (multiple-value-bind (result eofp) - (read-line in arg1 arg2) - (if eofp - (write-string result out) - (write-line result out)) - (values 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 (null arg1) - (string-input-stream-current 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 (%primitive find-character string current end #\newline))) - (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 (not (= (the fixnum (string-input-stream-current stream)) - (the fixnum (string-input-stream-end stream))))) - (: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 (%primitive header-ref buffer %array-fill-pointer-slot)) - (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)) - (%primitive header-set buffer %array-fill-pointer-slot 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 (%primitive header-ref buffer %array-fill-pointer-slot)) - (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)) - (%primitive header-set buffer %array-fill-pointer-slot 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 (%primitive header-ref buffer %array-fill-pointer-slot))) - (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 '(notinline read-char unread-char read-byte listen)) diff --git a/code/string.lisp b/code/string.lisp deleted file mode 100644 index 838d975096b24ccfec11a947b6b03c33d0af1f7b..0000000000000000000000000000000000000000 --- a/code/string.lisp +++ /dev/null @@ -1,609 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Functions to implement strings for Spice Lisp -;;; Written by David Dill -;;; Rewritten and currently maintained by Skef Wholey -;;; -;;; 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)) - -(eval-when (compile) - -;;; %String returns its arg if it is a string, otherwise calls String. -;;; -(defmacro %string (thing) - `(if (stringp ,thing) ,thing (string ,thing))) -) - -(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 ((data (gensym)) - (data-start (gensym)) - (data-end (gensym)) - (offset (gensym))) - `(progn - (if (symbolp ,string) - (setf ,string (symbol-name ,string))) - (if (array-header-p ,string) - (with-array-data ((,data ,string :offset-var ,offset) - (,data-start ,start) - (,data-end (or ,end - (length (the simple-string - ,string))))) - (psetq ,string ,data - ,cum-offset ,offset - ,start ,data-start - ,end ,data-end)) - (if (not ,end) (setq ,end (length (the simple-string ,string))))) - ,@forms))) - -) - -;;; With-String is like With-One-String, but doesn't parse keywords. - -(eval-when (compile) - -(defmacro with-string (string &rest forms) - `(let ((start 0) - (end ())) - (if (symbolp ,string) (setq ,string (symbol-name ,string))) - (if (array-header-p ,string) - (with-array-data ((data ,string) - (data-start start) - (data-end (length (the simple-string ,string)))) - (psetq ,string data - start data-start - end data-end)) - (setq end (length (the simple-string ,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 ((data (gensym)) - (data-start (gensym)) - (data-end (gensym)) - (offset (gensym))) - `(progn - (if (symbolp ,string1) (setq ,string1 (symbol-name ,string1))) - (if (symbolp ,string2) (setq ,string2 (symbol-name ,string2))) - (if (array-header-p ,string1) - (with-array-data ((,data ,string1 :offset-var ,offset) - (,data-start ,start1) - (,data-end (or ,end1 - (length (the simple-string - ,string1))))) - (psetq ,string1 ,data - ,cum-offset-1 ,offset - ,start1 ,data-start - ,end1 ,data-end)) - (if (not ,end1) (setq ,end1 (length (the simple-string ,string1))))) - (if (array-header-p ,string2) - (with-array-data ((,data ,string2) - (,data-start ,start2) - (,data-end (or ,end2 - (length (the simple-string - ,string2))))) - (psetq ,string2 ,data - ,start2 ,data-start - ,end2 ,data-end)) - (if (not ,end2) (setq ,end2 (length (the simple-string ,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." - (char string index)) - -(defun %charset (string index new-el) - (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." - (schar string index)) - -(defun %scharset (string index new-el) - (setf (schar string index) new-el)) - -(defun string=* (string1 string2 start1 end1 start2 end2) - (let ((offset1 0)) - (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) - (let ((offset1 0)) - (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))) - `(let ((,offset1 0)) - (declare (fixnum ,offset1)) - (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)) - (let ((offset1 0)) - (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 ()." - (let ((offset1 0)) - (declare (fixnum offset1)) - (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) - `(let ((offset1 0)) - (declare (fixnum offset1)) - (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)) - (if (symbolp string) (setq string (symbol-name string))) - (let ((slen (length string)) - (offset 0)) - (declare (fixnum slen offset)) - (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)) - (if (symbolp string) (setq string (symbol-name string))) - (let ((slen (length string)) - (offset 0)) - (declare (fixnum slen offset)) - (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)) - (if (symbolp string) (setq string (symbol-name string))) - (let ((slen (length string)) - (offset 0)) - (declare (fixnum slen offset)) - (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) - offset) - (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) - offset) - (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) - offset) - (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/struct.lisp b/code/struct.lisp deleted file mode 100644 index 9488ab77222de939cdcfdd199eb28f6c53d2f91a..0000000000000000000000000000000000000000 --- a/code/struct.lisp +++ /dev/null @@ -1,131 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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 structure definitions that need to be compiled early -;;; for bootstrapping reasons. -;;; -(in-package 'lisp) - -;;;; Defstruct structures: - -(in-package 'c) - -(defstruct (defstruct-description - (:conc-name dd-) - (:print-function print-defstruct-description)) - name ; name of the structure - doc ; documentation on the structure - slots ; list of slots - conc-name ; prefix for slot names - constructor ; name of standard constructor function - boa-constructors ; BOA constructors (cdr of option). - copier ; name of copying function - predicate ; name of type predictate - include ; name of included structure - (includes ()) ; names of all structures included by this one - (included-by ()) ; names of all strctures that include this one - print-function ; function used to print it - type ; type specified, Structure if no type specified. - lisp-type ; actual type used for implementation. - named ; T if named, Nil otherwise - offset ; first slot's offset into implementation sequence - (length nil :type (or fixnum null))) ; total length of the thing - - -(defstruct (defstruct-slot-description - (:conc-name dsd-) - (:print-function print-defstruct-slot-description)) - %name ; string name of slot - (index nil :type fixnum) ; its position in the implementation sequence - accessor ; name of it accessor function - default ; default value - type ; declared type - read-only) ; T if there's to be no setter for it - - -(in-package 'lisp) - -;;;; The stream structure: - -(defconstant in-buffer-length 100 "The size of a stream in-buffer.") - -(defstruct (stream (:predicate streamp) (:print-function %print-stream)) - (in-buffer nil) ; Buffered input - (in-index in-buffer-length :type fixnum) ; Index into in-buffer - (in #'ill-in) ; Read-Char function - (bin #'ill-bin) ; Byte input function - (n-bin #'ill-bin) ; N-Byte input function - (out #'ill-out) ; Write-Char function - (bout #'ill-bout) ; Byte output function - (sout #'ill-out) ; String output function - (misc #'do-nothing)) ; Less used methods - - -;;;; Alien structures: - -(defstruct (alien-value - (:constructor make-alien-value (sap offset size type)) - (:print-function %print-alien-value)) - "This structure represents an Alien value." - sap - offset - size - type) - -(defstruct (ct-a-val - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (write-string "#<Alien compiler info>" stream)))) - type ; Type of expression, NIL if unknown. - size ; Expression for the size of the alien. - sap ; Expression for SAP. - offset ; Expression for bit offset. - alien) ; Expression for alien-value or NIL. - - -(defstruct (alien-info - (:print-function %print-alien-info) - (:constructor - make-alien-info (function num-args arg-types result-type))) - function ; The function the definition was made into. - num-args ; The total number of arguments. - arg-types ; Alist of arg numbers to types of Alien args. - result-type) ; The type of the resulting Alien. - - -(defstruct (stack-info - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (format stream "#<Alien stack info>")))) - type - size - head - current - grow) - - -(defstruct enumeration-info - signed ; True if minimum value negative. - size ; Minimum number of bits needed to hold value. - from ; Symbol holding alist from keywords to integers. - to ; Symbol holding 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. - - -;;; Condition structures: - -(in-package "CONDITIONS") - -(defstruct (condition (:constructor |constructor for condition|) - (:predicate nil) - (:print-function condition-print)) - ) diff --git a/code/symbol.lisp b/code/symbol.lisp deleted file mode 100644 index 8c1870872400fb0e0fa2a38fe4870e7d35584f9c..0000000000000000000000000000000000000000 --- a/code/symbol.lisp +++ /dev/null @@ -1,192 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; 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)) - -(defun set (variable new-value) - "VARIABLE must evaluate to a symbol. This symbol's special value cell is - set to the specified new value." - (set variable new-value)) - -(defun makunbound (variable) - "VARIABLE must evaluate to a symbol. This symbol is made unbound, - removing any value it may currently have." - (makunbound variable)) - -(defun symbol-value (variable) - "VARIABLE must evaluate to a symbol. This symbol's current special - value is returned." - (symbol-value variable)) - -(defun symbol-function (variable) - "VARIABLE must evaluate to a symbol. This symbol's current definition - is returned." - (symbol-function variable)) - -(defun %sp-set-definition (symbol new-value) - (setf (symbol-function symbol) new-value)) - -(defun boundp (variable) - "VARIABLE must evaluate to a symbol. Return () if this symbol is - unbound, T if it has a value." - (boundp variable)) - -(defun symbol-plist (variable) - "VARIABLE must evaluate to a symbol. Return its property list." - (symbol-plist variable)) - -(defun %sp-set-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 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." - (%primitive put symbol indicator value) -#| (do ((pl (symbol-plist symbol) (cddr pl))) - ((atom pl) - (setf (symbol-plist symbol) - (list* indicator value (symbol-plist symbol))) - value) - (cond ((atom (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 (x y z) - (%primitive putf x y z)) - - -(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." - (let* ((*print-base* 10) - (*print-radix* nil) - (*print-pretty* nil) - (prefix (if (stringp string) string "G")) - (number (prin1-to-string (if (numberp string) - string - (incf *gensym-counter*))))) - (make-symbol (concatenate 'simple-string prefix number)))) - -(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 *gensym-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/sysmacs.lisp b/code/sysmacs.lisp deleted file mode 100644 index 95693b1a23b3a50ef5ee8cd2ba3387328ec8e60d..0000000000000000000000000000000000000000 --- a/code/sysmacs.lisp +++ /dev/null @@ -1,274 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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). -;;; ********************************************************************** -;;; -;;; Miscellaneous system hacking macros. -;;; -(in-package "LISP" :use '("SYSTEM" "DEBUG")) - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* t)) - -;;; WITH-ARRAY-DATA follows an arbitrarily long chain of displaced arrays -;;; binding data-var to the data vector, offset-var to the cumulative -;;; displacement offset, start-var to the actual start index in the data -;;; vector, and end-var to the actual end of the data vector. Put all the -;;; bindings in the LET, so declarations can be made on the variables (for -;;; example, declaring data-var to be a simple-string. -(defmacro with-array-data (((data-var array &key (offset-var (gensym))) - (start-var &optional (svalue 0)) - (end-var &optional (evalue nil))) - &rest forms) - "Bind data-var to the data-vector eventually reached by following displacement - links from array, offset-var to a cumulative offset, start-var to the first - index in the data vector, and end-var to the total length of the array plus - the cumulative offset. Offset-var, start-var, and end-var are declared to be - fixnums." - `(multiple-value-bind (,data-var ,offset-var) - (find-data-vector ,array) - (let* ((,data-var ,data-var) - (,offset-var ,offset-var) - (,start-var (+ ,svalue ,offset-var)) - (,end-var (+ ,offset-var (or ,evalue (array-total-size ,array))))) - (declare (fixnum ,offset-var ,start-var ,end-var)) - ,@forms))) - - -(defmacro %displacedp (array-header) - `(= (the fixnum (%primitive get-vector-subtype ,array-header)) - (the fixnum %array-displaced-subtype))) - -(defmacro %set-array-displacedp (array-header value) - `(%primitive set-vector-subtype ,array-header - (if ,value %array-displaced-subtype %array-normal-subtype))) - - -(defmacro without-gcing (&rest body) - "Executes the forms in the body without doing a garbage collection." - `(multiple-value-prog1 - (let ((*gc-inhibit* t)) - ,@body) - (when (and *need-to-collect-garbage* (not *gc-inhibit*)) - (maybe-gc nil)))) - - -(defmacro with-interrupts (&body body) - `(let ((iin %sp-interrupts-inhibited)) - (setq %sp-interrupts-inhibited NIL) - (when (consp iin) - (dolist (x iin) - (let ((f (svref *software-interrupt-vector* (car x)))) - (when f (apply f x))))) - (unwind-protect - (progn ,@body) - (if iin (setq %sp-interrupts-inhibited T))))) - -(defmacro without-interrupts (&rest body) - "Evaluates the forms in the Body without allowing interrupts." - `(let* ((old-interrupts-inhibited %sp-interrupts-inhibited) - (%sp-interrupts-inhibited (or %sp-interrupts-inhibited T))) - (multiple-value-prog1 - (progn ,@body) - (when (and (null old-interrupts-inhibited) - (consp %sp-interrupts-inhibited)) - (dolist (x %sp-interrupts-inhibited) - (let ((f (svref *software-interrupt-vector* (car x)))) - (when f (apply f x)))))))) - - -(defmacro with-enabled-interrupts (interrupt-list &body body) - "With-enabled-interrupts ({(interrupt function [character])}*) {form}* - Establish function as a handler for the Unix signal interrupt which - should be a number between 1 and 31 inclusive. For the signals that - can be generated from the keyboard, the optional character specifies - the character to use to generate the signal." - (let ((il (gensym)) - (fn (gensym)) - (ch (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)) - (ichr (caddar item) (caddar item)) - (forms NIL)) - ((null item) (nreverse forms)) - (if (symbolp intr) - (setq intr (symbol-value intr))) - (push `(multiple-value-bind (,fn ,ch) - (enable-interrupt ,intr ,ifcn - ,ichr) - (push `(,,intr ,,fn ,,ch) ,il)) forms)) - ,@body) - (dolist (,it (nreverse ,il)) - (funcall #'enable-interrupt (car ,it) (cadr ,it) (caddr ,it))))))) - - -(defvar hi::*in-the-editor* nil) - -(defmacro without-hemlock (&body body) - `(progn - (when (and hi::*in-the-editor* (null debug::*in-the-debugger*)) - (let ((device (hi::device-hunk-device - (hi::window-hunk (hi::current-window))))) - (funcall (hi::device-exit device) device))) - ,@body - (when (and hi::*in-the-editor* (null debug::*in-the-debugger*)) - (let ((device (hi::device-hunk-device - (hi::window-hunk (hi::current-window))))) - (funcall (hi::device-init device) device))))) - - -;;; With-Reply-Port -- Public -;;; -;;; If we find that the number of ports in use (as indicated by -;;; *reply-port-pointer*) disagrees with our dynamic depth in -;;; With-Reply-Port forms (as indicated by *reply-port-depth*), -;;; then we must have been unwound at some point in the past. -;;; We reallocate the ports that were in use when we were -;;; unwound, since they may have random messages hanging on them. -;;; -(defmacro with-reply-port ((var) &body body) - "With-Reply-Port (Var) {Form}* - Binds Var to a port during the evaluation of the Forms." - (let ((index (gensym)) - (old-flag (gensym)) - (res (gensym))) - `(let ((,old-flag %sp-interrupts-inhibited) - ,res) - (without-interrupts - (let* ((,index *reply-port-depth*) - (*reply-port-depth* (1+ ,index)) - ,var) - (unless (eql ,index *reply-port-pointer*) - (reallocate-reply-ports ,index)) - (setq ,var (svref *reply-port-stack* ,index)) - (setq *reply-port-pointer* (1+ ,index)) - (unless ,var (setq ,var (allocate-new-reply-ports))) - (setq %sp-interrupts-inhibited ,old-flag) - (setq ,res (multiple-value-list (progn ,@body))) - (when (eql (car ,res) mach:rcv-timed-out) - (gr-call mach:port_deallocate *task-self* ,var) - (setf (svref *reply-port-stack* ,index) - (gr-call* mach:port_allocate *task-self*))) - (setq %sp-interrupts-inhibited (or ,old-flag T)) - (if (eql ,index (1- *reply-port-pointer*)) - (setq *reply-port-pointer* ,index) - (reallocate-reply-ports (1+ ,index))) - (values-list ,res)))))) - - -;;; Eof-Or-Lose is a useful macro that handles EOF. - -(defmacro eof-or-lose (stream eof-errorp eof-value) - `(if ,eof-errorp - (error "~S: Stream hit EOF unexpectedly." ,stream) - ,eof-value)) - -;;; These macros handle the special cases of t and nil for input and -;;; output streams. -;;; -(defmacro in-synonym-of (stream) - (let ((svar (gensym))) - `(let ((,svar ,stream)) - (cond ((null ,svar) *standard-input*) - ((eq ,svar t) *terminal-io*) - (t (check-type ,svar stream) - ,svar))))) - -(defmacro out-synonym-of (stream) - (let ((svar (gensym))) - `(let ((,svar ,stream)) - (cond ((null ,svar) *standard-output*) - ((eq ,svar t) *terminal-io*) - (T (check-type ,svar stream) - ,svar))))) - -;;; With-Mumble-Stream calls the function in the given Slot of the Stream with -;;; the Args. -;;; -(defmacro with-in-stream (stream slot &rest args) - `(let ((stream (in-synonym-of ,stream))) - (funcall (,slot stream) stream ,@args))) - -(defmacro with-out-stream (stream slot &rest args) - `(let ((stream (out-synonym-of ,stream))) - (funcall (,slot stream) stream ,@args))) - - -;;;; These are hacks to make the reader win. - -;;; Prepare-For-Fast-Read-Char -- Internal -;;; -;;; This macro sets up some local vars for use by the Fast-Read-Char -;;; macro within the enclosed lexical scope. -;;; -(defmacro prepare-for-fast-read-char (stream &body forms) - `(let* ((%frc-stream% (in-synonym-of ,stream)) - (%frc-method% (stream-in %frc-stream%)) - (%frc-buffer% (stream-in-buffer %frc-stream%)) - (%frc-index% (stream-in-index %frc-stream%))) - (declare (type (or simple-string null) %frc-buffer%) (fixnum %frc-index%)) - ,@forms)) - -;;; Done-With-Fast-Read-Char -- Internal -;;; -;;; This macro must be called after one is done with fast-read-char -;;; inside it's scope to decache the stream-in-index. -;;; -(defmacro done-with-fast-read-char () - `(setf (stream-in-index %frc-stream%) %frc-index%)) - -;;; Fast-Read-Char -- Internal -;;; -;;; This macro can be used instead of Read-Char within the scope of -;;; a Prepare-For-Fast-Read-Char. -;;; -(defmacro fast-read-char (&optional (eof-errorp t) (eof-value ())) - `(cond - ((= %frc-index% in-buffer-length) - (setf (stream-in-index %frc-stream%) %frc-index%) - (prog1 (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value) - (setq %frc-index% (stream-in-index %frc-stream%)))) - (t - (prog1 (aref %frc-buffer% %frc-index%) - (incf %frc-index%))))) - -;;;; And these for the fasloader... - -;;; Prepare-For-Fast-Read-Byte -- Internal -;;; -;;; Just like Prepare-For-Fast-Read-Char except that we get the Bin -;;; method. -;;; -(defmacro prepare-for-fast-read-byte (stream &body forms) - `(let* ((%frc-stream% (in-synonym-of ,stream)) - (%frc-method% (stream-bin %frc-stream%)) - (%frc-buffer% (stream-in-buffer %frc-stream%)) - (%frc-index% (stream-in-index %frc-stream%))) - (declare (type (or simple-array null) %frc-buffer%) (fixnum %frc-index%)) - ,@forms)) - -;;; Fast-Read-Byte, Done-With-Fast-Read-Byte -- Internal -;;; -;;; Identical to the text versions, but we get some gratuitous -;;; psuedo-generality by having different names. -;;; -(defmacro done-with-fast-read-byte () - `(done-with-fast-read-char)) -;;; -(defmacro fast-read-byte (&rest stuff) - `(fast-read-char ,@stuff)) - - -#-new-compiler -(eval-when (compile) - (setq lisp::*bootstrap-defmacro* nil)) diff --git a/code/time.lisp b/code/time.lisp deleted file mode 100644 index 0b99f9bb19c337daf9b2172b72f6116985b6b386..0000000000000000000000000000000000000000 --- a/code/time.lisp +++ /dev/null @@ -1,383 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 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.") - -(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))))) - -;;; 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." - (let ((val (system:%primitive get-real-time))) - (when (eq val -1) - (error "Failed to get real time.")) - val)) - -#| -(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." - (multiple-value-bind (result seconds useconds) (mach:unix-gettimeofday) - (if result (+ (* seconds internal-time-units-per-second) useconds) - (error "Unix system call gettimeofday failed: ~A" - (mach:get-unix-error-msg seconds))))) -|# - -;;; Get-Internal-Run-Time -- Public -;;; -;;; PmGetTimes returns run time in microseconds. Convert to jiffies. -;;; -(defun get-internal-run-time () - "Return the run time in the internal time format. This is useful for - finding CPU usage." - (let ((val (system:%primitive get-run-time))) - (when (eq val -1) - (error "Failed to obtain run time.")) - val)) - -#| -(defun get-internal-run-time () - "Return the run time in the internal time format. This is useful for - finding CPU usage." - (multiple-value-bind (result utime stime) - (mach:unix-getrusage mach:rusage_self) - (if result (+ utime stime) - (error "Unix system call getrusage failed: ~A" - (mach:get-unix-error-msg utime))))) -|# - -;;; 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) (mach: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) - (mach: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) (mach: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)))) - -(defmacro time (form) - "Evaluates the Form and prints timing information on *Trace-Output*." - `(%time #'(lambda () ,form))) - -(defun %time (fun) - (let (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-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq old-run-utime utime) - (setq old-run-stime stime)))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_allocate gr) - (setq old-page-faults pf)) - (setq old-bytes-consed (get-bytes-consed)) - ;; Do it a second time to make sure everything is faulted in. - (multiple-value-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq old-run-utime utime) - (setq old-run-stime stime)))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_statistics gr) - (setq old-page-faults pf)) - (setq old-bytes-consed (get-bytes-consed)) - - (multiple-value-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq new-run-utime utime) - (setq new-run-stime stime)))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_statistics gr) - (setq new-page-faults pf)) - (setq new-bytes-consed (get-bytes-consed)) - - (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-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq old-run-utime utime) - (setq old-run-stime stime)))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_statistics gr) - (setq old-page-faults pf)) - (setq old-real-time (get-internal-real-time)) - (setq old-bytes-consed (get-bytes-consed)) - (multiple-value-prog1 - ;; Execute the form and return its values. - (funcall fun) - (multiple-value-bind (err? utime stime) - (mach:unix-getrusage mach:rusage_self) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (mach:get-unix-error-msg utime))) - (T (setq new-run-utime (- utime run-utime-overhead)) - (setq new-run-stime (- stime run-stime-overhead))))) - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra in ot)) - (gr-error 'mach:vm_statistics gr) - (setq new-page-faults (- pf page-faults-overhead))) - (setq new-real-time (- (get-internal-real-time) real-time-overhead)) - (setq new-bytes-consed (- (get-bytes-consed) cons-overhead)) - (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~% ~ - ~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) - (max (- new-page-faults old-page-faults) 0) - (max (- new-bytes-consed old-bytes-consed) 0))))) diff --git a/code/tty-inspect.lisp b/code/tty-inspect.lisp deleted file mode 100644 index e3c3e4acfa18a7fd858e713b209f9f602a5572cd..0000000000000000000000000000000000000000 --- a/code/tty-inspect.lisp +++ /dev/null @@ -1,217 +0,0 @@ -;;; -*- Log: code.log; Package: inspect -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Tty interface for INSPECT. -;;; -;;; Written by Blaine Burks - -;;; -(in-package "INSPECT") - -;;; The Tty inspector views LISP objects as being composed of parts. A list, -;;; for example, would be divided into it's members, and a structure into its -;;; slots. These parts are stored in a list. The first two elements of this -;;; list are for bookkeeping. The first element is a preamble string that will -;;; be displayed before the object. The second element is a boolean value that -;;; indicates whether a label will be printed in front of a value, or just the -;;; value. Symbols and structures need to display both a slot name and a -;;; value, while lists, vectors, and atoms need only display a value. If the -;;; second member of a parts list is t, then the third and successive members -;;; must be an association list of slot names and values. When the second slot -;;; is nil, the third and successive slots must be the parts of an object. -;;; - -;;; *tty-object-stack* is an assoc list of objects to their parts. -;;; -(defvar *tty-object-stack* ()) - -(proclaim '(inline numbered-parts-p)) -(defun numbered-parts-p (parts) - (second parts)) - -(defconstant parts-offset 2) - -(defun nth-parts (parts n) - (if (numbered-parts-p parts) - (cdr (nth (+ n parts-offset) parts)) - (nth (+ n parts-offset) parts))) - -(defun tty-inspect (object) - (unwind-protect - (input-loop object (describe-parts object) *standard-output*) - (setf *tty-object-stack* nil))) - -;;; When %illegal-object% occurs in a parts list, it indicates that that slot -;;; is unbound. -(defvar %illegal-object% (cons nil nil)) - -(defun input-loop (object parts s) - (tty-display-object parts s) - (loop - (format s "~&> ") - (let ((command (read)) - ;; Use 2 less than length because first 2 elements are bookkeeping. - (parts-len-2 (- (length parts) 2))) - (typecase command - (integer - (cond ((< -1 command parts-len-2) - (cond ((eq (nth-parts parts command) %illegal-object%) - (format s "~%That slot is unbound.~%")) - (t - (push (cons object parts) *tty-object-stack*) - (setf object (nth-parts parts command)) - (setf parts (describe-parts object)) - (tty-display-object parts s)))) - (t - (if (= parts-len-2 0) - (format s "~%This object contains nothing to inspect.~%~%") - (format s "~%Enter a VALID number (~:[0-~D~;0~]).~%~%" - (= parts-len-2 1) (1- parts-len-2)))))) - (symbol - (case (find-symbol (symbol-name command) (find-package "KEYWORD")) - ((:q :e) - (return object)) - (:u - (cond (*tty-object-stack* - (setf object (caar *tty-object-stack*)) - (setf parts (cdar *tty-object-stack*)) - (pop *tty-object-stack*) - (tty-display-object parts s)) - (t (format s "~%Bottom of Stack.~%")))) - (:r - (setf parts (describe-parts object)) - (tty-display-object parts s)) - (:d - (tty-display-object parts s)) - ((:h :? :help) - (show-help s)) - (t - (do-tty-inspect-eval command s)))) - (t - (do-tty-inspect-eval command s)))))) - -(defun do-tty-inspect-eval (command stream) - (let ((result-list (restart-case (multiple-value-list (eval command)) - (nil () :report "Return to the TTY-INSPECTOR" - (format stream "~%Returning to INPSECTOR.~%") - (return-from do-tty-inspect-eval nil))))) - (setf /// // // / / result-list) - (setf +++ ++ ++ + + - - command) - (setf *** ** ** * * (car /)) - (format stream "~&~{~S~%~}" /))) - -(defun show-help (s) - (terpri) - (write-line "TTY-Inspector Help:" s) - (write-line " R - recompute current object." s) - (write-line " D - redisplay current object." s) - (write-line " U - Move upward through the object stack." s) - (write-line " Q, E - Quit TTY-INSPECTOR." s) - (write-line " ?, H, Help - Show this help." s)) - -(defun tty-display-object (parts stream) - (format stream "~%~a" (car parts)) - (let ((numbered-parts-p (numbered-parts-p parts)) - (parts (cddr parts))) - (do ((part parts (cdr part)) - (i 0 (1+ i))) - ((endp part) nil) - (if numbered-parts-p - (format stream "~d. ~a: ~a~%" i (caar part) - (if (eq (cdar part) %illegal-object%) - "Unbound" - (cdar part))) - (format stream "~d. ~a~%" i (car part)))))) - - - -;;;; DESCRIBE-PARTS - -(defun describe-parts (object) - (typecase object - (symbol (describe-symbol-parts object)) - (structure (describe-structure-parts object)) - (function (describe-function-parts object)) - (vector (describe-vector-parts object)) - (array (describe-array-parts object)) - (cons (describe-cons-parts object)) - (t (describe-atomic-parts object)))) - -(defun describe-symbol-parts (object) - (list (format nil "~s is a symbol.~%" object) t - (cons "Value" (if (boundp object) - (symbol-value object) - %illegal-object%)) - (cons "Function" (if (fboundp object) - (symbol-function object) - %illegal-object%)) - (cons "Plist" (symbol-plist object)) - (cons "Package" (symbol-package object)))) - -(defun describe-structure-parts (object) - (let ((dd-slots - (c::dd-slots - (ext:info type defined-structure-info - (system:%primitive header-ref object - system:%g-vector-structure-name-slot)))) - (parts-list ())) - (push (format nil "~s is a structure.~%" object) parts-list) - (push t parts-list) - (dolist (dd-slot dd-slots (nreverse parts-list)) - (push (cons (c::dsd-%name dd-slot) - (system:%primitive header-ref object (c::dsd-index dd-slot))) - parts-list)))) - -(defun describe-function-parts (object) - (let ((object (if (= (system:%primitive get-vector-subtype object) - system:%function-closure-subtype) - (system:%primitive header-ref object - system:%function-name-slot) - object))) - (list (format nil "Function ~s.~%Argument List: ~a." object - (system:%primitive header-ref object - lisp::%function-entry-arglist-slot) - #|### - (system:%primitive header-ref object - lisp::%function-defined-from-slot) - ~%Defined from: ~a - |# - ) - t))) - -(defun describe-vector-parts (object) - (list* (format nil "Object is a ~:[~;displaced ~]vector of length ~d.~%" - (lisp::%displacedp object) (length object)) - nil - (coerce object 'list))) - -(defun describe-cons-parts (object) - (list* (format nil "Object is a LIST of length ~d.~%" (length object)) - nil - object)) - -(defun describe-array-parts (object) - (let* ((length (min (array-total-size object) inspect-length)) - (reference-array (make-array length :displaced-to object)) - (dimensions (array-dimensions object)) - (parts ())) - (push (format nil "Object is ~:[a displaced~;an~] array of ~a.~%~ - Its dimensions are ~s.~%" - (array-element-type object) (lisp::%displacedp object) - dimensions) - parts) - (push t parts) - (dotimes (i length (nreverse parts)) - (push (cons (format nil "~a " (index-string i (reverse dimensions))) - (aref reference-array i)) - parts)))) - -(defun describe-atomic-parts (object) - (list (format nil "Object is an atom.~%") nil object)) - diff --git a/code/type-boot.lisp b/code/type-boot.lisp deleted file mode 100644 index e9d8f765c850af9fd8c9a7b44f8de1a16c8bfc08..0000000000000000000000000000000000000000 --- a/code/type-boot.lisp +++ /dev/null @@ -1,52 +0,0 @@ -;;; -*- Log: code.log; Package: C -*- -;;; -;;; ********************************************************************** -;;; 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 initialization hacks that we need to get the type system started up -;;; enough so that we can define the types used to define types. -;;; -(in-package "C") - -;;; Make these types be sort-of-defined to allow bootstrapping. -(setf (info type defined-structure-info 'defstruct-description) - (make-defstruct-description)) - -(setf (info type defined-structure-info 'defstruct-slot-description) - (make-defstruct-description)) - - -;;; Define this now so that EQUAL works: -;;; -(defun pathnamep (x) - (and (structurep x) - (eq (%primitive structure-ref x 0) - 'pathname))) - -;;; Define so that we can test for VOLATILE-INFO-ENVs from the beginning of -;;; initialization. -;;; -(defun volatile-info-env-p (x) - (and (structurep x) - (eq (%primitive structure-ref x 0) - 'volatile-info-env))) - - -(deftype inlinep () - '(member :inline :maybe-inline :notinline nil)) - -(deftype boolean () - '(member t nil)) - -;;; Define this so that we can define the type system. -(in-package "KERNEL") -(defun ctype-p (thing) - (and (structurep thing) - (member (%primitive structure-ref thing 0) - '(ctype hairy-type named-type numeric-type array-type - member-type structure-type union-type args-type - values-type function-type)))) diff --git a/code/wire.lisp b/code/wire.lisp deleted file mode 100644 index 46bf5792a4cdd9ae2d91745cb45f94ab0b8b05f6..0000000000000000000000000000000000000000 --- a/code/wire.lisp +++ /dev/null @@ -1,622 +0,0 @@ -;;; -*- Log: code.log; Package: wire -*- -;;; -;;; ********************************************************************** -;;; 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 an interface to internet domain sockets. -;;; -;;; Written by William Lott. -;;; - -(in-package "WIRE") - -(export '(remote-object-p 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*)) - - -(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) - -) ;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 "using") - (msg "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* (mach:unix-gethostid)) - (setf *this-pid* (mach: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* (mach:unix-gethostid)) - (setf *this-pid* (mach: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) - (mach: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 (mach: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) - (mach:unix-read fd ibuf buffer-size) - (cond ((null bytes) - (error 'wire-io-error - :wire wire - :when "reading" - :msg (mach: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)) - (- #x100000000 unsigned) - unsigned))) - -;;; 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 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 mach: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) - (mach:unix-write ,fd ,string 0 ,(or end length)) - (cond ((null ,result) - (error 'wire-io-error - :wire wire - :when "writing" - :msg (mach: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) - (int-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-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 - (wire-output-byte wire number-op) - (wire-output-number 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 c059d0b614f8db08f4a528639b7218291125f1a9..0000000000000000000000000000000000000000 --- a/compiler/aliencomp.lisp +++ /dev/null @@ -1,830 +0,0 @@ -;;; -*- Log: C.Log; Package: C -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains transforms and other stuff used to compile Alien -;;; definitions. There are two main parts: A fairly general numeric -;;; constant-folding facility, and the transforms that implement the -;;; the Alien primitives. -;;; -;;; -(in-package 'c) - -(in-package 'lisp) -(import '( - ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size - ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien - check<= check= %alien-indirect %aligned-sap - naturalize-integer deport-integer naturalize-boolean deport-boolean - sap-ref-8 sap-ref-16 sap-ref-32 - signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 - %set-alien-access - - *alien-eval-when* make-alien alien-type alien-size alien-address - copy-alien dispose-alien defalien alien-value - alien-bind defoperator alien-index alien-indirect - bits bytes words long-words port perq-string - boolean defenumeration enumeration - system-area-pointer pointer alien alien-access - alien-assign alien-sap define-alien-stack - with-stack-alien null-terminated-string c-procedure - record-size - ) - (find-package "C")) - -(in-package 'c) - - -;;;; Pre-pass: -;;; -;;; We do a pre-pass over Alien expressions at source-transformation time. -;;; This pass does compile-time Alien type checking, and also composes the -;;; Alien operators, producing separate expressions that compute the address, -;;; type and total offset and size of the expression. - - -;;; Analyze-Alien-Expression -- Internal -;;; -;;; This function grovels an alien expression and return a bunch of values -;;; that tell how to evaluate the thing. Result-Type is the alien-type that -;;; the expression must evaluate to. The values returned are: -;;; 0] A list of let*-bindings that need to be made. -;;; 1] Some stuff that should be evaluated within the bindings. This -;;; stuff is error-checks and stuff like that. This is in reverse -;;; order. -;;; 2] A ct-a-val structure describing the size, sap and offset. -;;; -;;; If the expression is not of the correct type or is somehow malformed, then -;;; we call Compiler-Error, which aborts out. If the expression cannot be -;;; shown to be of the correct type then a runtime check is generated. When -;;; Result-Type is Nil we don't pay any attention to the type. -;;; -(defun analyze-alien-expression (result-type exp) - (if (atom exp) - (if (and (symbolp exp) - (or (ct-a-val-p (cdr (assoc exp *venv*))) - (info variable alien-value exp))) - (grovel-alien-var result-type exp) - (grovel-random-alien result-type exp)) - (let* ((fun (car exp)) - (info (info function alien-operator fun))) - (cond - ((eq fun 'alien-value) - (grovel-alien-var result-type (cadr exp))) - ((eq fun 'alien-index) - (when result-type - (compiler-error "Alien-Index used where a type is required:~% ~S" - exp)) - (grovel-alien-index exp)) - ((eq fun 'alien-indirect) - (when result-type - (compiler-error "Alien-Indirect used where a type is required:~% ~S" - exp)) - (grovel-alien-indirect exp)) - (info - (grovel-alien-operator result-type exp info)) - (t - (grovel-random-alien result-type exp)))))) - - -;;; Ignore-Unreferenced-Vars -- Internal -;;; -;;; Return an Ignorable declaration for all of the vars in the let-binding -;;; list Binds. -;;; -(defun ignore-unreferenced-vars (binds) - (declare (list binds)) - `(declare (ignorable ,@(mapcar #'car binds)))) - - -;;; Grovel-Alien-Index -- Internal -;;; -;;; Analyze a call to Alien-Index, a la Analyze-Alien-Expression. We -;;; throw a call to Check-Alien-Bounds into the Stuff to do the bounds -;;; checking. -;;; -(defun grovel-alien-index (exp) - (unless (= (length exp) 4) - (compiler-error "Wrong number of arguments to Alien-Index:~% ~S" exp)) - - (multiple-value-bind (binds stuff res) - (analyze-alien-expression nil (second exp)) - (let* ((offset (ct-a-val-offset res)) - (noffset `(+ ,offset ,(third exp))) - (size (ct-a-val-size res)) - (nsize (fourth exp))) - (values - binds - `((check<= (+ ,noffset ,nsize) (+ ,offset ,size)) - ,@stuff) - (make-ct-a-val - :sap (ct-a-val-sap res) - :offset noffset - :size nsize))))) - - -;;; Grovel-Alien-Indirect -- Internal -;;; -;;; Handle an Alien-Indirect. We transform to a %Alien-Indirect that looks -;;; at the offset and size. If the offset is long-word aligned and the size is -;;; 32, then we transform to a SAP-System-Ref, otherwise we give up and allow -;;; the error check to be done at run-time. -;;; -(defun grovel-alien-indirect (exp) - (unless (= (length exp) 3) - (compiler-error "Wrong number of arguments to Alien-Indirect:~% ~S" exp)) - - (multiple-value-bind (binds stuff res) - (analyze-alien-expression nil (second exp)) - (values - binds - stuff - (make-ct-a-val - :sap `(%alien-indirect ,(ct-a-val-size res) - ,(ct-a-val-sap res) - ,(ct-a-val-offset res) - ',exp) - :offset 0 - :size (third exp))))) - -(defknown %alien-indirect (index t index t) t (flushable)) - -(deftransform %alien-indirect ((size sap offset exp)) - (unless (>= (find-alignment offset) 5) - (give-up "Offset may not be long-word aligned:~% ~S" - (continuation-value exp))) - - (unless (and (constant-continuation-p size) - (eql (continuation-value size) 32)) - (give-up "Size may not be 32:~% ~S" (continuation-value exp))) - - '(%primitive sap-system-ref sap (ash offset -4))) - - -;;; Grovel-Alien-Var -- Internal -;;; -;;; Look the var up in *venv*, and then check if it is a global -;;; alien-variable. If it ain't there or is the the wrong type then flame out. -;;; -(defun grovel-alien-var (type var) - (let* ((local-def (cdr (assoc var *venv*))) - (res (cond ((ct-a-val-p local-def) local-def) - ((or (not local-def) - (and (global-var-p local-def) - (eq (global-var-kind local-def) :special))) - (info variable alien-value var)) - (t - (compiler-error "Not an Alien variable: ~S." var))))) - (unless res - (compiler-error "Undefined Alien variable: ~S" var)) - (when (and type (not (equal (ct-a-val-type res) type))) - (compiler-error "Alien type of ~S is ~S, not ~S." - var (ct-a-val-type res) type)) - - (values () () res))) - - -;;; Grovel-Alien-Operator -- Internal -;;; -;;; Handle a call to an alien operator. Analyze each Alien valued argument, -;;; throwing the result on *aenv* during the processing of the body. We always -;;; bind lisp arguments, letting the optimizer do any cleverness. All we do to -;;; the body is strip off any stuff if there is a progn, and then call -;;; Analyze-Alien-Expression on the body with Nil as the result-type. -;;; -(defun grovel-alien-operator (type exp info) - (unless (or (not type) - (equal (lisp::alien-info-result-type info) type)) - (compiler-error "Does not result in a ~S alien value:~% ~S" type exp)) - - (unless (= (lisp::alien-info-num-args info) (length (cdr exp))) - (compiler-error "Alien operator not called with ~D args:~% ~S" - (lisp::alien-info-num-args info) exp)) - - (do* ((args (cdr exp) (cdr args)) - (dums ()) - (*venv* *venv*) - (num 0 (1+ num)) - (types (lisp::alien-info-arg-types info)) - (atype (cdr (assoc num types)) (cdr (assoc num types))) - (stuff ()) - (binds ())) - ((null args) - (let ((body (apply (lisp::alien-info-function info) - (nreverse dums)))) - (when (and (consp body) - (eq (car body) 'progn)) - (push (butlast body) stuff) - (setq body (car (last body)))) - (multiple-value-bind (b s r) - (analyze-alien-expression nil body) - (when r - (setq r (make-ct-a-val - :type (lisp::alien-info-result-type info) - :sap (ct-a-val-sap r) - :offset (ct-a-val-offset r) - :size (ct-a-val-size r)))) - (values - (nconc b binds) - (nconc s stuff) - r)))) - (declare (list dums)) - (cond (atype - (multiple-value-bind (b s val) - (analyze-alien-expression atype (car args)) - (setq binds (nconc binds b) stuff (nconc stuff s)) - (unless val (return nil)) - (let ((var (gensym))) - (push (cons var val) *venv*) - (push var dums)))) - (t - (let ((var (gensym))) - (push var dums) - (setq binds (nconc binds `((,var ,(car args)))))))))) - - -;;; Grovel-Random-Alien -- Internal -;;; -;;; Flame out if the form is some random atom, otherwise bind a var -;;; to Check-Alien-Type of it, and return forms to access the fields -;;; of the Alien-Value. -;;; -(defun grovel-random-alien (type exp) - (when (and (atom exp) (not (symbolp exp))) - (compiler-error "~S is a bad thing to be an Alien-Value." exp)) - (cond ((and (symbolp exp) (info variable alien-value exp)) - (values () () (info variable alien-value exp))) - (t - (when (policy nil (> speed brevity)) - (compiler-note "Not a known Alien expression:~% ~S." exp)) - - (let ((var (gensym)) - (sap (gensym)) - (size (gensym)) - (offset (gensym))) - (values - `((,sap (lisp::alien-value-sap ,var)) - (,offset (lisp::alien-value-offset ,var)) - (,size (lisp::alien-value-size ,var)) - (,var ,(if type - `(lisp::check-alien-type ,exp ',type) - exp))) - () - (make-ct-a-val - :type type - :sap sap - :offset offset - :size size - :alien var)))))) - - -;;;; Miscellaneous internal frobs: - -(defknown sap+ (t t) t (movable flushable)) -(deftransform sap+ ((sap offset)) - (unless (and (constant-continuation-p offset) - (eql (continuation-value offset) 0)) - (give-up)) - 'sap) - -(defknown sap-int (t) unsigned-byte (movable flushable)) -(defknown int-sap (unsigned-byte) t (movable flushable)) - -(defknown %aligned-sap (t t t) t (movable flushable)) -(deftransform %aligned-sap ((sap offset form)) - (unless (> (find-alignment offset) 3) - (give-up)) - '(sap+ sap offset)) - -(defknown (check<= check=) (index index) void (movable)) - -;;; Compile-Time-Check -- Internal -;;; -;;; If the operands are constant, then test them using OP. If it succeeds, -;;; transform to NIL, otherwise warn and give-up. -;;; -(defun compile-time-check (x y op) - (unless (and (constant-continuation-p x) - (constant-continuation-p y)) - (give-up)) - (let ((x (continuation-value x)) - (y (continuation-value y))) - (unless (funcall (symbol-function op) x y) - (compiler-warning "~S not ~S to ~S at compile time." x op y) - (give-up))) - 'nil) - -(deftransform check<= ((x y)) (compile-time-check x y '<=)) -(deftransform check= ((x y)) (compile-time-check x y '=)) - -(defknown record-size (symbol) index (movable foldable flushable)) - -(defknown sap-ref-8 (t index) (unsigned-byte 8) (flushable)) -(defknown sap-ref-16 (t index) (unsigned-byte 16) (flushable)) -(defknown sap-ref-32 (t index) (unsigned-byte 32) (flushable)) -(defknown (setf sap-ref-8) (t index (unsigned-byte 8)) (unsigned-byte 8) ()) -(defknown (setf sap-ref-16) (t index (unsigned-byte 16)) (unsigned-byte 16) ()) -(defknown (setf sap-ref-32) (t index (unsigned-byte 32)) (unsigned-byte 32) ()) - - -;;;; Alien variable special forms: - -;;; Alien-Bind IR1 convert -- Internal -;;; -(def-ir1-translator alien-bind ((binds &body body &whole source) start cont) - (let ((*venv* *venv*)) - (collect ((lets nil nconc) - (stuff nil nconc)) - (dolist (bind binds) - (unless (<= 2 (length bind) 4) - (compiler-error "Malformed Alien-Bind specifier:~% ~S" bind)) - (let ((var (first bind)) - (val (second bind)) - (typ (third bind)) - (aligned (fourth bind))) - - (multiple-value-bind (l s res) - (analyze-alien-expression typ val) - (unless (ct-a-val-type res) - (compiler-error "Must specify type, since it is not apparent ~ - from the value:~% ~S" bind)) - (lets l) - (stuff s) - (let* ((offset (ct-a-val-offset res)) - (sap (ct-a-val-sap res)) - (size (ct-a-val-size res)) - (n-size (gensym)) - (n-sap (gensym)) - (n-offset (gensym))) - (lets `((,n-sap ,(if aligned - `(%aligned-sap ,sap ,offset ',source) - sap)) - (,n-size ,size) - (,n-offset ,(if aligned 0 offset)))) - - (push (cons var - (make-ct-a-val :type (ct-a-val-type res) - :offset (if aligned 0 n-offset) - :size n-size - :sap n-sap - :alien (ct-a-val-alien res))) - *venv*))))) - - (ir1-convert start cont - `(let* ,(reverse (lets)) - ,(ignore-unreferenced-vars (lets)) - ,@(nreverse (stuff)) - ,@body))))) - - -;;; With-Stack-Alien-Transform -- Internal -;;; -;;; -(def-ir1-translator with-stack-alien (((var stack) &body forms) start cont) - (let ((info (info alien-stack info stack))) - (unless info - (compiler-error "~S is not the name of a declared alien stack." stack)) - - (let* ((n-current (lisp::stack-info-current info)) - (n-sap (gensym)) - (n-alien (gensym)) - (*venv* (acons var - (make-ct-a-val :type (lisp::stack-info-type info) - :size (lisp::stack-info-size info) - :sap n-sap - :offset 0 - :alien n-alien) - *venv*))) - (ir1-convert start cont - `(let* ((,n-alien (or (car ,n-current) - (,(lisp::stack-info-grow info)))) - (,n-sap (lisp::alien-value-sap ,n-alien)) - (,n-current (cdr ,n-current))) - ,@forms))))) - - -;;;; Transforms for basic Alien accessors. -;;; -;;; Open-coding these guys is probably worthwhile, since they are used -;;; for real things. - -;;; Alien-Address source transform -- Internal -;;; -;;; Divide out the out the offset, producing a ratio if the alien -;;; isn't byte aligned. -;;; -(def-source-transform alien-address (alien) - (multiple-value-bind (binds stuff res) - (analyze-alien-expression nil alien) - `(let* ,(reverse binds) - ,(ignore-unreferenced-vars binds) - ,@(nreverse stuff) - (+ (sap-int ,(ct-a-val-sap res)) (/ ,(ct-a-val-offset res) 16))))) - - -;;; Alien-SAP soruce transform -- Internal -;;; -;;; -(def-source-transform alien-address (alien &whole source) - (multiple-value-bind (binds stuff res) - (analyze-alien-expression nil alien) - `(let* ,(reverse binds) - ,(ignore-unreferenced-vars binds) - ,@(nreverse stuff) - (%aligned-sap ,(ct-a-val-sap res) ,(ct-a-val-offset res) - ',source)))) - - -;;; Alien=>Lisp transform is defined in proclaim.lisp, since it is referenced -;;; by top-level code in cold load. -;;; -(dolist (x '(alien-index alien-indirect)) - (setf (info function source-transform x) #'alien=>lisp-transform)) - - -;;; Alien-Value IR1 convert -- Internal -;;; -;;; Although all we do is call Alien=>Lisp-Transform, this must be a special -;;; form, since the transformation must be done even when functions wouldn't be -;;; transformed. -;;; -(def-ir1-translator alien-value ((x &whole form) start cont) - x ; Ignore - (ir1-convert start cont (alien=>lisp-transform form))) - - -;;;; Alien-Access: - -;;; Alien-Access source transform -- Internal -;;; -;;; We analyze the alien expression, converting to a call to %Alien-Access -;;; with the alien parts as separate arguments. -;;; -(def-source-transform alien-access (alien &optional lisp-type &whole form) - (multiple-value-bind (binds stuff res) - (analyze-alien-expression nil alien) - `(let* ,(reverse binds) - ,(ignore-unreferenced-vars binds) - ,@(nreverse stuff) - (%alien-access ,(ct-a-val-sap res) ,(ct-a-val-offset res) - ,(ct-a-val-size res) ',(ct-a-val-type res) - ,lisp-type ',form)))) - -(defknown %alien-access (t unsigned-byte unsigned-byte t t t) t - (movable flushable)) - -;;; %Alien-Access transform -- Internal -;;; -;;; If we can figure out the alien and lisp types at compile time, then -;;; expand into the appropriate access form. -;;; -(deftransform %alien-access ((sap offset size type lisp-type form)) - (unless (constant-continuation-p lisp-type) - (give-up "Lisp-Type not constant, so cannot open-code.")) - - (let ((type (continuation-value type)) - (lisp-type (continuation-value lisp-type)) - (form (continuation-value form))) - (unless type - (give-up "Alien type unknown, so cannot open-code.")) - - (let ((access (lisp::get-alien-access-method type lisp-type))) - (funcall access 'sap 'offset 'size type :read nil form)))) - - -;;; %Set-Alien-Access source transform -- Internal -;;; -;;; Like the source transform for Alien-Access, only different. -;;; -(def-source-transform %set-alien-access (alien lisp-type - &optional (new-value nil nv-p) - &whole form) - (multiple-value-bind (binds stuff res) - (analyze-alien-expression nil alien) - `(let* ,(reverse binds) - ,(ignore-unreferenced-vars binds) - ,@(nreverse stuff) - (%%set-alien-access ,(ct-a-val-sap res) ,(ct-a-val-offset res) - ,(ct-a-val-size res) ',(ct-a-val-type res) - ,(if nv-p lisp-type nil) - ,(if nv-p new-value lisp-type) - ',form)))) - -(defknown %%set-alien-access (t unsigned-byte unsigned-byte t t t t) t) - -;;; %%Set-Alien-Access transform -- Internal -;;; -;;; Like %Alien-Access transform. The alien-access experts don't return the -;;; right value, cause it's a pain in the ass. Since this is a Setf method, we -;;; gotta return the right value. -;;; -(deftransform %%set-alien-access ((sap offset size type lisp-type new-value - form)) - (unless (constant-continuation-p lisp-type) - (give-up "Lisp-Type not constant, so cannot open-code.")) - - (let ((type (continuation-value type)) - (lisp-type (continuation-value lisp-type)) - (form (continuation-value form))) - (unless type - (give-up "Alien type unknown, so cannot open-code.")) - - (let ((access (lisp::get-alien-access-method type lisp-type))) - `(progn - ,(funcall access 'sap 'offset 'size type :write 'new-value - form) - new-value)))) - - -;;;; Alignment determination: - -;;; Integer-Alignment -- Internal -;;; -;;; Returns the largest power of two which evenly divides its argument. -;;; If N is not an integer 0 is returned. -;;; -(defun integer-alignment (n) - (if (integerp n) - (if (zerop n) - most-positive-fixnum - (do ((i 0 (1+ i)) - (n (abs n) (ash n -1))) - ((not (zerop (logand n 1))) i))) - 0)) - - -;;; Find-Alignment -- Internal -;;; -;;; This function is used to find out if offsets are some multiple of a -;;; power of two. The largest exponent of two which evenly the value of Cont -;;; is returned. 0 is returned if we can't figure out anything, or the result -;;; isn't an integer. If the value is known to be 0, then we return -;;; most-positive-fixnum. -;;; -(defun find-alignment (cont) - (declare (type continuation cont)) - (let ((use (continuation-use cont))) - (cond ((and (combination-p use) - (= (length (combination-args use)) 2)) - (let* ((name (continuation-function-name (combination-fun use))) - (args (combination-args use)) - (x (first args)) - (y (second args))) - (case name - ((+ -) - (min (find-alignment x) (find-alignment y))) - (* - (let ((itype (specifier-type 'integer))) - (if (and (csubtypep (continuation-type x) itype) - (csubtypep (continuation-type y) itype)) - (+ (find-alignment x) (find-alignment y)) - 0))) - (ash - (if (constant-continuation-p y) - (let ((val (continuation-value y))) - (if (integerp val) - (+ (find-alignment x) val) - 0)) - 0)) - (t - 0)))) - ((constant-continuation-p cont) - (integer-alignment (continuation-value cont))) - (t - 0)))) - -;;; Find-Bit-Offset -- Internal -;;; -;;; Returns the value of (rem Exp From) if this can be determined at -;;; compile-time, or Nil otherwise. From must be a power of two. -;;; -(defun find-bit-offset (exp &optional (from 16)) - (declare (type continuation exp) (type unsigned-byte from)) - (let ((use (continuation-use exp))) - (cond ((constant-continuation-p exp) - (rem (continuation-value exp) from)) - ((>= (find-alignment exp) (1- (integer-length from))) - 0) - ((and (combination-p use) - (= (length (combination-args use)) 2)) - (let* ((name (continuation-function-name (combination-fun use))) - (args (combination-args use)) - (x (find-bit-offset (first args) from)) - (y (find-bit-offset (second args) from))) - (when (and x y) - (case name - (+ (rem (+ x y) from)) - (t nil))))) - (t - nil)))) - - -;;;; Reading and writing integers. -;;; -;;; This code is used by many of the Alien-Access experts, since many -;;; operations reduce to reading and writing integers. - -;;; Sign-Extend -- Internal -;;; -;;; Wrap code around Form to sign-extend a Size-bit integer if Signed, -;;; otherwise just return arg. -;;; -(defun sign-extend (form size &optional (signed t)) - (if signed - `(let ((res ,form)) - (declare (fixnum res)) - (if (zerop (logand res ,(ash 1 (1- size)))) - res - (logior res ,(ash -1 size)))) - form)) - - -(defknown naturalize-integer (t t unsigned-byte unsigned-byte t) integer - (flushable)) - -;;; Naturalize-Integer Transform -- Internal -;;; -;;; Compile a call to Naturalize-Integer in some tense fashion. -;;; The number may be signed or unsigned. The integer may be any size and -;;; alignment, as long as it fits within a word, otherwise it must be -;;; exactly 16 or 32 bits and be word-aligned. The size must be a -;;; compile-time constant and is assumed to have been checked for -;;; correctness. -;;; -;;; ### Note that the alignment check will fail if the SAP isn't 32 bit -;;; aligned. Now that we don't generally squeeze offsets into the sap, this is -;;; probably usually true. Eventually, we should guarantee that the SAP is -;;; 32 bit aligned. -;;; -(deftransform naturalize-integer ((signed sap offset size form)) - (unless (constant-continuation-p size) - (give-up "Size not constant, so cannot open-code integer access:~%~S" - (continuation-value form))) - - (let ((align (find-alignment offset)) - (size (continuation-value size)) - (signed (continuation-value signed))) - (cond - ((or (and (> size 15) (< align 4)) - (and (> size 16) (< align 5))) - (give-up "Could not show ~D bit access to be word-aligned:~%~S" - size (continuation-value form))) - ((= size 32) - (if signed - '(%primitive signed-32bit-system-ref sap (ash offset -4)) - '(%primitive unsigned-32bit-system-ref sap (ash offset -4)))) - ((= size 16) - (if signed - '(%primitive signed-16bit-system-ref sap (ash offset -4)) - '(%primitive 16bit-system-ref sap (ash offset -4)))) - ((> size 15) - (compiler-warning "Access of ~D bit bytes is not supported:~%~S" - size (continuation-value form)) - (give-up)) - ((and (> align 2) (= size 8)) - (sign-extend '(%primitive 8bit-system-ref sap (ash offset -3)) - 8 signed)) - (t - (let ((bits (find-bit-offset offset))) - (unless bits - (give-up "Can't determine offset within word, so cannot ~ - open-code:~%~S" - (continuation-value form))) - - (if (>= (+ bits size) 16) - (let* ((hi-bits (- 16 bits)) - (lo-bits (- size hi-bits))) - ;; - ;; If the integer spans a 16bit boundry, then the high bits in - ;; the integer are the low bits in the first word, and the low - ;; bits in the integer are the high bits in the next word. - (sign-extend - `(let ((offset (ash offset -4))) - (logior (ash (ldb (byte ,hi-bits 0) - (sap-ref-16 sap offset)) - ,lo-bits) - (ash (sap-ref-16 sap (1+ offset)) - ,(- (- 16 lo-bits))))) - size signed)) - (sign-extend `(ldb (byte ,size ,bits) - (sap-ref-16 sap (ash offset -4))) - size signed))))))) - - - -(defknown deport-integer (t t unsigned-byte unsigned-byte integer t) void - ()) - -;;; Deport-Integer transform -- Internal -;;; -;;; Similar to Naturalize-Integer transform. -;;; -(deftransform deport-integer ((signed sap offset size value form)) - (unless (constant-continuation-p size) - (give-up "Size not constant, so cannot open-code integer access:~%~S" - (continuation-value form))) - - (let ((align (find-alignment offset)) - (size (continuation-value size))) - (cond - ((or (and (> size 15) (< align 4)) - (and (> size 16) (< align 5))) - (give-up "Could not show ~D bit access to be word-aligned:~%~S" - size (continuation-value form))) - ((= size 32) - '(%primitive signed-32bit-system-set sap (ash offset -4) value)) - ((= size 16) - '(%primitive 16bit-system-set sap (ash offset -4) value)) - ((> size 15) - (compiler-warning "Access of ~D bit bytes is not supported:~%~S" - size (continuation-value form)) - (give-up)) - ((and (> align 2) (= size 8)) - '(%primitive 8bit-system-set sap (ash offset -3) value)) - (t - (let ((bits (find-bit-offset offset))) - (unless bits - (give-up "Can't determine offset within word, so cannot ~ - open-code:~%~S" - (continuation-value form))) - - (if (>= (+ bits size) 16) - (let* ((hi-bits (- 16 bits)) - (lo-bits (- size hi-bits))) - ;; - ;; If the integer spans a 16bit boundry, then the high bits in - ;; the integer are the low bits in the first word, and the low - ;; bits in the integer are the high bits in the next word. - `(let ((offset (ash offset -4))) - (%primitive 16bit-system-set sap offset - (dpb (ash value ,(- lo-bits)) - (byte ,hi-bits 0) - (sap-ref-16 sap offset))) - (%primitive 16bit-system-set sap (1+ offset) - (dpb value - (byte ,lo-bits ,(- 16 lo-bits)) - (sap-ref-16 (1+ offset)))))) - `(let ((offset (ash offset -4))) - (setf (sap-ref-16 sap offset) - (dpb value - (byte ,size ,bits) - (sap-ref-16 sap offset)))))))))) - - -;;;; Boolean stuff: - -(defknown naturalize-boolean (t index index t) boolean (flushable)) -(defknown deport-boolean (t index index t t) void ()) - -;;; Naturalize and Deport Boolean transforms -- Internal -;;; -;;; If the bit falls at a known position within a byte, then we can -;;; test and set it using a single logical operation instead of extracting the -;;; whole field. If the value occupies a full byte/short/word, then then we -;;; just do the access, rather than messing around with masks. -;;; -;;; When setting, we must always set the entire field, so we can only be clever -;;; when the field is a single bit. -;;; -(deftransform naturalize-boolean ((sap offset size form)) - (unless (constant-continuation-p size) - (give-up "Size not constant, so cannot open-code integer access:~% ~S" - (continuation-value form))) - - (let ((off (find-bit-offset offset 8)) - (size (continuation-value size))) - (unless off - (give-up "Can't determine offset within word, so cannot open-code:~% ~S" - (continuation-value form))) - (if (and (>= (find-alignment offset) 3) - (member size '(8 16 32))) - `(not (zerop (naturalize-integer nil sap offset ,size - ',(continuation-value form)))) - `(not (zerop (logand (sap-ref-8 sap (ash (+ offset ,(1- size)) -3)) - ,(ash 1 (- 7 off)))))))) -;;; -(deftransform deport-boolean ((sap offset size value form)) - (unless (constant-continuation-p size) - (give-up "Size not constant, so cannot open-code integer access:~% ~S" - (continuation-value form))) - - (let ((off (find-bit-offset offset 8)) - (size (continuation-value size))) - (unless off - (give-up "Can't determine offset within word, so cannot open-code:~% ~S" - (continuation-value form))) - (if (= size 1) - `(let ((offset (ash offset -3))) - (setf (sap-ref-8 sap offset) - (let ((old (sap-ref-8 sap offset))) - (if value - (logior old ,(ash 1 (- 7 off))) - (logand old ,(lognot (ash 1 (- 7 off)))))))) - `(deport-integer nil sap offset ,size (if value 1 0) - ',(continuation-value form))))) diff --git a/compiler/alloc.lisp b/compiler/alloc.lisp deleted file mode 100644 index 09e77fbce7507a0f739ab3278007ca6a41ed10eb..0000000000000000000000000000000000000000 --- a/compiler/alloc.lisp +++ /dev/null @@ -1,331 +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 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-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-cookie structure) *current-cookie*) - (setf (node-default-cookie structure) *default-cookie*) - (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-reoptimize structure) t) - (setf (block-flush-p structure) t) - (setf (block-type-check structure) t) - (setf (block-delete-p structure) nil) - (setf (block-type-asserted structure) t) - (setf (block-test-modified structure) t) - (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-lambda structure) *current-lambda*) - (setf (block-start-cleanup structure) *current-cleanup*) - (setf (block-end-cleanup structure) *current-cleanup*) - (setf (block-component structure) *current-component*) - (setf (block-start structure) start))) - - ((ref (derived-type source leaf inlinep)) node-source - ((node-deinits) - (setf (ref-leaf structure) *undefined*)) - ((node-inits) - (setf (node-derived-type structure) derived-type) - (setf (node-source structure) source) - (setf (ref-leaf structure) leaf) - (setf (ref-inlinep structure) inlinep))) - - ((combination (source fun)) node-source - ((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 (node-source structure) source) - (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-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) - (let ((stn (tn-save-tn tn))) - (when stn - (unmake-tn stn))) - (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)) - (zap-in (block (component-head component) block-next) - (when (block-lambda 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))) - (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)) - (let ((tails (lambda-tail-set fun))) - (when tails - (setf (tail-set-info tails) nil))) - (let ((env (lambda-environment fun))) - (setf (environment-info env) nil) - (dolist (nlx (environment-nlx-info env)) - (setf (nlx-info-info nlx) nil))) - (dolist (var (lambda-vars fun)) - (setf (leaf-info var) nil)))) diff --git a/compiler/bit-util.lisp b/compiler/bit-util.lisp deleted file mode 100644 index 6aec56fd3d9f92e5fb85dce40532ab787aa8b686..0000000000000000000000000000000000000000 --- a/compiler/bit-util.lisp +++ /dev/null @@ -1,50 +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). -;;; ********************************************************************** -;;; -;;; Bit-vector hacking utilities, potentially implementation-dependent for -;;; speed. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; 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)) diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp deleted file mode 100644 index fe3e7f5f8907ee64906313de400bd90bb0392d41..0000000000000000000000000000000000000000 --- a/compiler/checkgen.lisp +++ /dev/null @@ -1,430 +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 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)))) - (if info - (let ((templates (function-info-templates info))) - (if templates - (template-cost (first templates)) - (case name - (null (template-cost (template-or-lose 'if-eq))) - (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 *type-predicates* :test #'type=)))) - (if found - (function-cost found) - 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 *type-predicates*) - (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*))))) - - -;;; 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. -;;; -;;; When doing a non-negated hairy check, we call MAYBE-WEAKEN-CHECK to -;;; weaken the test to a convenient supertype (conditional on policy.) -;;; -(defun maybe-negate-check (cont types) - (declare (type continuation cont) (list types)) - (multiple-value-bind (ptypes count) - (values-types (continuation-proven-type cont)) - (if (eq count :unknown) - (if (every #'type-check-template types) - (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))) - (list t diff c) - (list nil weak c)))) - ptypes types))) - (if (and (not (find-if #'first res)) - (every #'type-check-template types)) - (values :simple types) - (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. -;;; -;;; 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) - (values-types type) - (cond ((not (eq count :unknown)) - (maybe-negate-check cont types)) - ((and (mv-combination-p dest) - (eq (basic-combination-kind dest) :local)) - (assert (values-type-p type)) - (maybe-negate-check cont (args-type-optional type))) - (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. -;;; -;;; We always return true if there is a compile-time type error on the -;;; continuation, so that this error will be signalled at runtime as well. -;;; -(defun probable-type-check-p (cont) - (declare (type continuation cont)) - (let ((dest (continuation-dest cont))) - (cond ((eq (continuation-type-check cont) :error)) - ((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) - ((eq kind :full) 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)) - (declare (ignore i)) - (temps (gensym))) - - `(multiple-value-bind ,(temps) - 'dummy - ,@(mapcar #'(lambda (temp type) - (let* ((spec (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)) - (prev-cleanup (block-start-cleanup prev-block)) - (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)) - - (setf (block-start-cleanup new-block) prev-cleanup) - (setf (block-end-cleanup new-block) prev-cleanup) - - (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)) - - -;;; 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 -;;; with a :ERROR kind, emit a warning if appropriate, 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. -;;; -;;; 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) - (when (eq (continuation-type-check cont) t) - - (let ((dtype (node-derived-type node)) - (atype (continuation-asserted-type cont))) - (unless (values-types-intersect dtype atype) - (setf (continuation-%type-check cont) :error) - (let ((dest (continuation-dest cont))) - (when (and (combination-p dest) - (function-info-p (basic-combination-kind dest))) - (setf (basic-combination-kind dest) :full))) - (unless (policy node (= brevity 3)) - (let ((*compiler-error-context* node)) - (if (and (ref-p node) (constant-p (ref-leaf node))) - (compiler-warning "This is not a ~S:~% ~S" - (type-specifier atype) - (constant-value (ref-leaf node))) - (compiler-warning "Result is a ~S, not a ~S." - (type-specifier dtype) - (type-specifier atype))))))) - - (let ((check-p (probable-type-check-p cont))) - (multiple-value-bind (check types) - (continuation-check-types cont) - (ecase check - (:simple - (unless check-p - (setf (continuation-%type-check cont) :no-check))) - (:hairy - (if check-p - (convert-type-check cont types) - (setf (continuation-%type-check cont) :no-check))) - (: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 (block-type-check block) nil))) - - (undefined-value)) diff --git a/compiler/codegen.lisp b/compiler/codegen.lisp deleted file mode 100644 index 281257a43baa3bbd01a1f0a6d2f67e033cff9283..0000000000000000000000000000000000000000 --- a/compiler/codegen.lisp +++ /dev/null @@ -1,87 +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). -;;; ********************************************************************** -;;; -;;; 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) - -;;;; Utilities used during code generation. - -;;; 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))) - - -;;; 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 - (lambda-environment - (block-lambda 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)) - - -;;; Generate-Code -- Interface -;;; -(defun generate-code (component) - (let ((prev-env nil)) - (do-ir2-blocks (block component) - (let* ((1block (ir2-block-block block)) - (lambda (block-lambda 1block))) - (when (and (eq (block-info 1block) block) lambda) - (emit-label (block-label 1block)) - (let ((env (lambda-environment lambda))) - (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)))))))) - - (finish-assembly)) diff --git a/compiler/constraint.lisp b/compiler/constraint.lisp deleted file mode 100644 index 16b76358fad2804d217da8762f7f51afdfe6d60d..0000000000000000000000000000000000000000 --- a/compiler/constraint.lisp +++ /dev/null @@ -1,242 +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 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. - ;; - ;; >, <, =, EQL, EQ - ;; 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 eq)) - ;; - ;; 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 constaint. 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))) - - -;;; 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) - (let ((gen (make-sset)) - (kill (make-sset))) - - (do-nodes (node cont block) - (typecase node - (ref - (when (continuation-type-check cont) - (let ((leaf (ref-leaf node))) - (when (and (lambda-var-p leaf) - (lambda-var-constraints leaf)) - (let* ((atype (continuation-derived-type cont)) - (con (find-constraint 'typep leaf atype nil))) - (sset-adjoin con gen)))))) - (cset - (let ((var (set-var node))) - (when (lambda-var-p var) - (let ((cons (lambda-var-constraints var))) - (when cons - (sset-difference gen cons) - (sset-union kill cons)))))))) - - (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))) - - -;;; GET-CONSTRAINTS-TYPE -- Internal -;;; -;;; Given the set of Constraints for a variable and the current set of -;;; restrictions from flow analysis In, return the best approximation of what -;;; the type of a reference would be. -;;; -(defun get-constraints-type (constraints in) - (let ((var-cons (copy-sset constraints))) - (sset-intersection var-cons in) - (let ((res *universal-type*)) - (do-elements (con var-cons) - (when (eq (constraint-kind con) 'typep) - (if (constraint-not-p con) - (let ((diff (type-difference res (constraint-y con)))) - (when diff - (setf res diff))) - (setq res (type-intersection res (constraint-y con)))))) - res))) - - -;;; 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))) - (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 - (derive-node-type node (get-constraints-type 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 (lambda-home (block-lambda (node-block 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 -;;; -(defun flow-propagate-constraints (block) - (let* ((pred (block-pred block)) - (in (copy-sset (block-out (first pred))))) - (dolist (b (rest pred)) - (sset-intersection in (block-out b))) - (setf (block-in block) in) - (sset-union-of-difference (block-out block) in (block-kill block)))) - - -;;; CONSTRAINT-PROPAGATE -- Interface -;;; -(defun constraint-propagate (component) - (declare (type component component)) - (init-var-constraints component) - (do-blocks (block component) - (when (block-type-asserted block) - (find-block-type-constraints 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 354dda652e2d84df2cced70de33edd54b9dd78f0..0000000000000000000000000000000000000000 --- a/compiler/control.lisp +++ /dev/null @@ -1,141 +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). -;;; ********************************************************************** -;;; -;;; 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 ir2-block block after)) - (let ((next (ir2-block-next after))) - (setf (ir2-block-next after) block) - (setf (ir2-block-prev block) after) - (setf (ir2-block-next block) next) - (setf (ir2-block-prev next) block)) - (undefined-value)) - - -;;; Control-Analyze-Block -- Internal -;;; -;;; Do a graph walk linking blocks into the emit order as we go. We treat -;;; blocks ending in tail local calls 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.) -;;; -(defun control-analyze-block (block tail) - (declare (type cblock block) (type ir2-block tail)) - (unless (block-flag 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) (make-ir2-block block))) - (ir2-block-prev tail)) - - (let ((last (block-last block))) - (cond ((and (combination-p last) (node-tail-p last) - (eq (basic-combination-kind last) :local)) - (combination-lambda last)) - (t - (let ((fun nil)) - (dolist (succ (block-succ block)) - (let ((res (control-analyze-block succ tail))) - (when res (setq fun res)))) - 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. The walk from a NLX EP -;;; will never reach the bind block, so we will always get to insert it at the -;;; beginning. -;;; -;;; If the talk 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) - (declare (type clambda fun) (type component component)) - (let* ((tail-block (block-info (component-tail component))) - (prev-block (ir2-block-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)) - (assert (not (block-flag bind-block))) - (let ((new-fun (control-analyze-block bind-block - (ir2-block-next prev-block)))) - (when new-fun - (control-analyze-1-fun new-fun component))))) - (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 all blocks that weren't reached during our -;;; walk. This allows IR2 phases to assume that all IR1 blocks in the DFO have -;;; valid IR2 blocks in their Info. We delete all deleted blocks from the -;;; IR2-COMPONENT VALUES-RECEIVERS so that stack analysis won't get confused. -;;; -(defun control-analyze (component) - (let* ((head (component-head component)) - (head-block (make-ir2-block head)) - (tail (component-tail component)) - (tail-block (make-ir2-block tail))) - (setf (block-info head) head-block) - (setf (block-info tail) tail-block) - (setf (ir2-block-prev tail-block) head-block) - (setf (ir2-block-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))) - - (dolist (fun (component-lambdas component)) - (control-analyze-1-fun fun component)) - - (do-blocks (block component) - (unless (block-flag block) - (delete-block block)))) - - (let ((2comp (component-info component))) - (setf (ir2-component-values-receivers 2comp) - (delete-if-not #'block-component - (ir2-component-values-receivers 2comp)))) - - (undefined-value)) diff --git a/compiler/ctype.lisp b/compiler/ctype.lisp deleted file mode 100644 index 7a6d50b24e932e4b79e60349a9895eacbabf3357..0000000000000000000000000000000000000000 --- a/compiler/ctype.lisp +++ /dev/null @@ -1,589 +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 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, then the Node-Derived-Type is -;;; always used. If Strict-Result is false and 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 (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))) - ((< 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 strict-result (not (continuation-type-check cont))) - 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-lossage "The ~:R argument is a ~S, not a ~S." n - (type-specifier (continuation-proven-type cont)) - (type-specifier - (continuation-asserted-type cont))) - 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 type 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 pre-key (+ n 2))) - ((null key)) - (declare (fixnum n)) - (let ((k (car key))) - (check-arg-type k (specifier-type 'symbol) n) - (cond ((not (check-arg-type k (specifier-type 'keyword) n))) - ((not (constant-continuation-p k)) - (note-slime "The keyword for the ~:R argument 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) - n))))))))) - - -;;; Lambda-Result-Type -- Internal -;;; -;;; Guess the return type of a Lambda. We just return the derived type of -;;; the result continuation, assuming that IR1 optimize and Type check have -;;; made this be a good description of the return type. -;;; -(proclaim '(function lambda-result-type (lambda) type)) -(defun lambda-result-type (lambda) - (let ((ret (lambda-return lambda))) - (if ret - (continuation-derived-type (return-result ret)) - *empty-type*))) - - -;;; 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 (lambda-result-type 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 (lambda-result-type - (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. - (name nil :type keyword) - ;; - ;; The position at which this keyword appeared. 0 if it appeared as the - ;; first argument, etc. - (position nil :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 (find-if #'(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 type 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 type 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))))))) - - -;;;; Redefinition checking: -;;; -;;; When we encounter a - -#| - - -;;; Valid-Redefinition -- Interface -;;; -;;; Check for reasonablness of redefining a function of type Old as type -;;; New. -;;; -(proclaim '(function valid-redefinition (function-type function-type) ???)) -(defun valid-redefinition (old new) - ...) - - -;;; Assert-Definition-Type -- Interface -;;; -;;; Propagate type constraints from Type to the variables and result of -;;; Functional. -;;; -(proclaim '(function assert-definition-type (functional type) void)) -(defun assert-definition-type (functional type) - ...) -|# - diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp deleted file mode 100644 index e99282bd8c36060f60acc4f647127213b0d3350e..0000000000000000000000000000000000000000 --- a/compiler/debug-dump.lisp +++ /dev/null @@ -1,558 +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 creates debugger information from the -;;; compiler's internal data structures. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(defvar *byte-buffer* - (make-array 10 :element-type '(unsigned-byte 8) - :fill-pointer 0 :adjustable t)) - - -;;;; Debug blocks: - -(deftype location-kind () - '(member :unknown-return :known-return :internal-error :non-local-exit - :block-start)) - - -;;; 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 label) - ;; - ;; 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 label label) (type location-kind kind)) - (setf (ir2-block-locations (vop-block vop)) - (nconc (ir2-block-locations (vop-block vop)) - (list (make-location-info kind label vop)))) - (undefined-value)) - - -;;; IR2-BLOCK-ENVIRONMENT -- Interface -;;; -(proclaim '(inline ir2-block-environment)) -(defun ir2-block-environment (2block) - (declare (type ir2-block 2block)) - (lambda-environment (block-lambda (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 hashtable representing the variables dumped, -;;; compute a bit-vector representing the set of live variables. -;;; -(defun compute-live-vars (live block var-locs) - (declare (type ir2-block block) (type local-tn-bit-vector live) - (type hash-table var-locs)) - (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7) - :element-type 'bit - :initial-element 0))) - (do-live-tns (tn live block) - (let ((leaf (tn-leaf tn))) - (when (lambda-var-p leaf) - (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*) - -;;; DUMP-1-LOCATION -- Internal -;;; -;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the -;;; code/source map and live info. -;;; -(defun dump-1-location (node block kind tlf-num label live var-locs) - (declare (type node node) (type ir2-block block) - (type local-tn-bit-vector live) (type label label) - (type location-kind kind) (type (or index null) tlf-num) - (type hash-table var-locs)) - - (vector-push-extend - (dpb (position kind compiled-code-location-kinds) - compiled-code-location-kind-byte - 0) - *byte-buffer*) - - (let ((loc (label-location label))) - (write-var-integer (- loc *previous-location*) *byte-buffer*) - (setq *previous-location* loc)) - - (unless tlf-num - (write-var-integer (node-tlf-number node) *byte-buffer*)) - (write-var-integer (first (node-source-path node)) *byte-buffer*) - - (write-packed-bit-vector (compute-live-vars live block var-locs) - *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)) - (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 (node-tlf-number (lambda-bind fun))) - (num 0)) - (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 (node-tlf-number (continuation-next (block-start block))) - res) - (setq res nil))) - - (dolist (loc (ir2-block-locations 2block)) - (unless (eql (node-tlf-number (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)) - (write-var-integer (1+ (length locations)) *byte-buffer*) - (let ((2block (block-info block))) - (dump-1-location (continuation-next (block-start block)) - 2block :block-start tlf-num - (ir2-block-%label 2block) - (ir2-block-live-out 2block) - var-locs)) - (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 (lambda-environment (block-lambda (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. -;;; -(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 - (when (policy nil (>= debug 2)) - (coerce-to-smallest-eltype - (file-info-positions x)))))) - (cond ((pathnamep name) - (setf (debug-source-name res) name)) - (t - (setf (debug-source-from res) name) - (when (eq name :lisp) - (setf (debug-source-name res) - (cadr (aref (file-info-forms x) 0)))))) - 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) - (let ((max 0)) - (macrolet ((frob () - '(if (and (integerp val) (>= val 0) 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)))) - - -;;;; Locations: - -;;; 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. -;;; -(defun dump-1-variable (var tn id buffer) - (declare (type lambda-var var) (type tn tn) (type unsigned-byte id)) - (let* ((name (leaf-name var)) - (package (symbol-package name)) - (package-p (and package (not (eq package *package*)))) - (save-tn (tn-save-tn tn)) - (flags 0)) - (unless package - (setq flags (logior flags compiled-debug-variable-uninterned))) - (when package-p - (setq flags (logior flags compiled-debug-variable-packaged))) - (when (eq (tn-kind tn) :environment) - (setq flags (logior flags compiled-debug-variable-environment-live))) - (when save-tn - (setq flags (logior flags compiled-debug-variable-save-loc-p))) - (unless (zerop id) - (setq flags (logior flags compiled-debug-variable-id-p))) - (vector-push-extend flags buffer) - (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)) - (write-var-integer (tn-sc-offset tn) buffer) - (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) - (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)) - (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 var (cdr x) id *byte-buffer*) - (setf (gethash var var-locs) i)) - (incf i))) - - (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 (null (leaf-refs 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-INFO-FOR-COMPONENT -- Interface -;;; -;;; Return a debug-info structure describing component. This has to be called -;;; at some particular time (after assembly) so that source map information is -;;; available. -;;; -(defun debug-info-for-component (component assem-nodes count) - (declare (type component component) (simple-vector assem-nodes) - (type index count)) - (let ((level (cookie-debug *default-cookie*)) - (res (make-compiled-debug-info :name (component-name component) - :package (package-name *package*)))) - (collect ((dfuns)) - (let ((var-locs (make-hash-table :test #'eq))) - (dolist (fun (component-lambdas component)) - (clrhash var-locs) - (let* ((2env (environment-info (lambda-environment fun))) - (dispatch (lambda-optional-dispatch fun)) - (main-p (and dispatch - (eq fun (optional-dispatch-main-entry dispatch)))) - (dfun (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 component))) - :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-location - (ir2-environment-environment-start 2env)) - - :elsewhere-pc - (label-location - (ir2-environment-elsewhere-start 2env))))) - - (when (>= level 1) - (setf (compiled-debug-function-variables dfun) - (compute-variables fun level var-locs))) - - (unless (= level 0) - (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))) - - (let ((tails (lambda-tail-set fun))) - (when tails - (let ((info (tail-set-info tails))) - (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))))))) - - (dfuns (cons (label-location - (block-label - (node-block - (lambda-bind fun)))) - dfun))))) - - (let* ((sorted (sort (dfuns) #'< :key #'car)) - (len (1- (* (length sorted) 2))) - (funs-vec (make-array len))) - (do ((i -1 (+ i 2)) - (sorted sorted (cdr sorted))) - ((= i len)) - (let ((dfun (car sorted))) - (unless (minusp i) - (setf (svref funs-vec i) (car dfun))) - (setf (svref funs-vec (1+ i)) (cdr dfun)))) - (setf (compiled-debug-info-function-map res) funs-vec))) - - res)) diff --git a/compiler/debug.lisp b/compiler/debug.lisp deleted file mode 100644 index 96a4d55ca7fa88069ca3e7fabd2559d2d2368718..0000000000000000000000000000000000000000 --- a/compiler/debug.lisp +++ /dev/null @@ -1,1309 +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). -;;; ********************************************************************** -;;; -;;; Utilities for debugging the compiler. Currently contains only stuff for -;;; checking the consistency of the IR1. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(defvar *args* () - "This variable is bound to the format arguments when an error is signalled - by Barf or Burp.") - -;;; 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) nil)) -(defun barf (string &rest *args*) - (apply #'cerror "Skip this error." string *args*)) - -(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) nil)) -(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) - (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)) - (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)) - (when (lambda-cleanup functional) - (barf "Non-let has cleanup: ~S." 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-lambda block))) - (when (eq (functional-kind fun) :deleted) - (return-from check-block-consistency nil)) - (check-function-reached fun block)) - - (let ((this-cont (block-start block)) - (last (block-last 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)) - - (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))) - (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)))) - - (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 (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)) - (unless (or (node-source node) - (and (ref-p node) - (not (leaf-name (ref-leaf node))))) - (burp "~S has no SOURCE." 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))))))) - (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 - (lambda-home - (block-lambda (node-block node))))) - (barf "~S not in Entries for its home lambda." node)) - (dolist (exit (entry-exits node)) - (unless (eq (continuation-kind exit) :deleted) - (do-uses (node exit) - (check-node-reached node))))) - (exit - (let ((entry (exit-entry node)) - (value (exit-value node))) - (cond (entry - (check-node-reached entry) - (unless (member (node-cont node) (entry-exits entry)) - (barf "CONT for ~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)) - ((eq (tn-kind tn) :environment) - (incf environment)) - ((tn-global-conflicts tn) - (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))) - ((eq kind :environment) - (let ((env (tn-environment tn))) - (macrolet ((frob (refs) - `(do ((ref ,refs (tn-ref-next ref))) - ((null ref)) - (unless (eq (lambda-environment - (block-lambda - (ir2-block-block - (vop-block (tn-ref-vop ref))))) - env) - (barf "~S not in TN-Environment for ~S." ref - tn))))) - (frob (tn-reads tn)) - (frob (tn-writes tn))) - (unless (member tn (ir2-environment-live-tns (environment-info env))) - (barf "~S not in Live-TNs for ~S." tn env)) - (when (or (tn-local tn) (tn-global-conflicts tn)) - (barf ":Environment TN ~S has Local or Global-Conflicts." tn)))) - (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))))) - ((eq (tn-kind tn) :constant)) - (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)) - (locs (ir2-environment-arg-locs 2env)) - (pc (ir2-environment-return-pc-pass 2env)) - (fp (ir2-environment-old-fp-pass 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-kind tn) :cached-constant) - (member tn locs) - (eq tn pc) - (eq tn fp)) - (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)) - - -;;;; 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" (entry-info-name (leaf-info leaf)))))) - - -;;; Block-Or-Lose -- Interface -;;; -;;; Attempt to find a block given some thing that has to do with it. -;;; -(proclaim '(function block-or-lose (t) block)) -(defun block-or-lose (thing) - (ctypecase thing - (cblock thing) - (ir2-block (node-block (vop-node (ir2-block-start-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") - (mapc #'print-continuation (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)) - (do ((ref refs (tn-ref-across ref))) - ((null ref)) - (format t " ") - (let ((tn (tn-ref-tn ref)) - (ltn (tn-ref-load-tn ref))) - (cond ((not ltn) - (print-tn tn)) - (t - (print-tn tn) - (write-char (if (tn-ref-write-p ref) #\< #\>)) - (print-tn ltn)))))) - - -;;; 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: ~A" number (vop-info-name (vop-info vop))) - (print-operands (vop-args vop)) - (when (vop-codegen-info vop) - (let ((*print-level* 1) - (*print-length* 3)) - (format t " {~{~S~^ ~}}" (vop-codegen-info vop)))) - (when (vop-results vop) - (format t " =>") - (print-operands (vop-results vop))) - (terpri))) - - -;;; 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))) - (print-nodes block)) - (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 and :ENVIRONMENT - TNs." - (assert (member (tn-kind tn) '(:normal :cached-constant :environment))) - (let ((confs (tn-global-conflicts tn))) - (cond ((eq (tn-kind tn) :environment) - (clrhash *list-conflicts-table*) - (do-environment-ir2-blocks (env-block (tn-environment tn)) - (add-always-live-tns env-block tn) - (add-all-local-tns env-block)) - (listify-conflicts-table)) - (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 3f1c91fb8f423820da319032563bb4478e41f16e..0000000000000000000000000000000000000000 --- a/compiler/dfo.lisp +++ /dev/null @@ -1,404 +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 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) - (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)) - (delete-block block)))) - (setf (component-reanalyze component) nil)) - - -;;; Join-Components -- Internal -;;; -;;; Move all the code and entry points from Old to New. The code in Old is -;;; inserted at the head of New. -;;; -(proclaim '(function join-components (component component) void)) -(defun join-components (new 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 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. -;;; -;;; 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. -;;; -;;; 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 (lambda-home (block-lambda block))) - (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 XEP lambdas in top-level lambdas are excluded -;;; to keep run-time definitions from being joined to load-time code. We mark -;;; any such top-level references as :notinline to prevent the (unlikely) -;;; possiblity that they might later be converted. This preserves the -;;; invariant that local calls are always intra-component without joining in -;;; all top-level code. -;;; -(defun find-reference-functions (fun) - (collect ((res)) - (dolist (ref (leaf-refs fun)) - (let ((home (lambda-home (block-lambda (node-block ref))))) - (if (and (eq (functional-kind home) :top-level) - (eq (functional-kind fun) :external)) - (setf (ref-inlinep ref) :notinline) - (res home)))) - (res))) - - -;;; DFO-Walk-Call-Graph -- Internal -;;; -;;; Move the code for Fun and all functions called by it into 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. 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 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. -;;; -;;; 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 Fun is already in Component, then we just return that -;;; component. -;;; -(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)) - (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)))))))) - - -;;; FIND-TOP-LEVEL-COMPONENTS -- Internal -;;; -;;; Compute the result of FIND-INITIAL-DFO given the list of all resulting -;;; components. We find components that contain a :Top-Level lambda, marking -;;; them as :Top-Level. -;;; -(defun find-top-level-components (components) - (declare (list components)) - (collect ((real) - (top)) - (dolist (com components) - (unless (eq (block-next (component-head com)) (component-tail com)) - (let ((funs (component-lambdas com))) - (cond ((find :top-level funs :key #'functional-kind) - (assert (not (find :external funs :key #'functional-kind))) - (setf (component-kind com) :top-level) - (setf (component-name com) "Top-Level Form") - (top com)) - (t - (setf (component-name com) (find-component-name com)) - (real com)))))) - (values (real) (top)))) - - -;;; Find-Initial-DFO -- Interface -;;; -;;; Given a list of top-level lambdas, return two lists of components -;;; representing the actual component division. The first value is the -;;; non-top-level components, and the second is the top-level ones. 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. -;;; -;;; When we are done, we assign DFNs and delete any components that are -;;; empty due to having been merged with another component. Since all -;;; functions are walked, moving all reachable code to another component, all -;;; blocks remaining in the initial component may be deleted. The only code -;;; left will be in deleted functions or not reachable from the entry to the -;;; function. -;;; -;;; We then 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))))) - - (do-blocks (block component) - (delete-block block))))) - - (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-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. We depend on there being at least a reference to NIL -;;; preceding the RETURN node in each top-level lambda. -;;; -(defun merge-top-level-lambdas (lambdas) - (declare (cons lambdas)) - (let* ((result-lambda (first lambdas)) - (result-env (lambda-environment result-lambda)) - (result-component - (block-component (node-block (lambda-bind result-lambda)))) - (result-return (lambda-return result-lambda))) - - (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)))) - - (let ((result-return-block (node-block result-return))) - (dolist (lambda (rest lambdas)) - (setf (functional-kind lambda) :deleted) - (dolist (let (lambda-lets lambda)) - (setf (lambda-home let) result-lambda) - (setf (lambda-environment let) result-env) - (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)) - (return (lambda-return lambda)) - (return-block (node-block return)) - (result (return-result return)) - (component (block-component bind-block))) - - (do-blocks (block component) - (setf (block-component block) result-component) - (macrolet ((frob (slot) - `(when (eq (,slot block) lambda) - (setf (,slot block) result-lambda)))) - (frob block-lambda) - (frob block-start-cleanup) - (frob block-end-cleanup))) - - (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 ((lambdas (component-lambdas component))) - (assert (and (null (rest lambdas)) - (eq (first lambdas) lambda)))) - - (dolist (pred (block-pred result-return-block)) - (unlink-blocks pred result-return-block) - (link-blocks pred bind-block)) - - (setf (block-last return-block) (continuation-use result)) - (flush-dest result) - (delete-continuation result) - (link-blocks return-block result-return-block) - - (unlink-node bind)))) - - (values result-component result-lambda))) diff --git a/compiler/dump.lisp b/compiler/dump.lisp deleted file mode 100644 index 87e59f36836d4dd77867c82e7c6453c2f319b82f..0000000000000000000000000000000000000000 --- a/compiler/dump.lisp +++ /dev/null @@ -1,1047 +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/dump.lisp,v 1.9 1990/05/24 13:26:45 wlott Exp $ -;;; -;;; This file contains stuff that knows about dumping FASL files. -;;; -(in-package "C") - -(proclaim '(special compiler-version)) - - - -;;;; 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-segment code-length file) - (declare (type component component) (type fasl-file file)) - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) - (num-consts (length constants))) - (collect ((patches)) - - ;; Dump the constants, noting any :entries that have to be fixed up. - (do ((i vm:code-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))))) - #+nil - (:label - (dump-object (+ (label-position (cdr entry)) - clc::i-vector-header-size) - file)))) - (null - (dump-fop 'lisp::fop-misc-trap file))))) - - ;; Dump the debug info. - (let ((info (debug-info-for-component component))) - (dump-object info file) - (let ((info-handle (dump-pop file))) - (dump-push info-handle file) - (push info-handle (fasl-file-debug-info file)))) - - (let ((num-consts (- num-consts vm:code-constants-offset))) - (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)))) - - (let ((fixups (emit-code-vector (fasl-file-stream file) code-segment)) - (handle (dump-pop file))) - (dump-fixups handle fixups file) - (dolist (patch (patches)) - (push (cons handle (cdr patch)) - (gethash (car patch) (fasl-file-patch-table file)))) - handle)))) - - -(defun dump-assembler-routines (code-segment length routines file) - (dump-fop 'lisp::fop-assembler-code file) - (quick-dump-number length 4 file) - (let ((fixups (emit-code-vector (fasl-file-stream file) code-segment))) - (dolist (routine routines) - (dump-object (car routine) file) - (dump-fop 'lisp::fop-assembler-routine file) - (quick-dump-number (label-position (cdr routine)) 4 file)) - (let ((handle (dump-pop file))) - (dump-fixups handle fixups 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)) - (when fixups - (dump-push code-handle file) - (dolist (info fixups) - (let* ((kind (first info)) - (fixup (second info)) - (name (fixup-name fixup)) - (flavor (fixup-flavor fixup)) - (offset (third info))) - (ecase kind - (:addi - ;; ### The lui fixup assumes that an addi follows it. - ) - (:lui - (ecase flavor - (:assembly-routine - (assert (symbolp name)) - (dump-object name file) - (dump-fop 'lisp::fop-assembler-fixup file) - (quick-dump-number offset 4 file)) - (:foreign - (assert (stringp name)) - (dump-fop 'lisp::fop-foreign-fixup file) - (quick-dump-number offset 4 file) - (let ((len (length name))) - (assert (< len 256)) - (dump-byte len file) - (dotimes (i len) - (dump-byte (char-code (schar name i)) file)))))) - #+nil - (:jump - ;; ### Need to impliment this. - )))) - (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))) - ;; ### Do something special for closure functions? - (dump-push code-handle file) - (dump-object name file) - (dump-object (entry-info-arguments entry) file) - (dump-object (entry-info-type entry) file) - (dump-fop 'lisp::fop-function-entry file) - (quick-dump-number (label-position (entry-info-offset entry)) - 4 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-segment length file) - (declare (type component component) (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-segment length file)) - (2comp (component-info component))) - (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))) - (structure - (dump-structure x file) - (eq-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 16)) - (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)) - (float (dump-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)) -#| 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)) - -(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 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: - -(defun 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)))) - - -;;; Dump a structure. - -(defun dump-structure (obj file) - (dump-vector obj file) - (dump-fop 'lisp::fop-structure file)) - diff --git a/compiler/entry.lisp b/compiler/entry.lisp deleted file mode 100644 index 6878cd35b8a8565c20c97344daef240b7b4aa790..0000000000000000000000000000000000000000 --- a/compiler/entry.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). -;;; ********************************************************************** -;;; -;;; 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, assigning each XEP a 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. -;;; -(defun entry-analyze (component) - (let ((2comp (component-info component))) - (dolist (fun (component-lambdas component)) - (when (external-entry-point-p fun) - (let ((info (compute-entry-info fun))) - (setf (leaf-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 -;;; -;;; Return the an Entry-Info structure corresponding to the XEP lambda Fun. -;;; -(defun compute-entry-info (fun) - (declare (type clambda fun)) - (let ((block (node-block (lambda-bind fun))) - (internal-fun (functional-entry-function fun))) - (make-entry-info - :closure-p (not (null (environment-closure (lambda-environment fun)))) - :offset (gen-label) - :name (let ((name (leaf-name internal-fun))) - (or name - (component-name (block-component block)))) - :arguments (make-arg-names internal-fun) - :type (type-specifier (leaf-type internal-fun))))) - - -;;; REPLACE-TOP-LEVEL-XEPS -- Interface -;;; -;;; Replace all references in other components to non-closure XEPs in -;;; Component with :TOP-LEVEL-XEP functionals. We return true if any closure -;;; references were encountered. 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)) - (when (eq (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) - :fenv nil :venv nil - :benv nil :tenv nil)) - (closure (environment-closure - (lambda-environment (main-entry ef))))) - (dolist (ref (leaf-refs lambda)) - (let ((ref-component (block-component (node-block ref)))) - (unless (eq ref-component component) - (assert (eq (component-kind ref-component) :top-level)) - (cond (closure - (setq res t)) - (t - (setf (ref-leaf ref) new) - (push ref (leaf-refs new)))))))))) - res)) diff --git a/compiler/envanal.lisp b/compiler/envanal.lisp deleted file mode 100644 index 209a5f5b565c1c5fc234d6db32d55d47972dd2ed..0000000000000000000000000000000000000000 --- a/compiler/envanal.lisp +++ /dev/null @@ -1,375 +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). -;;; ********************************************************************** -;;; -;;; 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] Find any unreferenced variables in the lambdas in the component. -;;; 4] Scan the blocks in the component closing over non-local-exit -;;; continuations. -;;; 5] Compute a function type for each "real" function. This is done now -;;; because tail uses of the result continuation may be blown away by the -;;; back end. -;;; -(defun environment-analyze (component) - (declare (type component component)) - (assert (not (component-new-functions component))) - (dolist (fun (component-lambdas component)) - (let ((f (if (eq (functional-kind fun) :external) - (functional-entry-function fun) - fun))) - (setf (leaf-type f) (definition-type f))) - (get-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) - (undefined-value)) - - -;;; PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL -- Interface -;;; -;;; Called on top-level components 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)) - (assert (eq (component-kind component) :top-level)) - (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))) - (or (lambda-environment fun) - (let ((res (make-environment :function fun))) - (setf (lambda-environment fun) res) - (dolist (lambda (lambda-lets fun)) - (setf (lambda-environment lambda) res)) - res)))) - - -;;; GET-NODE-ENVIRONMENT -- Internal -;;; -;;; Get node's environment, assigning one if necessary. -;;; -(defun get-node-environment (node) - (declare (type node node)) - (get-lambda-environment (block-lambda (node-block 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))) - (dolist (var (lambda-vars fun)) - (unless (or (leaf-ever-used var) - (lambda-var-ignorep var)) - (let ((*compiler-error-context* (lambda-bind fun))) - (compiler-warning "Variable ~S defined but never used." - (leaf-name var)) - (setf (leaf-ever-used var) t))) - - (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: - -;;; Find-NLX-Cleanup -- Internal -;;; -;;; Given an Exit node, return the associated cleanup. We do this by -;;; scanning up the cleanups from the ending cleanup of the Entry's block, -;;; looking for an :Entry cleanup whose mess-up is Entry. -;;; -;;; If the previous cleanup was a :Catch or :Unwind-Protect, then we return the -;;; previous cleanup instead, since we want to return the catch or UWP cleanup -;;; when that is what the exit really represents. This assumes that the :Catch -;;; or :Unwind-Protect cleanup is always nested immediately inside the -;;; corresponding Entry cleanup, and that the catch or UWP mess-up is always -;;; converted in the same block as the Entry. -;;; -(defun find-nlx-cleanup (exit) - (declare (type exit exit)) - (let ((entry (exit-entry exit))) - (let ((cleanup (find-enclosing-cleanup - (block-end-cleanup (node-block entry)))) - (return-prev nil)) - (loop - (ecase (cleanup-kind cleanup) - (:special-bind - (assert (not return-prev))) - (:entry - (when (eq (continuation-use (cleanup-start cleanup)) entry) - (return (or return-prev cleanup))) - (setq return-prev nil)) - ((:catch :unwind-protect) - (setq return-prev cleanup))) - (setq cleanup (find-enclosing-cleanup (cleanup-enclosing cleanup))))))) - - -;;; 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 lonk to -;;; the component head. This leaves the entry stub reachable, but makes the -;;; flow graph less confusing to flow analysis. -;;; -;;; The ending cleanup of the entry stub is set to the enclosing cleanup for -;;; the entry's cleanup, since this represents the dynamic state that was saved -;;; at mess-up point. It may be that additional local cleanups need to be done -;;; before actually transferring control to the destination. -;;; -(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 (find-nlx-cleanup exit)) - (info (make-nlx-info :cleanup cleanup - :continuation (node-cont exit))) - (new-block (insert-cleanup-code exit-block next-block - (exit-entry exit) - `(%nlx-entry ',info)))) - (unlink-blocks exit-block new-block) - (link-blocks (component-head (block-component new-block)) new-block) - - (setf (nlx-info-target info) new-block) - (push info (environment-nlx-info env)) - (push info (cleanup-nlx-info cleanup)) - (setf (block-end-cleanup new-block) (cleanup-enclosing cleanup))) - - (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 unlink the exit block from its successor. -;;; -- 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 (lambda-home (block-lambda (node-block 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)))) - (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) - (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 blocks 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)) - (do-blocks (block component) - (let ((last (block-last block))) - (when (exit-p last) - (let ((target-env (lambda-environment - (block-lambda (first (block-succ block)))))) - (if (eq (node-environment last) target-env) - (unless *converting-for-interpreter* - (maybe-delete-exit last)) - (note-non-local-exit target-env last)))))) - - (undefined-value)) - - -;;;; Cleanup emission: - -;;; Emit-Cleanups -- Internal -;;; -;;; Zoom up the Cleanup-Enclosing thread 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. In this case, we set Block1's End-Cleanup to be the -;;; Start-Cleanup for block2 to indicate that no cleanup is necessary. -;;; -(defun emit-cleanups (block1 block2) - (declare (type cblock block1 block2)) - (collect ((code) - (reanalyze-funs)) - (let ((cleanup2 (find-enclosing-cleanup (block-start-cleanup block2)))) - (do ((cleanup (find-enclosing-cleanup (block-end-cleanup block1)) - (find-enclosing-cleanup (cleanup-enclosing cleanup)))) - ((eq cleanup cleanup2)) - (let* ((node (continuation-use (cleanup-start 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)))) - (:entry - (dolist (nlx (cleanup-nlx-info cleanup)) - (code `(%lexical-exit-breakup ',nlx))))))) - - (cond ((code) - (let ((block (insert-cleanup-code block1 block2 - (block-last block1) - `(progn ,@(code))))) - (setf (block-end-cleanup block) cleanup2)) - (dolist (fun (reanalyze-funs)) - (local-call-analyze-1 fun))) - (t - (setf (block-end-cleanup block1) cleanup2))))) - - (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. -;;; -(defun find-cleanup-points (component) - (declare (type component component)) - (do-blocks (block1 component) - (let ((env1 (lambda-environment (block-lambda block1))) - (cleanup1 (find-enclosing-cleanup (block-end-cleanup block1)))) - (dolist (block2 (block-succ block1)) - (let ((fun2 (block-lambda block2))) - (when fun2 - (let ((env2 (lambda-environment fun2))) - (when (and (eq env2 env1) - (not (eq (find-enclosing-cleanup - (block-start-cleanup block2)) - 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, so as 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)) - (tails (lambda-tail-set fun))) - (do-uses (use result) - (when (and (immediately-used-p result use) - (not (eq (node-derived-type use) *empty-type*))) - (setf (node-tail-p use) tails))))))) - (undefined-value)) diff --git a/compiler/eval-comp.lisp b/compiler/eval-comp.lisp deleted file mode 100644 index 305f837be0bd054abc7b08be8eb0b0b8be522749..0000000000000000000000000000000000000000 --- a/compiler/eval-comp.lisp +++ /dev/null @@ -1,297 +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 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* *sb-list* - *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* *fenv*)) - -(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) - (*fenv* ()) - ;; - (*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))) - (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* ((*converting-for-interpreter* t) - (lambdas (list (ir1-top-level form 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* - (maybe-mumble "[Check]~%") - (check-ir1-consistency *all-components*)) - ;; - ;; This DOLIST body comes from the beginning of - ;; COMPILE-COMPONENT. - (dolist (component *all-components*) - (let ((*compile-component* component)) - (maybe-mumble "Env ") - (environment-analyze component)) - (annotate-component-for-eval component)) - (when *check-consistency* - (maybe-mumble "[Check]~%") - (check-ir1-consistency *all-components*)))) - (ir1-finalize) - (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) - (dolist (nlx (environment-nlx-info (node-environment entry)) - :local-lexical-exit) - (let ((cleanup (nlx-info-cleanup nlx))) - (ecase (cleanup-kind cleanup) - (:entry - (when (eq (continuation-use (cleanup-start cleanup)) - entry) - (return :non-local-lexical-exit))) - ((:catch :unwind-protect) - (when (eq (continuation-use (cleanup-start (cleanup-enclosing cleanup))) - entry) - (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))) - -(defun %throw (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))) diff --git a/compiler/eval.lisp b/compiler/eval.lisp deleted file mode 100644 index 8d0fe6ab1570620cfeb61ea550194bd3e58ddf05..0000000000000000000000000000000000000000 --- a/compiler/eval.lisp +++ /dev/null @@ -1,1205 +0,0 @@ -;;; -*- Package: eval; 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 interpreter. We first convert to the compiler's -;;; IR1 and interpret that. -;;; -;;; Written by Bill Chiles. -;;; -(in-package "EVAL") - -(export '(internal-eval *eval-stack-trace* *internal-apply-node-trace* - *interpreted-function-cache-minimum-size* - *interpreted-function-cache-threshold* - trace-eval interpreted-function-p - interpreted-function-lambda-expression - interpreted-function-closure - interpreted-function-name - interpreted-function-arglist - 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))) - #'(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) - (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 (or (c::functional-fenv fun) - (c::functional-venv fun) - (c::functional-benv fun) - (c::functional-tenv fun)) - t nil) - (or (eval-function-name eval-fun) - (c::component-name - (c::block-component - (c::node-block (c::lambda-bind fun)))))))))) - - -;;; 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) (x val) - (setf (eval-function-name (get-eval-function x)) val)) -;;; -(defun interpreted-function-arglist (x) - (eval-function-arglist (get-eval-function x))) -;;; -(defun (setf interpreted-function-arglist) (x val) - (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*) - - - -;;;; 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))))) - (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))))))) - `(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 1)) - (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) - (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 ((eq ,kind :full) - (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 nil)) - (internal-apply res nil 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. -;;; -(defun internal-apply (lambda args closure) - (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 (cdr args))) - ((null vars)) - ;; Args may run out of values before vars runs out of variables, so - ;; just do CAR of nil and store nil. - (let ((var (car vars))) - (when (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 (car args)) - (car 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) - (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)) - ;; Ultimately CATCH will handle the stack top - ;; cleanup. - (stack-top *eval-stack-top*) - 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))) - (cond ((eq values :fell-through) - ;; Interpreting state is set with MV-SETQ above. - ;; Just get out of this branch and go on. - (return)) - ((eq values :non-local-go) - ;; Ultimately do nothing here since CATCH would - ;; have cleaned up the stack for us. - (eval-stack-set-top stack-top) - (setf node (c::continuation-next - (car (c::block-succ block))))) - (t - ;; We know we're non-locally exiting from a - ;; BLOCK with values (saw a RETURN-FROM). - ;; - ;; Ultimately do nothing here since CATCH would - ;; have cleaned up the stack for us. - (eval-stack-set-top stack-top) - (ecase (c::continuation-info cont) - (:single - (eval-stack-push (car values))) - ((:multiple :return) - (eval-stack-push values)) - (:unused)) - (setf cont last-cont) - (return)))))))))) - (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::lambda-environment - (c::block-lambda - (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))) - (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))))))) - (eval-stack-set-top frame-ptr))) - - -;;; 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 - (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 - (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 - (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))) - (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::functional-fenv 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)))))))))) - - -;;; 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::lambda-environment - (c::block-lambda (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::continuation-use - (c::cleanup-start (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) - (declare (ignore i)) - (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/fndb.lisp b/compiler/fndb.lisp deleted file mode 100644 index 24fe703f0fb5b21b95f6391072e5da2d749ee9a7..0000000000000000000000000000000000000000 --- a/compiler/fndb.lisp +++ /dev/null @@ -1,1089 +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 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 - %rplaca - %rplacd - %sbitset - %scharset - %set-documentation - %set-fdefinition - %set-fill-pointer - %setelt - %setnth - %sp-set-definition - %sp-set-plist - %standard-char-p - %string-char-p - %svset - %typep - %array-typep - array-header-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 'c) - -#| Something to convert the old FNDEFS database into our format: - -(defun convert-defs (fin fout) - (with-open-file (sin fin) - (with-open-file (sout fout :direction :output :if-exists :new-version) - (loop - (do ((ch (read-char sin nil nil) (read-char sin nil nil))) - ((or (not ch) - (not (or (char= ch #\tab) (char= ch #\newline) (char= ch #\space) - (char= ch #\;)))) - (when ch - (unread-char ch sin))) - (when (char= ch #\;) - (write-char ch sout) - (write-line (read-line sin) sout))) - - (let ((form (read sin nil '*eof*))) - (when (eq form '*eof*) (return)) - (if (atom form) - (format t "Ignoring ~S~%" form) - (case (car form) - (built-in-sf) - (built-in-fn - (let* ((args (mapcar 'eval (rest form))) - (name (first args)) - (nargs (second args)) - (flushable (third args)) - (result-type (fourth args)) - (result-fun (fifth args)) - (multiple (sixth args)) - (foldable (member 'clc::fold-transform - (get name 'clc::clc-transforms)))) - (unless (eq (symbol-package name) (symbol-package 'cons)) - (format t "~S not in Lisp package.~%" name)) - (format sout "(defknown ~S (" #|))|# name) - (block punt - (unless (fboundp name) - (format t "~S not fbound.~%" name) - (return-from punt)) - (let ((def (symbol-function name))) - (unless (compiled-function-p def) - (format t "~S not compiled." name) - (return-from punt)) - (let ((arglist (read-from-string - (%primitive header-ref def system:%function-arg-names-slot)))) - (multiple-value-bind (req opt restp ig1 keyp keys) - (parse-lambda-list arglist) - (declare (ignore ig1)) - (let* ((dmin (length req)) - (dmax (if (or restp keyp) nil - (+ dmin (length opt))))) - (unless (eql dmin (if (listp nargs) (car nargs) nargs)) - (format t "~S: actual min-args ~D, defined ~S.~%" - name dmin nargs)) - (unless (eql dmax (if (listp nargs) (cadr nargs) nargs)) - (format t "~S: actual max-args ~D, defined ~S.~%" - name dmax nargs)) - (dotimes (i (length req)) - (format sout "t ")) - (when opt - (format sout "&optional ") - (dotimes (i (length opt)) - (format sout "t "))) - (when restp - (format sout "&rest t ")) - (when keyp - (format sout "&key ") - (dolist (key keys) - (format sout "(~A t) " - (cond ((symbolp key) key) - ((symbolp (car key)) (car key)) - ((symbolp (caar key)) (caar key)) - (t - (format t "Bizzare keyword spec: ~S~%" key))))))))))) - (unless (eql nargs 0) - (file-position sout (1- (file-position sout)))) - (format sout #|(|# ")" sout) - - (let ((rtype (if (eq result-type 'predicate) - 'boolean result-type))) - (if multiple - (format sout " (values ~S &rest t)" rtype) - (format sout " ~S" rtype))) - - (cond - (flushable - (cond (foldable - (write-string " (flushable foldable unsafe)" sout)) - (t - (write-string " (flushable unsafe)" sout)))) - (t - (when foldable - (format t "Foldable but not flushable: ~S." name)))) - - (when result-fun - (format sout "~% :derive-type '~S" result-fun)) - (format sout #|(|# ")~%"))) - (built-in-special) - (t - (format t "Ignoring ~S~%" form))))))))) - -|# - - -;;;; Information for known functions: - -(defknown coerce (t type-specifier) t - (movable foldable) ; Is defined to signal errors. - :derive-type 'type-spec-arg2) - -(defknown type-of (t) t (foldable 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 commonp not) - (t) boolean (movable foldable flushable)) - - -(defknown (eq eql) (t t) boolean (movable foldable flushable)) -(defknown (equal equalp) (t t) boolean (foldable flushable)) - - -;;;; 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)) -(defknown special-form-p (symbol) t (movable foldable flushable)) ; They never change... -(defknown set (symbol t) t (unsafe) - :derive-type 'result-type-arg2) -(defknown fdefinition ((or symbol cons)) function) -(defknown %set-fdefinition ((or symbol cons) function) function) -(defknown makunbound (symbol) symbol) -(defknown fmakunbound ((or symbol cons)) (or symbol cons)) -(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 unsafe)) ; Returns arg... - -(defknown values (&rest t) * (movable foldable flushable unsafe)) -(defknown values-list (list) * (movable foldable flushable unsafe)) - - -;;;; In the "Macros" chapter: - -(defknown macro-function (symbol) (or function null) (flushable)) -(defknown (macroexpand 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 gentemp (&optional string package) 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)) -(defknown make-package (stringlike &key (use list) (nicknames list) - ;; ### Extensions... - (internal-symbols index) (external-symbols index)) - package) -(defknown in-package (stringlike &key (nicknames list) (use list)) void) -(defknown find-package (stringlike) (or package null) (flushable)) -(defknown package-name (package) simple-string (flushable)) -(defknown package-nicknames (package) list (flushable)) -(defknown rename-package (package stringlike &optional list) void) -(defknown package-use-list (package) list (flushable)) -(defknown package-used-by-list (package) list (flushable)) -(defknown package-shadowing-symbols (package) 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 shadow) (symbols &optional packagelike) truth) -(defknown (use-package unuse-package) ((or list packagelike) &optional packagelike) truth) -(defknown find-all-symbols (stringlike) list (flushable)) -(defknown provide (stringlike) void) -(defknown require (stringlike &optional filename) void) - - -;;;; In the "Numbers" chapter: - -(defknown zerop (number) boolean (movable foldable flushable)) -(defknown (plusp minusp) (real) boolean (movable foldable flushable)) -(defknown (oddp evenp) (integer) boolean (movable foldable flushable)) -(defknown (= /=) (number &rest number) boolean (movable foldable flushable)) -(defknown (< > <= >=) (real &rest real) boolean (movable foldable flushable)) -(defknown (max min) (real &rest real) real (movable foldable flushable) - :derive-type 'numeric-result-type) -(defknown + (&rest number) number (movable foldable flushable) - :derive-type 'numeric-result-type) -(defknown - (number &rest number) number (movable foldable flushable) - :derive-type 'numeric-result-type) -(defknown * (&rest number) number (movable foldable flushable) - :derive-type 'numeric-result-type) -(defknown / (number &rest number) number (movable foldable flushable) - :derive-type '/-result-type) -(defknown (1+ 1-) (number) number (movable foldable flushable)) -(defknown conjugate (number) number (movable foldable flushable)) -(defknown gcd (&rest integer) unsigned-byte (movable foldable flushable) - :derive-type 'boolean-result-type) -(defknown lcm (&rest integer) unsigned-byte (movable foldable flushable)) - -(defknown exp (number) irrational (movable foldable flushable)) -(defknown expt (number real) number (movable foldable flushable)) -(defknown log (number &optional real) irrational (movable foldable flushable)) -(defknown sqrt (number) irrational (movable foldable flushable)) -(defknown isqrt (unsigned-byte) unsigned-byte (movable foldable flushable)) -(defknown (abs phase signum) (number) number (movable foldable flushable)) -(defknown cis (real) (complex float) (movable foldable flushable)) -(defknown atan (number &optional real) irrational (movable foldable flushable)) -(defknown (sin cos tan asin acos sinh cosh tanh asinh acosh atanh) - (number) irrational (movable foldable flushable)) -(defknown float (real &optional float) float (movable foldable flushable) - :derive-type 'float-result-type) -(defknown (rational rationalize) (real) rational (movable foldable flushable)) -(defknown (numerator denominator) (rational) integer (movable foldable flushable)) -(defknown (floor ceiling truncate round) - (real &optional real) (values integer real) (movable foldable flushable)) -(defknown (mod rem) (real real) real (movable foldable flushable)) -(defknown (ffloor fceiling fround ftruncate) - (real &optional real) (values float float) (movable foldable flushable)) - - - -(defknown decode-float (float) (values float float-exponent float) (movable foldable flushable) -; :derive-type 'result-type-arg1 But not really... -) -(defknown scale-float (float float-exponent) float (movable foldable flushable) - :derive-type 'result-type-arg1) -(defknown float-radix (float) float-radix (movable foldable flushable)) -(defknown float-sign (float &optional float) float (movable foldable flushable)) -(defknown (float-digits float-precision) (float) float-digits (movable foldable flushable)) -(defknown integer-decode-float (float) - (values integer float-exponent (member -1 1)) - (movable foldable flushable)) -(defknown complex (real &optional real) number (movable foldable flushable)) -(defknown (realpart imagpart) (number) real (movable foldable flushable)) - -(defknown (logior logxor logand logeqv lognand lognor logandc1 logandc2 logorc1 - logorc2) - (&rest integer) t - (movable foldable flushable)) - -(defknown boole (t t boole-code) integer (movable foldable flushable)) -(defknown lognot (integer) t (movable foldable flushable) - :derive-type 'boolean-result-type) -(defknown logtest (t integer) boolean (movable foldable flushable)) -(defknown logbitp (bit-index integer) boolean (movable foldable flushable)) -(defknown ash (integer ash-index) integer (movable foldable flushable)) -(defknown (logcount integer-length) (integer) bit-index - (movable foldable flushable)) -(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 string-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 char-bits (character) char-bits (movable foldable flushable)) -(defknown char-font (character) char-font (movable foldable flushable)) -(defknown code-char (char-code &optional char-bits char-font) - character (movable foldable flushable)) -(defknown make-char (character &optional char-bits char-font) - character (movable foldable flushable)) -(defknown (char-upcase char-downcase) (character) character (movable foldable flushable)) -(defknown digit-char (integer &optional integer char-bits) - (or character null) (movable foldable flushable)) -(defknown char-int (character) char-int (movable foldable flushable)) -(defknown int-char (char-int) character (movable foldable flushable)) -(defknown char-name (character) (or simple-string null) (movable foldable flushable)) -(defknown name-char (stringable) (or character null) (movable foldable flushable)) -(defknown char-bit (character bit-names) boolean (movable foldable flushable)) -(defknown set-char-bit (character bit-names t) character (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 'result-type-arg1) - -(defknown copy-seq (sequence) consed-sequence (foldable flushable) - :derive-type 'result-type-arg1) - -(defknown length (sequence) index (foldable flushable)) - -(defknown reverse (sequence) consed-sequence (foldable flushable) - :derive-type 'result-type-arg1) - -(defknown nreverse (sequence) sequence (unsafe) - :derive-type 'result-type-arg1) - -(defknown make-sequence (type-specifier index &key (initial-element t)) consed-sequence - (movable flushable unsafe) :derive-type 'type-spec-arg1) - -(defknown concatenate (type-specifier &rest sequence) consed-sequence - (foldable flushable) :derive-type 'type-spec-arg1) - -(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)) - t - (foldable flushable call unsafe)) - -(defknown fill (sequence t &key (start index) (end sequence-end)) sequence - (unsafe) - :derive-type 'result-type-arg1) - -(defknown replace (sequence sequence &key (start1 index) (end1 sequence-end) - (start2 index) (end2 sequence-end)) - consed-sequence (unsafe) - :derive-type 'result-type-arg1) - -(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 'result-type-arg2) - -(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 'result-type-arg2) - -(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 'result-type-arg2) - -(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 'result-type-arg2) - -(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 unsafe) - :derive-type 'result-type-arg2) - -(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 unsafe) - :derive-type 'result-type-arg3) - -(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 unsafe) - :derive-type 'result-type-arg2) - -(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 unsafe) - :derive-type 'result-type-arg3) - -(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 'result-type-arg1) - -(defknown delete-duplicates - (sequence &key (test callable) (test-not callable) (start index) (from-end t) - (end sequence-end) (key callable)) - sequence - (flushable call unsafe) - :derive-type 'result-type-arg1) - -(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 'result-type-arg1) - -(defknown merge (type-specifier sequence sequence callable - &key (key callable)) - sequence - (flushable call) - :derive-type 'type-spec-arg1) - - -;;;; 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 (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 unsafe)) -(defknown last (list) list (foldable flushable unsafe)) -(defknown list (&rest t) list (flushable unsafe)) -(defknown list* (t &rest t) t (flushable unsafe)) -(defknown make-list (index &key (initial-element t)) list (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 unsafe)) -(defknown nconc (&rest list) list (unsafe)) -(defknown nreconc (list list) list (unsafe)) -(defknown butlast (list &optional index) list (flushable)) -(defknown nbutlast (list &optional index) list (unsafe)) -(defknown ldiff (list list) list (flushable)) -(defknown (rplaca rplacd) (cons t) list (unsafe)) - -;;; --------- clean pointer ######### - -(defknown subst (t t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown subst-if (t t t &key (key t)) list (flushable unsafe)) -(defknown subst-if-not (t t t &key (key t)) list (flushable unsafe)) -(defknown nsubst (t t t &key (key t) (test t) (test-not t)) list) -(defknown nsubst-if (t t t &key (key t)) list) -(defknown nsubst-if-not (t t t &key (key t)) list) -(defknown sublis (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown nsublis (t t &key (key t) (test t) (test-not t)) list) -(defknown member (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown member-if (t t &key (key t)) list (flushable unsafe)) -(defknown member-if-not (t t &key (key t)) list (flushable unsafe)) -(defknown tailp (t t) boolean (flushable unsafe)) -(defknown adjoin (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown union (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown intersection (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown set-difference (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown set-exclusive-or (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown nunion (t t &key (key t) (test t) (test-not t)) list) -(defknown nintersection (t t &key (key t) (test t) (test-not t)) list) -(defknown nset-difference (t t &key (key t) (test t) (test-not t)) list) -(defknown nset-exclusive-or (t t &key (test t) (test-not t) (key t)) list) -(defknown subsetp (t t &key (key t) (test t) (test-not t)) boolean (flushable unsafe)) -(defknown acons (t t t) list (flushable unsafe)) -(defknown pairlis (t t &optional t) list (flushable unsafe)) -(defknown assoc (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown assoc-if (t t) list (flushable unsafe)) -(defknown assoc-if-not (t t) list (flushable unsafe)) -(defknown rassoc (t t &key (key t) (test t) (test-not t)) list (flushable unsafe)) -(defknown rassoc-if (t t) list (flushable unsafe)) -(defknown rassoc-if-not (t t) list (flushable unsafe)) - - -;;;; In the "Hash Tables" chapter: - -(defknown make-hash-table - (&key (test callable) (size index) (rehash-size (or (integer (0)) (float (1.0)))) - (rehash-threshold (or (integer (0)) (float (0.0) (1.0))))) - 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 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) fixnum (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 list) (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 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-arg1) - -(defknown bit-not ((array bit) &optional (or (array bit) (member t))) - (array bit) - (foldable) - :derive-type 'result-type-arg1) - -(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) (adjustable t) - (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) string-char (foldable flushable)) -(defknown schar (simple-string index) string-char (foldable flushable)) - -(defknown (string= string-equal) - (stringlike stringlike &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) - (stringlike stringlike &key (start1 index) (end1 sequence-end) - (start2 index) (end2 sequence-end)) - (or index null) - (foldable flushable)) - -(defknown make-string (index &key (initial-element string-char)) - simple-string (flushable)) - -(defknown (string-trim string-left-trim string-right-trim) - (sequence stringlike) simple-string (flushable)) - -(defknown (string-upcase string-downcase string-capitalize) - (stringlike &key (start index) (end sequence-end)) - simple-string (flushable)) - -(defknown (nstring-upcase nstring-downcase nstring-capitalize) - (string &key (start index) (end sequence-end)) - string (unsafe)) - -(defknown string (t) string (flushable unsafe)) - - -;;; Internal non-keyword versions of string predicates: - -(defknown (string<* string>* string<=* string>=* string/=*) - (stringlike stringlike index sequence-end index sequence-end) - (or index null) - (foldable flushable)) - -(defknown string=* - (stringlike stringlike index sequence-end index sequence-end) - boolean - (foldable flushable)) - - -;;;; In the "Eval" chapter: - -(defknown eval (t) *) -(defknown evalhook (t callable callable &optional full-lexical-environment) *) -(defknown applyhook (callable list callable callable &optional full-lexical-environment) *) -(defknown constantp (t) boolean (foldable flushable)) - - -;;;; In the "Streams" chapter: - -(defknown make-synonym-stream (symbol) stream (flushable unsafe)) -(defknown make-broadcast-stream (&rest stream) stream (flushable unsafe)) -(defknown make-concatenated-stream (&rest stream) stream (flushable unsafe)) -(defknown make-two-way-stream (stream stream) stream (flushable unsafe)) -(defknown make-echo-stream (stream stream) stream (flushable unsafe)) -(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 (unsafe)) -(defknown readtablep (t) boolean (movable foldable flushable)) - -(defknown set-syntax-from-char - (character character &optional (or readtable null) readtable) void - (unsafe)) - -(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 (unsafe)) -(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 read-char-no-hang) - (&optional streamlike t t t) t) - -(defknown read-delimited-list (character &optional streamlike t) t) -(defknown read-line (&optional streamlike t t t) (values t boolean)) -(defknown unread-char (character &optional streamlike) t) -(defknown peek-char (&optional (or character (member nil t)) streamlike t t t) t) -(defknown listen (&optional streamlike) boolean (flushable)) - -(defknown clear-input (&optional stream) null) - -(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) - -(defknown write - (t &key (stream streamlike) (escape t) (radix t) (base (integer 2 36)) - (circle t) (pretty t) (level (or unsigned-byte null)) - (length (or unsigned-byte null)) (case t) (array t) (gensym t)) t - (any) - :derive-type 'result-type-arg1) - -(defknown (prin1 print princ) (t &optional streamlike) t (any) - :derive-type 'result-type-arg1) - -;;; xxx-TO-STRING not foldable because they depend on the dynamic environment. -(defknown write-to-string - (t &key (stream streamlike) (escape t) (radix t) (base (integer 2 36)) - (circle t) (pretty t) (level (or unsigned-byte null)) - (length (or unsigned-byte null)) (case t) (array t) (gensym t)) - simple-string - (foldable flushable)) - -(defknown (prin1-to-string princ-to-string) (t) simple-string (flushable)) - -(defknown write-char (character &optional streamlike) character) -(defknown (write-string write-line) - (string &optional streamlike &key (start index) (end sequence-end)) - string) - -(defknown (terpri finish-output force-output clear-output) - (&optional streamlike) null) - -(defknown fresh-line (&optional streamlike) boolean) - -(defknown write-byte (integer stream) integer) - -(defknown format ((or streamlike string) string &rest t) (or string null)) - -(defknown (y-or-n-p yes-or-no-p) (&optional string &rest t) boolean) - - -;;;; In the "File System Interface" chapter: - -(defknown pathname (pathnamelike) pathname (foldable flushable unsafe)) -(defknown truename (pathnamelike) pathname (unsafe)) - -(defknown parse-namestring - (pathnamelike &optional (or string null) pathnamelike &key (start index) - (end sequence-end) (junk-allowed t)) - (values (or pathname null) index) - (unsafe)) - -(defknown merge-pathnames (pathnamelike &optional pathnamelike) pathname - (foldable flushable)) - -;;; Sooo many kindsof garbage can be specified, that I don't feel like figuring -;;; out what legal args are... -(defknown make-pathname - (&key (defaults pathnamelike) (host t) (device t) (directory t) (name t) - (type t) (version t)) - pathname (foldable flushable unsafe)) - -(defknown pathnamep (t) boolean (movable foldable flushable)) - -(defknown pathname-host (pathnamelike) pathname-host (foldable flushable)) -(defknown pathname-device (pathnamelike) pathname-device (foldable flushable)) -(defknown pathname-directory (pathnamelike) pathname-directory (foldable flushable)) -(defknown pathname-name (pathnamelike) pathname-name (foldable flushable)) -(defknown pathname-type (pathnamelike) 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 unsafe)) - -(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 - (filename &key (verbose t) (print t) - (if-does-not-exist (member :error :create nil))) - t) - -(defknown directory (pathnamelike &key) 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 null) boolean boolean)) -(defknown compile-file - ((or filename list) &key (output-file filename) (error-file filename) - (trace-file filename) (errors-output t) (load t) (block-compile t)) - (values (or pathname null) boolean boolean)) -(defknown disassemble (callable &optional stream) void) - -(defknown documentation (symbol (member variable function structure type setf)) - (or string null) - (flushable)) - -(defknown describe (t &optional stream) (values)) -(defknown inspect (t) (values)) - -(defknown room (&optional (member t nil) t) void) -(defknown ed (&optional filename) 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-arg1) - - -;;;; Magical compiler frobs: - -(defknown (%typep %array-typep) (t type-specifier) boolean) -(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) nil) -(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)) -(defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer - (movable foldable flushable)) -(defknown %negate (number) number (movable foldable 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 unsafe)) -(defknown %slot-setter (t t) t (unsafe)) - - -;;;; Setf inverses: - -(defknown %aset (array &rest 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 index bit) bit (unsafe)) -(defknown %sbitset (simple-bit-vector index bit) bit (unsafe)) -(defknown %charset (string index string-char) string-char (unsafe)) -(defknown %scharset (simple-string index string-char) string-char (unsafe)) -(defknown %sp-set-definition (symbol function) function (unsafe)) -(defknown %sp-set-plist (symbol t) t (unsafe)) -(defknown %set-documentation - (symbol (member variable function structure type setf) - (or string null)) - (unsafe)) -(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 %string-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/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp deleted file mode 100644 index e44c964826331a153a4fae6408400deb0d5fe5b8..0000000000000000000000000000000000000000 --- a/compiler/generic/vm-fndb.lisp +++ /dev/null @@ -1,179 +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/generic/vm-fndb.lisp,v 1.9 1990/05/27 16:51:48 ch Exp $ -;;; -;;; This file defines the machine specific function signatures. -;;; -;;; Written by William Lott. -;;; -(in-package "C") - -(import '(lisp::%raw-bits lisp::simple-array-p)) - - - -;;;; 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 %string-char-p %standard-char-p structurep - array-header-p simple-array-p simple-array-unsigned-byte-2-p - simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p - simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p - simple-array-single-float-p simple-array-double-float-p - system-area-pointer-p realp unsigned-byte-32-p signed-byte-32-p) - (t) boolean (movable foldable flushable)) - -;;; Introduce these predicates into the old compiler. This is necessary -;;; 'cause they are marked as foldable. -;;; -#-new-compiler -(macrolet ((frob (name type) - `(defun ,name (thing) - (typep thing ',type)))) - (frob simple-array-unsigned-byte-2-p (simple-array (unsigned-byte 2) (*))) - (frob simple-array-unsigned-byte-4-p (simple-array (unsigned-byte 4) (*))) - (frob simple-array-unsigned-byte-8-p (simple-array (unsigned-byte 8) (*))) - (frob simple-array-unsigned-byte-16-p (simple-array (unsigned-byte 16) (*))) - (frob simple-array-unsigned-byte-32-p (simple-array (unsigned-byte 32) (*))) - (frob simple-array-single-float-p (simple-array single-float (*))) - (frob simple-array-double-float-p (simple-array double-float (*))) - (frob system-area-pointer-p system-area-pointer) - (frob realp real) - (frob unsigned-byte-32-p (unsigned-byte 32)) - (frob signed-byte-32-p (signed-byte 32))) - - -;;;; Miscellaneous "sub-primitives": - -(defknown %sp-string-compare - (simple-string index index simple-string index index) - (or index null) - (foldable flushable)) - - -(defknown %raw-bits (t fixnum) (unsigned-byte 32) - (foldable flushable)) -(defknown ((setf %raw-bits)) (t fixnum (unsigned-byte 32)) (unsigned-byte 32) - (unsafe)) - - -(defknown dynamic-space-free-pointer () - (system-area-pointer) - (foldable flushable movable)) - - -;;;; 32bit logical operations - -(defknown merge-bits ((unsigned-byte 5) (unsigned-byte 32) (unsigned-byte 32)) - (unsigned-byte 32) - (foldable flushable movable)) - -(defknown 32bit-logical-not ((unsigned-byte 32)) (unsigned-byte 32) - (foldable flushable movable)) - -(defknown (32bit-logical-and 32bit-logical-or 32bit-logical-xor - 32bit-logical-nor) - ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32) - (foldable flushable movable)) - - - -;;;; Bignum operations. - -(defknown bignum::%allocate-bignum (bignum-index) bignum-type - (flushable)) - -(defknown bignum::%bignum-length (bignum-type) bignum-index - (foldable flushable movable)) - -(defknown bignum::%bignum-set-length (bignum-type bignum-index) bignum-index - (unsafe)) - -(defknown bignum::%bignum-ref (bignum-type bignum-index) bignum-element-type - (flushable)) - -(defknown bignum::%bignum-set (bignum-type bignum-index bignum-element-type) - bignum-element-type - (unsafe)) - -(defknown bignum::%digit-0-or-plusp (bignum-element-type) boolean - (foldable flushable movable)) - -(defknown (bignum::%add-with-carry bignum::%subtract-with-borrow) - (bignum-element-type bignum-element-type (mod 2)) - (values bignum-element-type (mod 2)) - (foldable flushable movable)) - -(defknown bignum::%multiply (bignum-element-type bignum-element-type) - (values bignum-element-type bignum-element-type) - (foldable flushable movable)) - -(defknown bignum::%lognot (bignum-element-type) bignum-element-type - (foldable flushable movable)) - -(defknown (bignum::%logand bignum::%logior bignum::%logxor) - (bignum-element-type bignum-element-type) - bignum-element-type - (foldable flushable movable)) - -(defknown bignum::%fixnum-to-digit (fixnum) bignum-element-type - (foldable flushable movable)) - -(defknown bignum::%floor - (bignum-element-type bignum-element-type bignum-element-type) - (values bignum-element-type bignum-element-type) - (foldable flushable movable)) - -(defknown bignum::%fixnum-digit-with-correct-sign - (bignum-element-type) - fixnum - (foldable flushable movable)) - -(defknown (bignum::%signed-digit-to-single-float bignum::%digit-to-single-float) - (bignum-element-type) - (single-float) - (foldable flushable movable)) - -(defknown (bignum::%signed-digit-to-double-float bignum::%digit-to-double-float) - (bignum-element-type) - (double-float) - (foldable flushable movable)) - -(defknown (bignum::%ashl bignum::%ashr) - (bignum-element-type (mod 32)) bignum-element-type - (foldable flushable movable)) - - - -;;;; Bit-bashing routines. - -(defknown copy-to-system-area - ((simple-unboxed-array (*)) index system-area-pointer index index) - null - ()) - -(defknown copy-from-system-area - (system-area-pointer index (simple-unboxed-array (*)) index index) - null - ()) - -(defknown system-area-copy - (system-area-pointer index system-area-pointer index index) - null - ()) - -(defknown bit-bash-copy - ((simple-unboxed-array (*)) index - (simple-unboxed-array (*)) index index) - null - ()) diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp deleted file mode 100644 index 232051b221d474de3ccaf09724d6c8e895e05973..0000000000000000000000000000000000000000 --- a/compiler/generic/vm-tran.lisp +++ /dev/null @@ -1,265 +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/generic/vm-tran.lisp,v 1.10 1990/05/27 14:58:13 wlott Exp $ -;;; -;;; This file contains impelemtentation-dependent transforms. -;;; -;;; 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)) - -(def-source-transform structurep (x) - (once-only ((n-x x)) - `(and (simple-vector-p ,n-x) - (eql (%primitive get-vector-subtype ,n-x) - system:%g-vector-structure-subtype)))) - -(def-source-transform compiled-function-p (x) - `(functionp ,x)) - -(def-source-transform char-int (x) - `(char-code ,x)) - -(def-source-transform abs (x) - (once-only ((n-x x)) - `(if (< ,n-x 0) (- ,n-x) ,n-x))) - - - -(macrolet ((frob (name primitive) - `(def-source-transform ,name (&rest foo) - `(truly-the nil - (%primitive ,',primitive ,@foo))))) - (frob %type-check-error type-check-error) - (frob %odd-keyword-arguments-error odd-keyword-arguments-error) - (frob %unknown-keyword-argument-error unknown-keyword-argument-error) - (frob %argument-count-error argument-count-error)) - - -(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)) - - - -;;; Let these pass for now. - -(def-primitive-translator header-ref (obj slot) - (warn "Someone used HEADER-REF.") - `(%primitive data-vector-ref/simple-vector ,obj ,slot)) - -(def-primitive-translator header-set (obj slot value) - (warn "Someone used HEADER-SET.") - `(%primitive data-vector-set/simple-vector ,obj ,slot ,value)) - -(def-primitive-translator header-length (obj) - (warn "Someone used HEADER-LENGTH.") - `(%primitive vector-length ,obj)) - - - -;;;; Charater support. - -;;; There are really only base-chars. -;;; -(def-source-transform characterp (obj) - `(base-char-p ,obj)) - -;;; Keep this around in case someone uses it. -;;; -(def-source-transform %string-char-p (obj) - (warn "Someone used %string-char-p.") - `(base-char-p ,obj)) - - - - -;;;; Transforms for data-vector-ref for strange array types. - -(deftransform data-vector-ref ((array index) - (simple-array t)) - (let ((array-type (continuation-type array))) - (unless (array-type-p array-type) - (give-up)) - (let ((dims (array-type-dimensions array-type))) - (when (or (atom dims) (= (length dims) 1)) - (give-up)) - (let ((el-type (array-type-element-type array-type)) - (total-size (if (member '* dims) - '* - (reduce #'* dims)))) - `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type) - (,total-size)) - (%array-data-vector array)) - index))))) - -(deftransform data-vector-set ((array index new-value) - (simple-array t t)) - (let ((array-type (continuation-type array))) - (unless (array-type-p array-type) - (give-up)) - (let ((dims (array-type-dimensions array-type))) - (when (or (atom dims) (= (length dims) 1)) - (give-up)) - (let ((el-type (array-type-element-type array-type)) - (total-size (if (member '* dims) - '* - (reduce #'* dims)))) - `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type) - (,total-size)) - (%array-data-vector array)) - index - new-value))))) - - -;;; Transforms for getting at arrays of unsigned-byte n when n < 8. - -#+nil -(macrolet - ((frob (type bits) - `(progn - (deftransform data-vector-ref ((vector index) - (,type *)) - `(multiple-value-bind (word bit) - (floor index ,(truncate 16 ,bits)) - (ldb ,(ecase vm:target-byte-order - (:little-endian '(byte ,bits bit)) - (:big-endian '(byte 1 (- 16 ,bits bit)))) - (%raw-bits vector (+ (* word 16) - (* vm:vector-data-offset - vm:word-bits)))))) - (deftransform data-vector-set ((vector index new-value) - (,type * *)) - `(multiple-value-bind (word bit) - (floor index ,(truncate 16 ,bits)) - (setf (ldb ,(ecase vm:target-byte-order - (:little-endian '(byte ,bits bit)) - (:big-endian '(byte 1 (- 16 ,bits bit)))) - (%raw-bits vector (+ (* word 16) - (* vm:vector-data-offset - vm:word-bits)))) - new-value)))))) - (frob simple-bit-vector 1) - (frob (simple-array (unsigned-byte 2) (*)) 2) - (frob (simple-array (unsigned-byte 4) (*)) 4)) - - - - -;;;; Simple string transforms: - -(defconstant vector-data-bit-offset (* vm:vector-data-offset vm:word-bits)) - -(deftransform subseq ((string start &optional (end nil)) - (simple-string t &optional t)) - '(let* ((length (- (or end (length string)) - start)) - (result (make-string length))) - (bit-bash-copy string - (+ (* start vm:byte-bits) vector-data-bit-offset) - result - vector-data-bit-offset - (* length vm:byte-bits)) - result)) - - -(deftransform copy-seq ((seq) (simple-string)) - '(let* ((length (length seq)) - (res (make-string length))) - (bit-bash-copy seq - vector-data-bit-offset - res - vector-data-bit-offset - (* length vm:byte-bits)) - res)) - - -(deftransform replace ((string1 string2 &key (start1 0) (start2 0) - end1 end2) - (simple-string simple-string &rest t)) - '(progn - (bit-bash-copy string2 - (+ (* start2 vm:byte-bits) vector-data-bit-offset) - string1 - (+ (* start1 vm:byte-bits) vector-data-bit-offset) - (* (min (- (or end1 (length string1)) - start1) - (- (or end2 (length string2)) - start2)) - vm:byte-bits)) - string1)) - - -(deftransform concatenate ((rtype &rest sequences) - (t &rest simple-string) - simple-string) - (collect ((lets) - (forms) - (all-lengths) - (args)) - (dolist (seq sequences) - (declare (ignore seq)) - (let ((n-seq (gensym)) - (n-length (gensym))) - (args n-seq) - (lets `(,n-length (* (length ,n-seq) vm:byte-bits))) - (all-lengths n-length) - (forms `(bit-bash-copy ,n-seq vector-data-bit-offset - res start - ,n-length)) - (forms `(setq start (+ start ,n-length))))) - `(lambda (rtype ,@(args)) - (declare (ignore rtype)) - (let* (,@(lets) - (res (make-string (truncate (+ ,@(all-lengths)) vm:byte-bits))) - (start vector-data-bit-offset)) - (declare (type index start ,@(all-lengths))) - ,@(forms) - res)))) - - -;;;; Primitive translator for byte-blt - - -(def-primitive-translator byte-blt (src src-start dst dst-start dst-end) - `(let ((src ,src) - (src-start (* ,src-start vm:byte-bits)) - (dst ,dst) - (dst-start (* ,dst-start vm:byte-bits)) - (dst-end (* ,dst-end vm:byte-bits))) - (let ((length (- dst-end dst-start))) - (etypecase src - (system-area-pointer - (etypecase dst - (system-area-pointer - (system-area-copy src src-start dst dst-start length)) - ((simple-unboxed-array (*)) - (copy-from-system-area src src-start - dst (+ dst-start vector-data-bit-offset) - length)))) - ((simple-unboxed-array (*)) - (etypecase dst - (system-area-pointer - (copy-to-system-area src (+ src-start vector-data-bit-offset) - dst dst-start - length)) - ((simple-unboxed-array (*)) - (bit-bash-copy src (+ src-start vector-data-bit-offset) - dst (+ dst-start vector-data-bit-offset) - length)))))))) diff --git a/compiler/generic/vm-type.lisp b/compiler/generic/vm-type.lisp deleted file mode 100644 index d1eb1267b70623614210fa4a15d3845beb14b458..0000000000000000000000000000000000000000 --- a/compiler/generic/vm-type.lisp +++ /dev/null @@ -1,190 +0,0 @@ -;;; -*- Package: KERNEL; 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/generic/vm-type.lisp,v 1.14 1990/05/15 01:20:59 wlott Exp $ -;;; -;;; 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 "KERNEL") - - -;;;; 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. -;;; -;;; ### Bootstrap hack: if we frob these types in the old compiler environment, -;;; subtypep will break. -;;; -(compiler-let ((lisp::*bootstrap-deftype* t)) - -(deftype long-float (&optional low high) - `(double-float ,low ,high)) -;;; -(deftype short-float (&optional low high) - `(single-float ,low ,high)) - -); compiler-let -;;; Compiled-function is the same as function in this implementation. -;;; -(deftype compiled-function () 'function) - -;;; Character is the same as base-character. -;;; ### Bootstrap hack: base characters don't exist in the old compiler, -;;; so leave characters alone. Also, make string-char look like base-char. -(compiler-let ((lisp::*bootstrap-deftype* t)) - (remhash 'character *builtin-types*) - (deftype character () 'base-character) - (deftype string-char () 'base-character)) - -;;; -;;; 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 () 'list) -;;; -;;; 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 () 'char-code) -;;; -;;; 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) - -(deftype bignum-element-type () `(unsigned-byte ,vm:word-bits)) -(deftype bignum-type () 'bignum) -(deftype bignum-index () 'index) - - -;;;; 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) base-character single-float double-float)) - -(deftype unboxed-array (&optional dims) - (collect ((types (list 'or))) - (dolist (type specialized-array-element-types) - (when (subtypep type '(or integer character)) - (types `(array ,type ,dims)))) - (types))) - -(deftype simple-unboxed-array (&optional dims) - (collect ((types (list 'or))) - (dolist (type specialized-array-element-types) - (when (subtypep type '(or integer character)) - (types `(simple-array ,type ,dims)))) - (types))) - - -;;; 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 - (single-float 'single-float) - (double-float 'double-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)) - - -;;; Contaning-Integer-Type -- Interface -;;; -;;; Return the most specific integer type that can be quickly checked that -;;; includes the given type. -;;; -(defun containing-integer-type (subtype) - (dolist (type '(fixnum - (signed-byte 32) - (unsigned-byte 32) - integer) - (error "~S isn't an integer type?" subtype)) - (when (csubtypep subtype (specifier-type type)) - (return 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 'c::check-cons) - (symbol 'c::check-symbol) - (t nil))) - (numeric-type - (cond ((type= type (specifier-type 'fixnum)) - 'c::check-fixnum) - ((type= type (specifier-type '(signed-byte 32))) - 'c::check-signed-byte-32) - ((type= type (specifier-type '(unsigned-byte 32))) - 'c::check-unsigned-byte-32) - (t nil))) - (union-type - (if (type= type (specifier-type '(or function symbol))) - 'c::check-function-or-symbol - nil)) - (t - nil))) diff --git a/compiler/generic/vm-typetran.lisp b/compiler/generic/vm-typetran.lisp deleted file mode 100644 index c88d12c092c4a72eca37d696dcc476e8bb289812..0000000000000000000000000000000000000000 --- a/compiler/generic/vm-typetran.lisp +++ /dev/null @@ -1,59 +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/generic/vm-typetran.lisp,v 1.5 1990/05/14 01:59:07 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-character) -(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)) - -;;; 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/globaldb.lisp b/compiler/globaldb.lisp deleted file mode 100644 index a02732b79e5b30554bed2b327f06acd03ccb2656..0000000000000000000000000000000000000000 --- a/compiler/globaldb.lisp +++ /dev/null @@ -1,1170 +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 provides a functional interface to global information about -;;; named things in the system. Information is considered to be global if it -;;; must persist between invocations of the compiler. The use of a functional -;;; interface eliminates the need for the compiler to worry about the actual -;;; representation. This is important, since the information may well have -;;; several representations. This code also deals with the need for multiple -;;; "global" environments, so that changing something in the compiler doesn't -;;; trash the running Lisp environment. -;;; -;;; The database contains arbitrary Lisp values, addressed by a combination -;;; of Name, Class and Type. The Name is a EQUAL-thing which is the name of -;;; the thing we are recording information about. Class is the kind of object -;;; involved. Typical classes are Function, Variable, Type, ... A Type names -;;; a particular piece of information within a given class. Class and Type are -;;; symbols, but are compared with STRING=. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") -(use-package "EXTENSIONS") -(use-package "SYSTEM") - -(deftype index () `(integer 0 ,most-positive-fixnum)) - -;;; Undefined-Value -- Public -;;; -;;; This is here until we figure out what to do with it. -;;; -(proclaim '(inline undefined-value)) -(defun undefined-value () - '%undefined%) - -(in-package "EXTENSIONS") -(export '(info clear-info define-info-class define-info-type - make-info-environment do-info *info-environment* - compact-info-environment)) - -(in-package "C") - -;;; The defvar for this appears later. -(proclaim '(special *universal-type*)) -(proclaim '(type list type-specifier-symbols)) - - -;;; PRIMIFY -- Internal -;;; -;;; Given any non-negative integer, return a prime number >= to it. -;;; -(defun primify (x) - (declare (type unsigned-byte x)) - (do ((n (logior x 1) (+ n 2))) - ((system:primep n) n))) - - - -;;;; Defining info types: - -(eval-when (compile load eval) - -(defstruct (class-info - (:constructor make-class-info (name)) - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Class-Info ~S>" (class-info-name s))))) - ;; - ;; String name of this class. - (name nil :type simple-string) - ;; - ;; List of Type-Info structures for each type in this class. - (types () :type list)) - - -;;; At run-time, we represent the type of info that we want by a small -;;; non-negative integer. -;;; -(defconstant type-number-bits 6) -(deftype type-number () `(unsigned-byte ,type-number-bits)) -;;; -;;; Also initialized in GLOBALDB-INIT... -(defvar *type-numbers* - (make-array (ash 1 type-number-bits) :initial-element nil)) - - -(defstruct (type-info - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Type-Info ~S ~S, Number = ~D>" - (class-info-name (type-info-class s)) - (type-info-name s) - (type-info-number s))))) - - ;; - ;; String name of this type. - (name nil :type simple-string) - ;; - ;; This type's class. - (class nil :type class-info) - ;; - ;; A number that uniquely identifies this type (and implicitly its class.) - (number nil :type type-number) - ;; - ;; Type specifier which info of this type must satisfy. - (type nil :type t) - ;; - ;; Function called when there is no information of this type. Null at - ;; meta-compile time. - (default nil :type (or function null))) - - -;;; A hashtable from class names to Class-Info structures. This data structure -;;; exists at compile time as well as run time. Also initialized in -;;; GLOBALDB-INIT... -;;; -(defvar *info-classes* (make-hash-table :test #'equal)) -(proclaim '(hash-table *info-classes*)) - - -;;; FIND-TYPE-INFO -- Internal -;;; -;;; If Name is the name of a type in Class, then return the TYPE-INFO, -;;; otherwise NIL. -;;; -(defun find-type-info (name class) - (declare (simple-string name) (type class-info class)) - (dolist (type (class-info-types class) nil) - (when (string= (type-info-name type) name) - (return type)))) - - -;;; Class-Info-Or-Lose, Type-Info-Or-Lose -- Internal -;;; -;;; Return the info structure for an info class or type, or die trying. -;;; -(proclaim '(function class-info-or-lose (string) class-info)) -(defun class-info-or-lose (class) - (or (gethash class *info-classes*) - (error "~S is not a defined info class." class))) -;;; -(proclaim '(function type-info-or-lose (string string) type-info)) -(defun type-info-or-lose (class type) - (or (find-type-info type (class-info-or-lose class)) - (error "~S is not a defined info type." type))) - - -;;; Define-Info-Class -- Public -;;; -;;; Set up the data structures to support an info class. We make sure that -;;; the class exists at compile time so that macros can use it, but don't -;;; actually store the init function until load time so that we don't break the -;;; running compiler. -;;; -(defmacro define-info-class (class) - "Define-Info-Class Class - Define a new class of global information." - `(progn - (eval-when (compile load eval) - (%define-info-class ',(symbol-name class))) - ',class)) - - -;;; %Define-Info-Class -- Internal -;;; -;;; If there is no info for the class, then create it, otherwise do nothing. -;;; -(proclaim '(function %define-info-class (string) void)) -(defun %define-info-class (class) - (unless (gethash class *info-classes*) - (setf (gethash class *info-classes*) (make-class-info class)))) - - -;;; FIND-UNUSED-TYPE-NUMBER -- Internal -;;; -;;; Find a type number not already in use by looking for a null entry in -;;; *TYPE-NUMBERS*. -;;; -(defun find-unused-type-number () - (or (position nil *type-numbers*) - (error "Out of INFO type numbers!"))) - - -;;; Define-Info-Type -- Public -;;; -;;; The main thing we do is determine the type's number. We need to do this -;;; at macroexpansion time, since both the COMPILE and LOAD time calls to -;;; %DEFINE-INFO-TYPE must use the same type number. -;;; -(defmacro define-info-type (class type type-spec &optional default) - "Define-Info-Type Class Type default Type-Spec - Define a new type of global information for Class. Type is the symbol name - of the type, Default is the value for that type when it hasn't been set, and - Type-Spec is a type-specifier which values of the type must satisfy. The - default expression is evaluated each time the information is needed, with - Name bound to the name for which the information is being looked up. If the - default evaluates to something with the second value true, then the second - value of Info will also be true." - (let* ((class (symbol-name class)) - (type (symbol-name type)) - (old (find-type-info type (class-info-or-lose class)))) - `(progn - (eval-when (compile load eval) - (%define-info-type ',class ',type ',type-spec - ,(if old - (type-info-number old) - (find-unused-type-number)))) - (eval-when (load eval) - (setf (type-info-default (type-info-or-lose ',class ',type)) - #'(lambda (name) name ,default))) - ',type))) - - -;;; %Define-Info-Type -- Internal -;;; -;;; If there is no such type, create it. In any case, set the type -;;; specifier for the value. The class must exist. -;;; -(defun %define-info-type (class type type-spec number) - (declare (simple-string class type) (type type-number number)) - (let* ((class-info (class-info-or-lose class)) - (old (find-type-info type class-info)) - (res (or old - (make-type-info :name type - :class class-info - :number number - :type type-spec))) - (num-old (svref *type-numbers* number))) - (cond (old - (setf (type-info-type res) type-spec) - (unless (= (type-info-number res) number) - (cerror "Redefine it." "Changing type number for ~A ~A." - class type) - (setf (type-info-number res) number))) - (t - (push res (class-info-types class-info)))) - - (unless (eq num-old res) - (when num-old - (cerror "Go for it." "Reusing type number for ~A ~A." - (class-info-name (type-info-class num-old)) - (type-info-name num-old))) - (setf (svref *type-numbers* number) res))) - - (undefined-value)) - -); eval-when (compile load eval) - - -;;;; Info environments: -;;; -;;; We do info access relative to the current *info-environment*. This is a -;;; list of INFO-ENVIRONMENT structures we search. The variable is actually -;;; initialized in GLOBALDB-INIT. - -(defvar *info-environment*) -(proclaim '(type list *info-environment*)) - - -(defun %print-info-environment (s stream d) - (declare (ignore d) (stream stream)) - (format stream "#<~S ~S>" (type-of s) (info-env-name s))) - - -;;; Note: the CACHE-NAME slot is deliberately not shared for bootstrapping -;;; reasons. If we access with accessors for the exact type, then the inline -;;; type check will win. If the inline check didn't win, we would try to use -;;; the type system before it was properly initialized. -;;; -(defstruct (info-env (:print-function %print-info-environment)) - ;; - ;; Some string describing what is in this environment, for printing purposes - ;; only. - (name nil :type string)) - - -;;; INFO-HASH -- Internal -;;; -;;; Semantically equivalent to SXHASH, but optimized for legal function -;;; names. Note: semantically equivalent does *not* mean that it always -;;; returns the same value as SXHASH, just that it satisfies the formal -;;; definition of SXHASH. -;;; -;;; All we do for now is pick off the cases of a symbol and a list of two -;;; symbols [e.g. (SETF FOO)]. The symbol case is the same as what SXHASH -;;; does, but we get there more expeditiously. With the two-list, we LOGXOR a -;;; random constant with the hash of the second symbol. -;;; -(proclaim '(inline info-hash)) -(defun info-hash (x) - (cond - ((symbolp x) - #-new-compiler - (the fixnum (%primitive sxhash-simple-string (symbol-name x))) - #+new-compiler - (truly-the index (%primitive sxhash-simple-string (symbol-name x)))) - ((and (listp x) - (eq (car x) 'setf)) - (let ((next (cdr x))) - (when (listp next) - (let ((name (car next))) - (when (and (symbolp name) (null (cdr next))) - (return-from info-hash - (logxor #-new-compiler - (the fixnum - (%primitive sxhash-simple-string - (symbol-name name))) - #+new-compiler - (truly-the index - (%primitive sxhash-simple-string - (symbol-name name))) - 110680597)))))) - (sxhash x)) - (t - (sxhash x)))) - - -;;;; Generic interfaces: - -;;; Info -- Public -;;; -;;; This is a macro so that we can resolve the Class and Type to a type -;;; number at compile time. When we check the new-value's type directly in the -;;; SETF expansion, since the check can be done much more efficiently when the -;;; type is constant. -;;; -(defmacro info (class type name) - "Return the information of the specified Type and Class for Name. - The second value is true if there is any such information recorded. If there - is no information, the first value is the default and the second value is NIL." - ;; - ;; ### Should be a values type, but interpreter can't hack that now. - (let* ((class (symbol-name class)) - (type (symbol-name type)) - (info (type-info-or-lose class type))) - `(#+new-compiler truly-the #-new-compiler the - ,(type-info-type info) - (get-info-value ,name ,(type-info-number info))))) -;;; -(define-setf-method info (class type name) - "Set the global information for Name." - (let* ((n-name (gensym)) - (n-value (gensym)) - (class-str (symbol-name class)) - (type-str (symbol-name type)) - (info (type-info-or-lose class-str type-str))) - (values - `(,n-name) - `(,name) - `(,n-value) - `(progn - (check-type ,n-value ,(type-info-type info)) - (set-info-value ,n-name ,(type-info-number info) ,n-value)) - `(info ,class ,type ,n-name)))) - - -;;; DO-INFO -- Public -;;; -(defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym)) - (type-number (gensym)) (value (gensym))) - &body body) - "DO-INFO (Env &Key Name Class Type Value) Form* - Iterate over all the values stored in the Info-Env Env. Name is bound to - the entry's name, Class and Type are bound to the class and type - (represented as strings), and Value is bound to the entry's value." - (once-only ((n-env env)) - `(if (typep ,n-env 'volatile-info-env) - ,(do-volatile-info name class type type-number value n-env body) - ,(do-compact-info name class type type-number value n-env body)))) - - -(eval-when (compile load eval) - -;;; DO-COMPACT-INFO -- Internal -;;; -;;; Return code to iterate over a compact info environment. -;;; -(defun do-compact-info (name-var class-var type-var type-number-var value-var - n-env body) - (let ((n-index (gensym)) (n-type (gensym)) (punt (gensym))) - (once-only ((n-table `(compact-info-env-table ,n-env)) - (n-entries-index `(compact-info-env-index ,n-env)) - (n-entries `(compact-info-env-entries ,n-env)) - (n-entries-info `(compact-info-env-entries-info ,n-env)) - (n-type-numbers '*type-numbers*)) - `(dotimes (,n-index (length ,n-table)) - (declare (type index ,n-index)) - (block ,PUNT - (let ((,name-var (svref ,n-table ,n-index))) - (unless (eql ,name-var 0) - (do-anonymous ((,n-type (aref ,n-entries-index ,n-index) - (1+ ,n-type))) - (nil) - (declare (type index ,n-type)) - ,(once-only ((n-info `(aref ,n-entries-info ,n-type))) - `(let ((,type-number-var - (logand ,n-info compact-info-entry-type-mask))) - ,(once-only ((n-type-info - `(svref ,n-type-numbers - ,type-number-var))) - `(let ((,type-var (type-info-name ,n-type-info)) - (,class-var (class-info-name - (type-info-class ,n-type-info))) - (,value-var (svref ,n-entries ,n-type))) - #+new-compiler - (declare (ignorable ,type-var ,class-var - ,value-var)) - ,@body - (unless (zerop (logand ,n-info compact-info-entry-last)) - (return-from ,PUNT)))))))))))))) - -;;; DO-VOLATILE-INFO -- Internal -;;; -;;; Return code to iterate over a volatile info environment. -;;; -(defun do-volatile-info (name-var class-var type-var type-number-var value-var - n-env body) - (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym))) - (once-only ((n-table `(volatile-info-env-table ,n-env)) - (n-type-numbers '*type-numbers*)) - `(dotimes (,n-index (length ,n-table)) - (do-anonymous ((,n-names (svref ,n-table ,n-index) - (cdr ,n-names))) - ((null ,n-names)) - (let ((,name-var (caar ,n-names))) - #+new-compiler - (declare (ignorable ,name-var)) - (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types))) - ((null ,n-types)) - (let ((,type-number-var (caar ,n-types))) - ,(once-only ((n-type `(svref ,n-type-numbers - ,type-number-var))) - `(let ((,type-var (type-info-name ,n-type)) - (,class-var (class-info-name - (type-info-class ,n-type))) - (,value-var (cdar ,n-types))) - #+new-compiler - (declare (ignorable ,type-var ,class-var ,value-var)) - ,@body)))))))))) - - -); Eval-When (Compile Load Eval) - - -;;;; INFO cache: -;;; -;;; We use a hash cache to cache name X type => value for the current value -;;; of *INFO-ENVIRONMENT*. This is in addition to the per-environment caching -;;; of name => types. -;;; - -;;; The value of *INFO-ENVIRONMENT* that has cached values. *INFO-ENVIRONMENT* -;;; should nevern be destructively modified, so it is EQ to this, then the -;;; cache is valid. -;;; -(defvar *cached-info-environment*) - - -;;; INFO-CACHE-HASH -- Internal -;;; -;;; Hash function used for INFO cache. -;;; -(defmacro info-cache-hash (name type) - `(the fixnum - (logand - (the fixnum - (logxor (the fixnum (cache-hash-eq ,name)) - (the fixnum (ash (the fixnum ,type) 7)))) - #x3FF))) - - -(define-hash-cache info ((name eq) (type eq)) - :values 2 - :hash-function info-cache-hash - :hash-bits 10 - :default (values nil :empty)) - - -;;; INFO-CACHE-INIT -- Internal -;;; -;;; Set up the info cache. The top-level code of DEFINE-HASH-CACHE can't -;;; initialize the cache, since it must be initialized before we run any -;;; top-level forms. This is called in GLOBALDB-INIT. -;;; -(defun info-cache-init () - (setq *cached-info-environment* nil) - (setq *info-cache-vector* (make-array (* 4 (ash 2 10)))) - (info-cache-clear) - (undefined-value)) - - -;;; Whenever we GC, we must blow away the INFO cache, otherwise values might -;;; become unreachable (and hence not be updated), and then could become -;;; reachable again in a future GC. -;;; -(defun info-cache-gc-hook () - (setq *cached-info-environment* nil)) -;;; -(pushnew 'info-cache-gc-hook *after-gc-hooks*) - - -;;; CLEAR-INVALID-INFO-CACHE -- Internal -;;; -;;; If the info cache is invalid, then clear it. -;;; -(proclaim '(inline clear-invalid-info-cache)) -(defun clear-invalid-info-cache () - (unless (eq *info-environment* *cached-info-environment*) - (without-interrupts - (info-cache-clear) - (setq *cached-info-environment* *info-environment*)))) - - -;;;; Compact environments: - -;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV. -;;; -(defconstant compact-info-env-entries-bits 16) -(deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits)) - - -;;; Type of the values in COMPACT-INFO-ENTRIES-INFO. -;;; -(deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits))) - - -;;; This is an open hashtable with rehashing. Since modification is not -;;; allowed, we don't have to worry about deleted entries. We indirect through -;;; a parallel vector to find the index in the ENTRIES at which the entries for -;;; a given name starts. -;;; -(defstruct (compact-info-env - (:include info-env) - (:print-function %print-info-environment)) - ;; - ;; If this value is EQ to the name we want to look up, then the cache hit - ;; function can be called instead of the lookup function. - (cache-name 0) - ;; - ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has no - ;; entries. - (cache-index nil :type (or compact-info-entries-index null)) - ;; - ;; Hashtable of the names in this environment. If a bucket is unused, it is - ;; 0. - (table nil :type simple-vector) - ;; - ;; Indirection vector parallel to TABLE, translating indices in TABLE to the - ;; start of the ENTRIES for that name. Unused entries are undefined. - (index nil :type (simple-array compact-info-entries-index (*))) - ;; - ;; Vector contining in contiguous ranges the values of for all the types of - ;; info for each name. - (entries nil :type simple-vector) - ;; - ;; Vector parallel to ENTRIES, indicating the type number for the value - ;; stored in that location and whether this location is the last type of info - ;; stored for this name. The type number is in the low TYPE-NUMBER-BITS - ;; bits, and the next bit is set if this is the last entry. - (entries-info nil :type (simple-array compact-info-entry (*)))) - - -(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1)) -(defconstant compact-info-entry-last (ash 1 type-number-bits)) - - -;;; COMPACT-INFO-CACHE-HIT -- Internal -;;; -;;; Return the value of the type corresponding to Number for the currently -;;; cached name in Env. -;;; -(proclaim '(inline compact-info-cache-hit)) -(defun compact-info-cache-hit (env number) - (declare (type compact-info-env env) (type type-number number)) - (let ((entries-info (compact-info-env-entries-info env)) - (index (compact-info-env-cache-index env))) - (if index - (do ((index index (1+ index))) - (nil) - (declare (type index index)) - (let ((info (aref entries-info index))) - (when (= (logand info compact-info-entry-type-mask) number) - (return (values (svref (compact-info-env-entries env) index) - t))) - (unless (zerop (logand compact-info-entry-last info)) - (return (values nil nil))))) - (values nil nil)))) - - -;;; COMPACT-INFO-LOOKUP -- Internal -;;; -;;; Encache Name in the compact environment Env. Hash is the INFO-HASH of -;;; Name. -;;; -(defun compact-info-lookup (env name hash) - (declare (type compact-info-env env) (type index hash)) - (let* ((table (compact-info-env-table env)) - (len (length table)) - (len-2 (- len 2)) - (hash2 (- len-2 (rem hash len-2)))) - (macrolet ((lookup (test) - `(do ((probe (rem hash len) - (rem (+ probe hash2) len))) - (nil) - (let ((entry (svref table probe))) - (when (eql entry 0) - (return nil)) - (when (,test entry name) - (return (aref (compact-info-env-index env) - probe))))))) - (setf (compact-info-env-cache-index env) - (if (symbolp name) - (lookup eq) - (lookup equal))) - (setf (compact-info-env-cache-name env) name))) - - (undefined-value)) - - -;;; Exact density (modulo rounding) of the hashtable in a compact info -;;; environment in names/bucket. -;;; -(defconstant compact-info-environment-density 0.65) - - -;;; COMPACT-INFO-ENVIRONMENT -- Public -;;; -;;; Iterate over the environment once to find out how many names and entries -;;; it has, then build the result. This code assumes that all the entries for -;;; a name well be iterated over contiguously, which holds true for the -;;; implementation of iteration over both kinds of environments. -;;; -(defun compact-info-environment (env &key (name (info-env-name env))) - "Return a new compact info environment that holds the same information as - Env." - (let ((name-count 0) - (prev-name 0) - (entry-count 0)) - (do-info (env :name name) - (unless (eq name prev-name) - (incf name-count) - (setq prev-name name)) - (incf entry-count)) - - (let* ((table-size - (primify - (+ - (truncate - (/ name-count compact-info-environment-density)) - 3))) - (table (make-array table-size :initial-element 0)) - (index (make-array table-size - :element-type 'compact-info-entries-index)) - (entries (make-array entry-count)) - (entries-info (make-array entry-count - :element-type 'compact-info-entry))) - - (let ((prev-name 0) - (entries-idx 0)) - (do-info (env :name name :type-number num :value value) - (unless (eq prev-name name) - (setq prev-name name) - (let* ((hash (info-hash name)) - (len-2 (- table-size 2)) - (hash2 (- len-2 (rem hash len-2)))) - (do ((probe (rem hash table-size) - (rem (+ probe hash2) table-size))) - (nil) - (let ((entry (svref table probe))) - (when (eql entry 0) - (setf (svref table probe) name) - (setf (aref index probe) entries-idx) - (return)) - (assert (not (equal entry name)))))) - - (unless (zerop entries-idx) - (setf (aref entries-info (1- entries-idx)) - (logior (aref entries-info (1- entries-idx)) - compact-info-entry-last)))) - - (setf (aref entries-info entries-idx) num) - (setf (aref entries entries-idx) value) - (incf entries-idx))) - - (unless (zerop entry-count) - (setf (aref entries-info (1- entry-count)) - (logior (aref entries-info (1- entry-count)) - compact-info-entry-last))) - - (make-compact-info-env :name name - :table table - :index index - :entries entries - :entries-info entries-info)))) - - - -;;;; Volatile environments: - -;;; This is a closed hashtable, with the bucket being computed by taking the -;;; INFO-HASH of the Name mod the table size. -;;; -(defstruct (volatile-info-env - (:include info-env) - (:print-function %print-info-environment)) - - ;; - ;; If this value is EQ to the name we want to look up, then the cache hit - ;; function can be called instead of the lookup function. - (cache-name 0) - ;; - ;; The alist translating type numbers to values for the currently cached - ;; name. - (cache-types nil :type list) - ;; - ;; Vector of alists of alists of the form: - ;; ((Name . ((Type-Number . Value) ...) ...) - ;; - (table nil :type simple-vector) - ;; - ;; The number of distinct names currently in this table (each name may have - ;; multiple entries, since there can be many types of info. - (count 0 :type index) - ;; - ;; The number of names at which we should grow the table and rehash. - (threshold nil :type index)) - - -;;; VOLATILE-INFO-CACHE-HIT -- Internal -;;; -;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment. -;;; -(proclaim '(inline volatile-info-cache-hit)) -(defun volatile-info-cache-hit (env number) - (declare (type volatile-info-env env) (type type-number number)) - (dolist (type (volatile-info-env-cache-types env) (values nil nil)) - (when (eql (car type) number) - (return (values (cdr type) t))))) - - -;;; VOLATILE-INFO-LOOKUP -- Internal -;;; -;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment. -;;; -(defun volatile-info-lookup (env name hash) - (declare (type volatile-info-env env) (type index hash)) - (let ((table (volatile-info-env-table env))) - (macrolet ((lookup (test) - `(dolist (entry (svref table (mod hash (length table))) ()) - (when (,test (car entry) name) - (return (cdr entry)))))) - (setf (volatile-info-env-cache-types env) - (if (symbolp name) - (lookup eq) - (lookup equal))) - (setf (volatile-info-env-cache-name env) name))) - - (undefined-value)) - - -;;; WITH-INFO-BUCKET -- Internal -;;; -;;; Given a volatile environment Env, bind Table-Var the environment's table -;;; and Index-Var to the index of Name's bucket in the table. We also flush -;;; the cache so that things will be consistent if body modifies something. -;;; -(eval-when (compile eval) - (defmacro with-info-bucket ((table-var index-var name env) &body body) - (once-only ((n-name name) - (n-env env)) - `(progn - (setf (volatile-info-env-cache-name ,n-env) 0) - (let* ((,table-var (volatile-info-env-table ,n-env)) - (,index-var (mod (info-hash ,n-name) (length ,table-var)))) - ,@body))))) - - -;;; GET-WRITE-INFO-ENV -- Internal -;;; -;;; Get the info environment that we use for write/modification operations. -;;; This is always the first environment in the list, and must be a -;;; VOLATILE-INFO-ENV. -;;; -(proclaim '(inline get-write-info-env)) -(defun get-write-info-env () - (let ((env (car *info-environment*))) - (unless env - (error "No info environment?")) - (unless (typep env 'volatile-info-env) - (error "Cannot modify this environment: ~S." env)) - (the volatile-info-env env))) - - -;;; SET-INFO-VALUE -- Internal -;;; -;;; If Name is already present in the table, then just create or modify the -;;; specified type. Otherwise, add the new name and type, checking for -;;; rehashing. -;;; -;;; We rehash by making a new larger environment, copying all of the entries -;;; into it, then clobbering the old environment with the new environment's -;;; table. We clear the old table to prevent it from holding onto garbage if -;;; it is statically allocated. -;;; -(defun set-info-value (name type new-value &optional - (env (get-write-info-env))) - (declare (type type-number type) (type volatile-info-env env) - (inline assoc)) - (when (eql name 0) - (error "0 is not a legal INFO name.")) - (clear-invalid-info-cache) - (info-cache-enter name type new-value t) - (with-info-bucket (table index name env) - (let ((types (if (symbolp name) - (assoc name (svref table index) :test #'eq) - (assoc name (svref table index) :test #'equal)))) - (cond - (types - (let ((value (assoc type (cdr types)))) - (if value - (setf (cdr value) new-value) - (push (cons type new-value) (cdr types))))) - (t - (push (cons name (list (cons type new-value))) - (svref table index)) - - (let ((count (incf (volatile-info-env-count env)))) - (when (>= count (volatile-info-env-threshold env)) - (let ((new (make-info-environment :size (* count 2)))) - (do-info (env :name entry-name :type-number entry-num - :value entry-val) - (set-info-value entry-name entry-num entry-val new)) - (fill (volatile-info-env-table env) nil) - (setf (volatile-info-env-table env) - (volatile-info-env-table new)) - (setf (volatile-info-env-threshold env) - (volatile-info-env-threshold new))))))))) - - new-value) - - -;;; The maximum density of the hashtable in a volatile env (in names/bucket). -;;; -(defconstant volatile-info-environment-density 0.5) - - -;;; MAKE-INFO-ENVIRONMENT -- Public -;;; -;;; Make a new volatile environment of the specified size. -;;; -(defun make-info-environment (&key (size 42) (name "Unknown")) - (declare (type (integer 1) size)) - (let ((table-size - (primify - (truncate - (/ size volatile-info-environment-density))))) - (make-volatile-info-env - :name name - :table (make-array table-size :initial-element nil) - :threshold size))) - - -;;; CLEAR-INFO -- Public -;;; -(defmacro clear-info (class type name) - "Clear the information of the the specified Type and Class for Name in the - current environment, allowing any inherited info to become visible. We - return true if there was any info." - (let* ((class (symbol-name class)) - (type (symbol-name type)) - (info (type-info-or-lose class type))) - `(clear-info-value ,name ,(type-info-number info)))) -;;; -(defun clear-info-value (name type) - (declare (type type-number type) (inline assoc)) - (clear-invalid-info-cache) - (info-cache-enter name type nil :empty) - (with-info-bucket (table index name (get-write-info-env)) - (let ((types (assoc name (svref table index) :test #'equal))) - (when (and types - (assoc type (cdr types))) - (setf (cdr types) - (delete type (cdr types) :key #'car)) - t)))) - - -;;;; GET-INFO-VALUE: - -(eval-when (compile eval) - -;;; GET-INFO-VALUE-SEARCH -- Internal -;;; -;;; Return the value from the first environment which has it defined, or -;;; return the default if none does. We have a cache for the last name looked -;;; up in each environment. We don't compute the hash until the first time the -;;; cache misses. When the cache does miss, we invalidate it before calling -;;; the lookup routine to eliminate the possiblity of the cache being -;;; partially updated if the lookup is interrupted. -;;; -(defmacro get-info-value-search () - '(let ((hash nil)) - (dolist (env *info-environment* - (multiple-value-bind - (val winp) - (funcall (type-info-default (svref *type-numbers* type)) - name) - (values val winp))) - (macrolet ((frob (lookup cache slot) - `(progn - (unless (eq name (,slot env)) - (unless hash - (setq hash (info-hash name))) - (setf (,slot env) 0) - (,lookup env name hash)) - (multiple-value-bind - (value winp) - (,cache env type) - (when winp (return (values value t))))))) - (if (typep env 'volatile-info-env) - (frob volatile-info-lookup volatile-info-cache-hit - volatile-info-env-cache-name) - (frob compact-info-lookup compact-info-cache-hit - compact-info-env-cache-name)))))) - -); Eval-When (Compile Eval) - - -;;; GET-INFO-VALUE -- Internal -;;; -;;; Check if the name and type is in our cache, if so return it. Otherwise, -;;; search for the value and encache it. -;;; -(defun get-info-value (name type) - (declare (type type-number type)) - (clear-invalid-info-cache) - (multiple-value-bind (val winp) - (info-cache-lookup name type) - (if (eq winp :empty) - (multiple-value-bind (val winp) - (get-info-value-search) - (info-cache-enter name type val winp) - (values val winp)) - (values val winp)))) - - -;;;; Initialization: - -;;; GLOBALDB-INIT -- Interface -;;; -;;; Since the global enviornment database is used by top-level forms in this -;;; file, we must initialize the database before processing any top-level -;;; forms. This requires a special initialization function that is called from -;;; %INITIAL-FUNCTION. We replicate the init forms of the variables that -;;; maintain the class/type namespace. We also initialize the info cache. -;;; -(defun globaldb-init () - (unless (boundp '*info-environment*) - (setq *info-environment* - (list (make-info-environment :name "Initial Global")))) - (unless (boundp '*info-classes*) - (setq *info-classes* (make-hash-table :test #'equal)) - (setq *type-numbers* - (make-array (ash 1 type-number-bits) :initial-element nil))) - - (info-cache-init) - (function-info-init) - (other-info-init)) - - -;;;; Definitions for function information. - -(defun function-info-init () - -(define-info-class function) - -;;; The kind of functional object being described. If null, Name isn't a known -;;; functional object. -(define-info-type function kind (member nil :function :macro :special-form) - #+new-compiler - (if (fboundp name) :function nil) - #-new-compiler - nil) - -;;; The type specifier for this function. -(define-info-type function type ctype - #+new-compiler - (if (fboundp name) - (let ((def (fdefinition name))) - (let ((entry (if (eql (%primitive get-vector-subtype def) - %function-closure-subtype) - (%primitive header-ref def %function-name-slot) - def))) - (specifier-type - (%primitive header-ref entry %function-entry-type-slot)))) - (specifier-type 'function)) - #-new-compiler - (specifier-type 'function)) - -;;; The Assumed-Type for this function, if we have to infer the type due to not -;;; having a declaration or definition. -(define-info-type function assumed-type (or approximate-function-type null)) - -;;; Where this information came from: -;;; :declared, from a declaration. -;;; :assumed, from uses of the object. -;;; :defined, from examination of the definition. -(define-info-type function where-from (member :declared :assumed :defined) - #+new-compiler - (if (fboundp name) :defined :assumed) - #-new-compiler - :assumed) - -;;; Lambda used for inline expansion of this function. -(define-info-type function inline-expansion list) - -;;; Specifies whether this function may be expanded inline. If null, we -;;; don't care. -(define-info-type function inlinep inlinep nil) - -;;; A macro-like function which transforms a call to this function into some -;;; other Lisp form. This expansion is inhibited if inline expansion is -;;; inhibited. -(define-info-type function source-transform (or function null - #-new-compiler list)) - -;;; The macroexpansion function for this macro. -(define-info-type function macro-function (or function null - #-new-compiler list) - nil) - -;;; A function which converts this special form into IR1. -(define-info-type function ir1-convert (or function null - #-new-compiler list)) - -;;; A function which gets a chance to do stuff to the IR1 for any call to this -;;; function. -(define-info-type function ir1-transform (or function null - #-new-compiler list)) - -;;; If a function is an alien-operator, then this is the Alien-Info. -(define-info-type function alien-operator (or lisp::alien-info null) nil) - -;;; If a function is a defstruct slot accessor or setter, then this is the -;;; defstruct-definition for the structure that it belongs to. -(define-info-type function accessor-for (or defstruct-description null) - nil) - -;;; If a function is "known" to the compiler, then this is FUNCTION-INFO -;;; structure containing the info used to special-case compilation. -(define-info-type function info (or function-info null) nil) - -(define-info-type function documentation (or string null) nil) - -); defun function-info-init - -#| - Other: - Documentation? -|# - -;;;; Definitions for other random information. - -(defun other-info-init () - -(define-info-class variable) - -;;; The kind of variable-like thing described. -(define-info-type variable kind (member :special :constant :global) - #+new-compiler - (if (or (eq (symbol-package name) (symbol-package :end)) - (member name '(t nil))) - :constant - :global) - #-new-compiler - (if (constantp name) - :constant - :global)) - -;;; The declared type for this variable. -(define-info-type variable type ctype *universal-type*) - -;;; Where this type and kind information came from. -(define-info-type variable where-from (member :declared :assumed :defined) - :assumed) - -;;; The the lisp object which is the value of this constant, if known. -(define-info-type variable constant-value t - #+new-compiler - (if (boundp name) - (values (symbol-value name) t) - (values nil nil)) - #-new-compiler - (if (constantp name) - (values (symbol-value name) t) - (values nil nil))) - -(define-info-type variable alien-value (or lisp::ct-a-val null) nil) - -(define-info-type variable documentation (or string null) nil) - -(define-info-class type) - -;;; The kind of type described. We return :Structure for standard types that -;;; are implemented as structures. -;;; -(define-info-type type kind (member :primitive :defined :structure nil) - (if (member name type-specifier-symbols) - :primitive - nil)) - -;;; Expander function for a defined type. -(define-info-type type expander (or function null - #-new-compiler list) nil) - -;;; Print function for a type. -(define-info-type type printer (or function symbol null - #-new-compiler list) nil) - -;;; Defstruct description information for a structure type. DEFINED is the -;;; current global definition, and is not shadowed by compilation of -;;; structure definitions. -;;; -(define-info-type type structure-info (or defstruct-description null) nil) -(define-info-type type defined-structure-info (or defstruct-description null) - nil) - -(define-info-type type documentation (or string null)) - -;;; Function that parses type specifiers into CTYPE structures. -;;; -(define-info-type type translator (or function null list) nil) - -;;; If true, then the type coresponding to this name. -;;; -(define-info-type type builtin (or ctype null) nil) - - -(define-info-class declaration) -(define-info-type declaration recognized boolean) - -(define-info-class alien-stack) -(define-info-type alien-stack info (or lisp::stack-info null) nil) - -(define-info-class enumeration) -(define-info-type enumeration info (or lisp::enumeration-info null) nil) - -(define-info-class setf) - -(define-info-type setf inverse (or symbol null) nil) - -(define-info-type setf documentation (or string null) nil) - -(define-info-type setf expander (or function null - #-new-compiler list) nil) - -;;; Used for storing random documentation types. The stuff is an alist -;;; translating documentation kinds to values. -;;; -(define-info-class random-documentation) -(define-info-type random-documentation stuff list ()) - -); defun other-info-init diff --git a/compiler/globals.lisp b/compiler/globals.lisp deleted file mode 100644 index 62e5ce6a20f14e81cb5805b8cde39bc22b9f6fe0..0000000000000000000000000000000000000000 --- a/compiler/globals.lisp +++ /dev/null @@ -1,15 +0,0 @@ - -(in-package "C") -(proclaim '(special - *defprint-pretty* *event-info* *event-note-threshold* - *instruction-formats* *instructions* *current-fixup* *first-fixup* - *next-location* *code-vector* *labels* *current-label* - *last-label-created* *assembler-nodes* *current-assembler-node* - *last-assembler-node-created* *other-code-vector* - *other-next-location* *fixup-offset* *fixup-offset-map* - *fixup-last-shortening* *result-fixups* *source-path-tree* - *sc-numbers* *sb-list* *template-names* *sc-names* *sb-names* - *meta-sc-numbers* *primitive-type-names* *move-costs* *save-scs* - *save-costs* *restore-costs* *parsed-vops* - *compiler-error-context* *word-length* target-byte-order - *undefined-warnings* *meta-sb-names* *meta-sc-names*)) diff --git a/compiler/gtn.lisp b/compiler/gtn.lisp deleted file mode 100644 index 1223e1bd4317ef212eafc31cb1a1c915b7379808..0000000000000000000000000000000000000000 --- a/compiler/gtn.lisp +++ /dev/null @@ -1,218 +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 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. Let-P indicates whether this variable is -;;; for a let or a "real argument". In the latter case, we allocate the TNs -;;; environment-live unless SPEED is 3 so that the values are always available -;;; in the debugger. -;;; -(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) - *any-primitive-type* - (primitive-type (leaf-type var)))) - (temp (make-normal-tn type)) - (res (if (or let-p - (policy (lambda-bind fun) (= speed 3))) - temp - (environment-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 allocate TNs for argument -;;; passing locations at this point. XEPs differ in that the argument passing -;;; locations are wired and there are no implicit environment arguments. -;;; -(defun assign-ir2-environment (fun) - (declare (type clambda fun)) - (let ((env (lambda-environment fun)) - (xep-p (external-entry-point-p fun))) - (collect ((args) - (env)) - - (do ((vars (lambda-vars fun) (rest vars)) - (i -1 (1+ i))) - ((null vars)) - (let ((var (first vars))) - (when (leaf-refs var) - (args (if xep-p - (if (minusp i) - (make-argument-count-location) - (standard-argument-location i)) - (make-normal-tn (primitive-type (leaf-type var)))))))) - - (dolist (thing (environment-closure env)) - (let ((ptype (etypecase thing - (lambda-var - (if (lambda-var-indirect thing) - *any-primitive-type* - (primitive-type (leaf-type thing)))) - (nlx-info *any-primitive-type*)))) - (unless xep-p - (args (make-normal-tn ptype))) - (env (cons thing (make-normal-tn ptype))))) - - (let ((res - (make-ir2-environment - :arg-locs (args) :environment (env) - :old-fp-pass (make-old-fp-passing-location xep-p) - :return-pc-pass (make-return-pc-passing-location xep-p)))) - (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)) - (do-uses (use (return-result (lambda-return fun)) 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-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))) - (if (or (eq count :unknown) - (use-standard-returns tails)) - (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 Env has a Tail-Set, and the 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))) - (when tails - (let ((returns (or (tail-set-info tails) - (setf (tail-set-info tails) - (return-info-for-set tails))))) - (when (and (not (eq (return-info-kind returns) :unknown)) - (external-entry-point-p fun)) - (do-uses (use (return-result (lambda-return fun))) - (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 (eq (cleanup-kind (nlx-info-cleanup nlx)) :entry) - (make-normal-tn *any-primitive-type*)) - :save-sp (make-nlx-sp-tn env))))) - (undefined-value)) diff --git a/compiler/ir1final.lisp b/compiler/ir1final.lisp deleted file mode 100644 index 2d1a5917dac9475ca715d41a7feef2174e476e82..0000000000000000000000000000000000000000 --- a/compiler/ir1final.lisp +++ /dev/null @@ -1,97 +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 implements the IR1 finalize phase, which checks for various -;;; semantic errors. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; IR1-Finalize -- Interface -;;; -;;; We do a number of things: -;;; 2] Find any unknown free functions. -;;; 3] Accumulate approximate function type info for unknown functions. -;;; 4] Update the global type for functions newly defined. -;;; 5] Emit any delayed notes about failed optimizations. -;;; -(proclaim '(function ir1-finalize () void)) -(defun ir1-finalize () - (maphash #'check-free-function *free-functions*) - (maphash #'note-failed-optimization *failed-optimizations*)) - - -;;; 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. -;;; -(proclaim '(function note-failed-optimization (combination (or list ctype)) - void)) -(defun note-failed-optimization (node what) - (unless (or (node-deleted node) - (not (function-info-p (combination-kind node)))) - (let ((*compiler-error-context* node)) - (cond ((listp what) - (compiler-note "Unable to optimize because:~%~6T~?" - (first what) (rest what))) - (t - (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 optimize due to type uncertainty:~@ - ~{~6T~?~^~&~}" - (messages)))))))) - - -;;; Check-Free-Function -- Internal -;;; -;;; If the entry is a functional, then we update the global environment -;;; according to the new definition, checking for inconsistency. If the entry -;;; is an unknown global function, then we add the uses into the function's -;;; approximate type. -;;; -(proclaim '(function check-free-function (t leaf) void)) -(defun check-free-function (name leaf) - (etypecase leaf - (functional - (let* ((where (info function where-from name)) - (dtype (leaf-type leaf)) - (node (lambda-bind (main-entry leaf))) - (*compiler-error-context* node)) - (note-name-defined name :function) - - (when (function-type-p dtype) - (ecase where - (:assumed - (let ((approx-type (info function assumed-type name))) - (when approx-type - (valid-approximate-type approx-type dtype)))) - ((:declared :defined) - )) - - (when (and (eq (function-type-returns dtype) *empty-type*) - (policy node (>= safety brevity))) - (compiler-note "Function does not return.")) - - (setf (info function type name) dtype) - (clear-info function assumed-type name)) - - (setf (info function kind name) :function) - (setf (info function where-from name) :defined))) - (global-var))) diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp deleted file mode 100644 index 6244e0ecd9a16d54a0b2290a5f42db5c69509f43..0000000000000000000000000000000000000000 --- a/compiler/ir1opt.lisp +++ /dev/null @@ -1,1201 +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 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) - -;;; -;;; A hashtable from combination nodes to things describing how an -;;; optimization of the node failed. If the thing is a list, then it is format -;;; arguments. If it is a type, then the type is a type that the call failed -;;; to match. -;;; -(defvar *failed-optimizations* (make-hash-table :test #'eq)) - - -;;;; 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) - (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) type)) -(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 (eq (continuation-kind cont) :deleted) - (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))) - (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) - (setf (node-derived-type node) int) - (reoptimize-continuation (node-cont node)))))) - (undefined-value)) - - -;;; 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 -;;; BLOCK-TYPE-CHECK 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) - (let ((block (node-block node))) - (setf (block-type-check block) t) - (setf (block-type-asserted block) 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 -- Interface -;;; -;;; Do one forward pass over Component, deleting unreachable blocks and -;;; doing IR1 optimizations. We can ignore all blocks that don't have -;;; Block-Reoptimize 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-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 doing 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) - (when (node-reoptimize node) - (setf (node-reoptimize node) nil) - (typecase node - (ref) - (combination - (when (continuation-reoptimize (basic-combination-fun node)) - (propagate-function-change node)) - (when (dolist (arg (basic-combination-args node) nil) - (when (and arg (continuation-reoptimize arg)) - (return t))) - (ir1-optimize-combination node))) - (cif - (ir1-optimize-if node)) - (creturn - (setf (node-reoptimize node) t) - (ir1-optimize-return node)) - (mv-combination - (when (and (eq (basic-combination-kind node) :local) - (continuation-reoptimize - (first (basic-combination-args node)))) - (ir1-optimize-mv-bind 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-lambda next) - (let* ((last (block-last block)) - (last-cont (node-cont last)) - (next-cont (block-start next)) - (cleanup (block-end-cleanup block)) - (next-cleanup (block-start-cleanup next)) - (lambda (block-lambda block)) - (next-lambda (block-lambda next))) - (cond ((or (rest (block-pred next)) - (not (eq (continuation-use last-cont) last)) - (eq next block) - (not (eq (lambda-home lambda) (lambda-home next-lambda))) - (not (eq (find-enclosing-cleanup cleanup) - (find-enclosing-cleanup next-cleanup)))) - 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))) - (assert (not (continuation-dest next-cont))) - (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. The End-Cleanup for Block1 is set to that for -;;; Block2 so that we don't lose cleanup info. 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-end-cleanup block1) (block-end-cleanup block2)) - - (when (block-reoptimize block2) - (setf (block-reoptimize block1) t)) - (when (block-flush-p block2) - (setf (block-flush-p block1) t)) - (when (block-type-check block2) - (setf (block-type-check block1) t)) - (assert (not (block-delete-p block2))) - - (setf (block-type-asserted block1) t) - (setf (block-test-modified block1) t) - - (let ((next (block-next block2)) - (prev (block-prev block2))) - (setf (block-next prev) next) - (setf (block-prev next) prev)) - - (undefined-value)) - - -;;;; 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 is a local call, then we check that the called function has -;;; the tail set Tails. If we encounter any different tail set, we return -;;; the second value true. -;;; -- 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.) -;;; -(defun find-result-type (node tails) - (declare (type creturn node)) - (let ((result (return-result node)) - (retry nil)) - (collect ((use-union *empty-type* values-type-union)) - (do-uses (use result) - (if (and (basic-combination-p use) - (eq (basic-combination-kind use) :local)) - (when (merge-tail-sets use tails) - (setq retry t)) - (use-union (node-derived-type use)))) - (let ((int (values-type-intersection - (continuation-asserted-type result) - (use-union)))) - (setf (return-result-type node) int))) - retry)) - - -;;; Merge-Tail-Sets -- Internal -;;; -;;; This function handles merging the tail sets if Call is a call to a -;;; function with a different TAIL-SET than Ret-Set. We return true if we do -;;; anything. -;;; -;;; It is assumed that Call sends its value to a RETURN node. We -;;; destructively modify the set for the returning function to represent both, -;;; and then change all the functions in callee's set to reference the first. -;;; -;;; If the called function has no tail set, then do nothing; if it doesn't -;;; return, then it can't affect the callers value. -;;; -(defun merge-tail-sets (call ret-set) - (declare (type basic-combination call) (type tail-set ret-set)) - (let ((fun-set (lambda-tail-set (combination-lambda call)))) - (when (and fun-set (not (eq ret-set fun-set))) - (let ((funs (tail-set-functions fun-set))) - (dolist (fun funs) - (setf (lambda-tail-set fun) ret-set)) - (setf (tail-set-functions ret-set) - (nconc (tail-set-functions ret-set) funs))) - t))) - - -;;; 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.) -;;; -;;; During this iteration, we may discover new functions that should be -;;; added to the tail set. If this happens, we restart the iteration over the -;;; TAIL-SET-FUNCTIONS. Note that this really doesn't duplicate much work, as -;;; we clear the NODE-REOPTIMIZE flags in the return nodes as we go, thus we -;;; don't call FIND-RESULT-TYPE on any given return more than once. -;;; -;;; Restarting the iteration doesn't disturb the computation of the result -;;; type RES, since we will just be adding more types to the union. (or when -;;; we iterate over a return multiple times, unioning in the same type more -;;; than once.) -;;; -;;; 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)))) - (collect ((res *empty-type* values-type-union)) - (loop - (block RETRY - (let ((funs (tail-set-functions tails))) - (dolist (fun funs) - (let ((return (lambda-return fun))) - (when (node-reoptimize return) - (setf (node-reoptimize node) nil) - (when (find-result-type return tails) (return-from RETRY))) - (res (return-result-type return))))) - (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)) - - -;;; 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)) -;;; -(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 :source (node-source node) - :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) - - (reoptimize-continuation test) - (reoptimize-continuation new-cont) - (setf (component-reanalyze *current-component*) t))) - (undefined-value)) - - -;;;; 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 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 (lambda-home (block-lambda (node-block node))) - (lambda-home (block-lambda (node-block entry))))) - (prog1 - (unlink-node node) - (when value - (substitute-continuation-uses cont value)))))) - - -;;;; Combination IR1 optimization: - -;;; Ir1-Optimize-Combination -- Internal -;;; -;;; Do IR1 optimizations on a Combination node. -;;; -(proclaim '(function ir1-optimize-combination (combination) void)) -(defun ir1-optimize-combination (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 - (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))))) - - (let ((fun (function-info-optimizer kind))) - (unless (and fun (funcall fun node)) - (dolist (x (function-info-transforms kind)) - (unless (ir1-transform node (car x) (cdr x)) - (return)))))))) - - (undefined-value)) - - -;;; Recognize-Known-Call -- Interface -;;; -;;; If Call is a call to a known function, mark it as such by setting the -;;; Kind. 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. -;;; -(defun recognize-known-call (call) - (declare (type combination call)) - (let* ((fun (basic-combination-fun call)) - (name (continuation-function-name fun))) - (when name - (let ((info (info function info name))) - (cond (info - (setf (basic-combination-kind call) info)) - ((slot-accessor-p (ref-leaf (continuation-use fun))) - (setf (basic-combination-kind call) - (info function info - (if (consp name) - '%slot-setter - '%slot-accessor)))))))) - (undefined-value)) - - -;;; Propagate-Function-Change -- Internal -;;; -;;; Called by Ir1-Optimize when the function for a call has changed. -;;; If the call is to a functional, then we attempt to convert it to a local -;;; call, otherwise we check the call for legality with respect to the new -;;; type; if it is illegal, we mark the Ref as :Notline and punt. -;;; -;;; If we do have a good type for the call, we propagate type information from -;;; the type to the arg and result continuations. If we discover that the call -;;; is to a known global function, then we mark the combination as known. -;;; -(defun propagate-function-change (call) - (declare (type combination call)) - (let* ((fun (combination-fun call)) - (use (continuation-use fun)) - (type (continuation-derived-type fun)) - (*compiler-error-context* call)) - (setf (continuation-reoptimize fun) nil) - (cond ((or (not (ref-p use)) - (eq (ref-inlinep use) :notinline))) - ((functional-p (ref-leaf use)) - (let ((leaf (ref-leaf use))) - (cond ((eq (combination-kind call) :local) - (let ((tail-set (lambda-tail-set leaf))) - (when tail-set - (derive-node-type - call (tail-set-type tail-set))))) - ((not (eq (ref-inlinep use) :notinline)) - (convert-call-if-possible use call) - (maybe-let-convert leaf))))) - ((not (function-type-p type))) - ((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) - (recognize-known-call call)) - (t - (setf (ref-inlinep use) :notinline)))) - - (undefined-value)) - - -;;;; Known function optimization: - -;;; 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 type fun) - (declare (type combination node) (type ctype type) (type function fun)) - (let ((constrained (function-type-p type)) - (flame (policy node (> speed brevity))) - (*compiler-error-context* node)) - (cond ((or (not constrained) - (valid-function-use node type)) - (multiple-value-bind - (severity args) - (catch 'give-up - (transform-call node (funcall fun node)) - (remhash node *failed-optimizations*) - (values :none nil)) - (ecase severity - (:none nil) - (:aborted - (setf (combination-kind node) :full) - (setf (ref-inlinep (continuation-use (combination-fun node))) - :notinline) - (when args - (apply #'compiler-warning args)) - nil) - (:failure - (when (and flame args) - (setf (gethash node *failed-optimizations*) args)) - t)))) - ((and flame - (valid-function-use node type - :argument-test #'types-intersect - :result-test #'values-types-intersect)) - (setf (gethash node *failed-optimizations*) type) - t)))) - - -;;; 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. We set the Reanalyze flag in the component to cause the DFO to be -;;; recomputed at soonest convenience. -;;; -(defun transform-call (node res) - (declare (type combination node) (list res)) - (with-ir1-environment node - (let ((new-fun (ir1-convert-lambda res (node-source node))) - (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 full call and marking it as -;;; :notinline to make sure that it stays that way. -;;; -;;; For now, if the result is other than one value, we don't fold it. -;;; -(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 (ref-inlinep ref) :notinline) - (setf (combination-kind call) :full)) - ((= (length values) 1) - (with-ir1-environment call - (let* ((leaf (find-constant (first values))) - (node (make-ref (leaf-type leaf) - (node-source call) - leaf - nil)) - (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))))))) - - (undefined-value)) - - -;;;; Local call optimization: - -;;; 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 -- Internal -;;; -;;; 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 - (constant t) - (functional t) - (lambda-var - (null (lambda-var-sets leaf))) - (global-var - (case (global-var-kind leaf) - (:global-function - (not (eq (ref-inlinep ref) :notinline))) - (: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. -;;; -;;; 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)) - (dest (continuation-dest cont))) - (when (and (eq (continuation-use cont) ref) - dest - (not (typep dest '(or creturn exit mv-combination))) - (eq (lambda-home (block-lambda (node-block ref))) - (lambda-home (lambda-var-home var))) - (member (continuation-type-check arg) '(t nil)) - (member (continuation-type-check cont) '(t nil))) - (assert-continuation-type arg (continuation-asserted-type cont)) - (change-ref-leaf ref (find-constant nil)) - (substitute-continuation arg cont) - (reoptimize-continuation arg) - t))) - - -;;; 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 Ref'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. -;;; -;;; Note that we are responsible for clearing the Continuation-Reoptimize -;;; flags. -;;; -(defun propagate-let-args (call fun) - (declare (type combination call) (type clambda fun)) - (mapc #'(lambda (arg var) - (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 - (node-derived-type use) - (continuation-asserted-type arg))) - (substitute-leaf leaf var) - (propagate-to-refs var (continuation-type arg)) - t))))) - ((and (null (rest (leaf-refs var))) - (substitute-single-use-continuation arg var))) - (t - (propagate-to-refs var (continuation-type arg)))))) - (basic-combination-args call) - (lambda-vars 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)) - - -;;; 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)) - - -;;; 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)))))) - (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)) - diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp deleted file mode 100644 index 4b6dcde7d65dc56b20ae94327363f74028ba15b8..0000000000000000000000000000000000000000 --- a/compiler/ir1tran.lisp +++ /dev/null @@ -1,2928 +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 code which does the translation from Lisp code to the -;;; first intermediate representation (IR1). -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(export '(*compile-time-define-macros* *converting-for-interpreter*)) - -(in-package 'ext) -(export '(ignorable truly-the maybe-inline)) - -(in-package 'c) - - -(proclaim '(special *compiler-error-bailout* *template-names*)) - -;;; The *fenv* is used to keep track of the meaning of the names of functional -;;; objects during IR1 translation. It is an alist with the car of each entry -;;; being the name of the function. If the cdr is a Leaf structure, then the -;;; name is bound to the function it represents. If the cdr is -;;; (macro . (lambda ...)) then the lambda is the macroexpansion function for a -;;; local macro. -;;; -(defvar *fenv*) - -;;; *inlines* is used to keep track of which functions may and may not be coded -;;; as inline functions. It is an alist (Leaf . Flag), where Leaf is the -;;; structure that represents the function and Flag is either :Inline or -;;; :Notinline, indicating the sense of the declaration. -;;; -(defvar *inlines*) - -;;; *type-restrictions* is an alist (Leaf . CType) which is used to keep track -;;; of "pervasive" type declarations. A pervasive type declaration is a type -;;; declaration that pertains to the type in a syntactic extent which does not -;;; correspond to a binding of the affected name. Currently Common Lisp only -;;; allows pervasive type declarations on variables in the function namespace. -;;; -(defvar *type-restrictions*) - -;;; *venv* translates from variable names to Leaf structures. A special -;;; binding is indicated by a :Special Global-Var leaf. Each special binding -;;; within the code gets a distinct var structure, as does the current "global" -;;; value on entry to the code compiled. (locally (special ...)) is handled by -;;; adding the most recent special binding to the front of the list. -;;; -(defvar *venv*) - -;;; *benv* and *tenv* are alists from block and go-tag names to 2-lists of the -;;; form (<entry> <continuation>), where <continuation> is the continuation to -;;; exit to, and <entry> is the corresponding Entry node. -;;; -(defvar *benv*) -(defvar *tenv*) -(proclaim '(list *fenv* *inlines* *type-restrictions* *venv* *benv* *tenv*)) - -;;; *free-variables* translates from the names of variables referenced globally -;;; to the Leaf structures for them. *free-functions* is like -;;; *free-variables*, only it deals with function names. -;;; -;;; We must preserve the property that a proclamation for a global thing -;;; only affects the code after it. This takes some work, since a proclamation -;;; may appear in the middle of a block being compiled. If there are -;;; references before the proclaim, then we copy the current entry before -;;; modifying it. Code converted before the proclaim sees the old Leaf, while -;;; code after it sees the new Leaf. -;;; -(defvar *free-variables*) -(defvar *free-functions*) -(proclaim '(hash-table *free-variables* *free-functions*)) - -;;; We use the same Constant structure to represent all equal anonymous -;;; constants. This hashtable translates from constants to the Leafs that -;;; represent them. -;;; -(defvar *constants*) -(proclaim '(hash-table *constants*)) - -;;; *Current-Cookie* represents locally bound state information; declaration -;;; processing binds it. -;;; -(proclaim '(type cookie *current-cookie*)) -(defvar *current-cookie*) - -;;; *source-paths* is a hashtable from source code forms to the path taken -;;; through the source to reach the form. This provides a way to keep track of -;;; the location of original source forms, even when macroexpansions and other -;;; arbitary permutations of the code happen. This table is initialized by -;;; calling Find-Source-Paths on the original source. -;;; -(proclaim '(hash-table *source-paths*)) -(defvar *source-paths*) - -;;; *current-lambda* is used to keep track of the function currently being -;;; translated. Blocks point to the current lambda so that we can find the -;;; environment that they run in. -;;; -(proclaim '(type (or clambda null) *current-lambda*)) -(defvar *current-lambda*) - -;;; *Current-Component* is the Component structure which we link blocks into as -;;; we generate them. This just serves to glue the emitted blocks together -;;; until local call analysis and flow graph canonicalization figure out what -;;; is really going on. We need to keep track of all the blocks generated so -;;; that we can delete them if they turn out to be unreachable. -;;; -(proclaim '(type (or component null) *current-component*)) -(defvar *current-component*) - -;;; *Current-Cleanup* is similar to *Current-Lambda*, but used to keep track -;;; of the enclosing Cleanup. If there is no cleanup, then this is the same as -;;; *Current-Lambda*. -;;; -(proclaim '(type (or cleanup clambda null) *current-cleanup*)) -(defvar *current-cleanup*) - -;;; *Current-Path* is the source path of the form we are currently translating. -;;; If the path for the form is unknown, then this is the path for the -;;; innermost enclosing form for which the path is known. -;;; -(proclaim '(list *current-path*)) -(defvar *current-path* nil) - -;;; *Current-Form* is the form that is currently being converted into IR1. -;;; This is used to provide context for errors found during IR1 conversion. -;;; -(defvar *current-form* nil) - -;;; *Converting-For-Interpreter* is true when we are creating IR1 to be -;;; interpreted rather than compiled. This inhibits source tranformations and -;;; stuff. -;;; -(defvar *converting-for-interpreter* nil) - -;;; *Compile-Time-Define-Macros* is true when we want DEFMACRO definitions to -;;; be installed in the compilation environment as interpreted functions. We -;;; set this to false when compiling some parts of the system. -;;; -(defvar *compile-time-define-macros* t) - - -;;; IR1-Error-Bailout -- Internal -;;; -;;; Bind *compiler-error-bailout* to a function throws out of the body and -;;; converts a proxy form instead. -;;; -(defmacro ir1-error-bailout ((start cont form) &body body) - `(catch 'ir1-error-abort - (let ((*bailout-start* ,start) - (*bailout-cont* ,cont) - (*bailout-form* ,form) - (*compiler-error-bailout* - #'(lambda () - (ir1-convert - *bailout-start* *bailout-cont* - `(error "Execution of a form compiled with errors:~% ~S" - ',*bailout-form*)) - (throw 'ir1-error-abort nil)))) - (declare (special *bailout-start* *bailout-cont* *bailout-form*)) - ,@body - nil))) - - -;;; IR1-Convert -- Interface -;;; -;;; Translate Form into IR1. The code is inserted as the Next of the -;;; continuation Start. Cont is the continuation which receives the value of -;;; the Form to be translated. The translators call this function recursively -;;; to translate their subnodes. -;;; -;;; As a special hack to make life easier in the compiler, a Leaf -;;; IR1-converts into a reference to that leaf structure. This allows the -;;; creation using backquote of forms that contain leaf references, without -;;; having to introduce dummy names into the namespace. -;;; -(proclaim '(function ir1-convert (continuation continuation t) void)) -(defun ir1-convert (start cont form) - (ir1-error-bailout (start cont form) - (if (atom form) - (cond ((and (symbolp form) (not (keywordp form))) - (ir1-convert-variable start cont form)) - ((leaf-p form) - (reference-leaf start cont form nil)) - ((constantp form) - (reference-constant start cont form form)) - (t - (compiler-error "Cannot evaluate this object: ~S" form))) - (let ((fun (car form)) - (*current-form* form) - (*current-path* (or (gethash form *source-paths*) - *current-path*))) - (cond - ((symbolp fun) - (let ((lexical-def (cdr (assoc fun *fenv*)))) - (cond - ((not lexical-def) - (ir1-convert-global-functoid start cont form)) - ((leaf-p lexical-def) - (ir1-convert-local-function start cont form lexical-def)) - ((and (consp lexical-def) (eq (car lexical-def) 'macro)) - (ir1-convert-macro start cont (cdr lexical-def) form)) - (t - (error "Malformed *fenv* entry: ~S." lexical-def))))) - ((or (atom fun) (not (eq (car fun) 'lambda))) - (compiler-error "Illegal function call.")) - (t - (ir1-convert-combination start cont form - (ir1-convert-lambda fun)))))))) - -;;; IR1-Convert-Global-Functoid -- Internal -;;; -;;; Convert anything that looks like a special-form, global function or -;;; macro call. If the thing has a ir1-convert method, but we are at top level -;;; and the method can't be used there, then convert the form in the initial -;;; component. -;;; -(defun ir1-convert-global-functoid (start cont form) - (declare (type continuation start cont) - (list form)) - (let* ((fun (first form)) - (translator (info function ir1-convert fun))) - (if translator - (funcall translator start cont form) - (ecase (info function kind fun) - (:macro - (let ((expander (info function macro-function fun))) - (assert expander (expander) - "No macro-function for global macro ~S." fun) - (ir1-convert-macro start cont expander form))) - ((nil :function) - (ir1-convert-global-function start cont form))))) - (undefined-value)) - - -;;; IR1-Convert-Macro -- Internal -;;; -;;; Trap errors during the macroexpansion. -;;; -(defun ir1-convert-macro (start cont fun form) - (declare (type continuation start cont)) - (ir1-convert start cont - (handler-case (funcall fun form *fenv*) - (error (condition) - (compiler-error "(during macroexpansion)~%~A" - condition))))) - - -;;; Leaf-Inlinep -- Internal -;;; -;;; Return the current Inlinep value for references to Leaf. -;;; -(defun leaf-inlinep (leaf) - (declare (type leaf leaf)) - (let ((found (assoc leaf *inlines*))) - (if found - (cdr found) - (etypecase leaf - (functional nil) - (global-var - (assert (eq (global-var-kind leaf) :global-function)) - (info function inlinep (leaf-name leaf))))))) - - -;;; IR1-Convert-Local-Function -- Internal -;;; -;;; Convert a call to a local function. If speed is important, we a have an -;;; inline expansion and the function is :inline, then convert the inline -;;; expansion instead of a reference to the existing function. -;;; -(proclaim '(function ir1-convert-local-function - (continuation continuation t leaf) void)) -(defun ir1-convert-local-function (start cont form var) - (let ((inlinep (leaf-inlinep var)) - (expansion (if (functional-p var) - (functional-inline-expansion var)))) - (if (and expansion (eq inlinep :inline) - (policy nil (>= speed space) (>= speed cspeed))) - (ir1-convert-combination start cont form - (let ((*fenv* (functional-fenv var)) - (*venv* (functional-venv var)) - (*tenv* (functional-tenv var)) - (*benv* (functional-benv var))) - (ir1-convert-lambda expansion form)) - :inline) - (ir1-convert-combination start cont form var inlinep)))) - - -;;; IR1-Convert-Combination -- Internal -;;; -;;; Convert a function call where the function is a Leaf. Inlinep is the -;;; value of Inlinep for the Ref. We return the Combination node so that we -;;; can poke at it if we want to. -;;; -(proclaim '(function ir1-convert-combination - (continuation continuation list leaf &optional inlinep) - combination)) -(defun ir1-convert-combination (start cont form fun &optional (inlinep nil)) - (let ((fun-cont (make-continuation))) - (reference-leaf start fun-cont fun inlinep) - (ir1-convert-combination-args fun-cont cont form))) - - -;;; IR1-Convert-Combination-Args -- Internal -;;; -;;; Convert the arguments to a call and make the Combination node. Fun-Cont -;;; is the continuation which yields the function to call. Form is the source -;;; for the call. Source is the source for the call. Args is the list of -;;; arguments for the call, which defaults to the cdr of source. We return the -;;; Combination node. -;;; -(proclaim '(function ir1-convert-combination-args - (continuation continuation list &optional list) - combination)) -(defun ir1-convert-combination-args (fun-cont cont source &optional (args (cdr source))) - (let ((node (make-combination source fun-cont))) - (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) - (collect ((arg-conts)) - (let ((this-start fun-cont)) - (dolist (arg args) - (let ((this-cont (make-continuation node))) - (ir1-convert this-start this-cont arg) - (setq this-start this-cont) - (arg-conts this-cont))) - (prev-link node this-start) - (use-continuation node cont) - (setf (combination-args node) (arg-conts)))) - node)) - - -;;; IR1-Convert-Progn-Body -- Internal -;;; -;;; Convert a bunch of forms, discarding all the values except the last. -;;; If there aren't any forms, then translate a NIL. -;;; -(proclaim '(function ir1-convert-progn-body (continuation continuation list) void)) -(defun ir1-convert-progn-body (start cont body) - (if (endp body) - (reference-constant start cont nil nil) - (let ((this-start start) - (forms body)) - (loop - (let ((form (car forms))) - (when (endp (cdr forms)) - (ir1-convert this-start cont form) - (return)) - (let ((this-cont (make-continuation))) - (ir1-convert this-start this-cont form) - (setq this-start this-cont forms (cdr forms)))))))) - - -;;; IR1-Convert-Global-Function -- Internal -;;; -;;; Convert a call to a global function. If the function has a -;;; source-transform and inline expansion is enabled then we convert its -;;; expansion. If the source transform returns a non-null second value, then -;;; we act as though there was no source transformation, and directly convert -;;; the call. -;;; -(proclaim '(function ir1-convert-global-function (continuation continuation list) void)) -(defun ir1-convert-global-function (start cont form) - (let ((name (car form))) - (multiple-value-bind (var inlinep) - (find-free-function name "in a reasonable place") - (cond - ((eq inlinep :notinline) - (ir1-convert-combination start cont form var inlinep)) - (*converting-for-interpreter* - (ir1-convert-ok-combination-fer-sher start cont form var)) - (t - (let ((transform (info function source-transform name)) - (expansion (info function inline-expansion name))) - (cond - (transform - (multiple-value-bind (result pass) - (funcall transform form) - (if pass - (ir1-convert-ok-combination start cont form var) - (ir1-convert start cont result)))) - (expansion - (ir1-convert-global-inline start cont form var inlinep expansion)) - (t - (when (and (eq inlinep :inline) (policy nil (> speed brevity)) - (not (info function info name))) - (compiler-note "~S is declared inline, but has no expansion." - name)) - (ir1-convert-ok-combination start cont form var))))))))) - - -;;; IR1-Convert-Ok-Combination -- Internal -;;; -;;; Convert a global function call that we are allowed to early bind. We -;;; find any Function-Info for Var. Although Var is not necessarily a -;;; Global-Var, it is in the global namespace, so we can assume that we know -;;; about it if we recognize the name. -;;; -;;; If the function has the Predicate attribute, and the CONT's DEST isn't -;;; an IF, then we convert (IF <form> T NIL), ensuring that a predicate always -;;; appears in a conditional context. -;;; -;;; If the function isn't a predicate, then we call -;;; IR1-Convert-OK-Combination-Fer-Sher. -;;; -(defun ir1-convert-ok-combination (start cont form var) - (declare (type continuation start cont) (list form) (type leaf var)) - (let ((info (info function info (leaf-name var)))) - (if (and info - (ir1-attributep (function-info-attributes info) predicate) - (not (if-p (continuation-dest cont)))) - (ir1-convert start cont `(if ,form t nil)) - (ir1-convert-ok-combination-fer-sher start cont form var)))) - - -;;; IR1-Convert-OK-Combination-Fer-Sher -- Internal -;;; -;;; Actually really convert a global function call that we are allowed to -;;; early-bind. -;;; -;;; If we know the function type of the function, then we check the call for -;;; syntactic legality with respect to the declared function type. If it is -;;; impossible to determine whether the call is correct due to non-constant -;;; keywords, then we give up, marking the Ref as :Notinline to inhibit further -;;; error messages. We return true when the call is legal. -;;; -;;; If the call is legal, we also propagate type assertions from the function -;;; type to the arg and result continuations. We do this now so that IR1 -;;; optimize doesn't have to redundantly do the check later so that it can do -;;; the type propagation. -;;; -;;; If the function is unknown, then we note the name and error context so that -;;; we can give a warning if the function is never defined. -;;; -(defun ir1-convert-ok-combination-fer-sher (start cont form var) - (declare (type continuation start cont) (list form) (type leaf var)) - (let ((fun-cont (make-continuation))) - (reference-leaf start fun-cont var nil) - (let ((type (leaf-type var)) - (node (ir1-convert-combination-args fun-cont cont form))) - (cond - ((eq (leaf-where-from var) :assumed) - (let ((name (leaf-name var))) - (when (and (eq (info function where-from name) :assumed) - (eq (info function kind name) :function)) - (let ((*compiler-error-context* node)) - (note-undefined-reference name :function)) - (setf (info function assumed-type name) - (note-function-use node - (info function assumed-type name))))) - nil) - ((not (function-type-p type)) nil) - ((valid-function-use node type - :argument-test #'always-subtypep - :result-test #'always-subtypep - :error-function #'compiler-warning - :warning-function #'compiler-note) - (recognize-known-call node) - (assert-call-type node type) - (setf (continuation-%derived-type fun-cont) type) - (setf (continuation-reoptimize fun-cont) nil) - (setf (continuation-%type-check fun-cont) nil) - t) - (t - (setf (ref-inlinep (continuation-use fun-cont)) :notinline) - nil))))) - - -;;; In-Null-Environment -- Internal -;;; -;;; Return true if the lexical environment is null. If Macros-OK is true, -;;; then it is ok for there there to be local macros and other compile-time -;;; stuff in the environment. -;;; -(defun in-null-environment (&optional macros-ok) - (and (if macros-ok - (every #'(lambda (x) - (let ((val (cdr x))) - (and (consp val) - (eq (car val) 'macro)))) - *fenv*) - (null *fenv*)) - (null *benv*) (null *venv*) (null *tenv*))) - - -;;; IR1-Convert-Global-Lambda -- Internal -;;; -;;; Like IR1-Convert-Lambda except that we null out the environment -;;; variables around the conversion. -;;; -(proclaim '(function ir1-convert-global-lambda (t t) functional)) -(defun ir1-convert-global-lambda (fun source) - (let ((*fenv* ()) - (*benv* ()) - (*venv* ()) - (*tenv* ())) - (ir1-convert-lambda fun source))) - - -;;; IR1-Convert-Global-Inline -- Internal -;;; -;;; Convert a call to a global function which has an inline expansion. We -;;; make a number of speed v.s. space policy decisions using information from -;;; our extended inline declaration. We don't do anything unless either the -;;; function is :INLINE or space is totally unimportant. If :INLINE, we do -;;; normal copy-per-call inlining, otherwise we share a single copy across all -;;; calls. -;;; -;;; We allow inlining of recursive functions through a similar hack to that -;;; used for LABELS. Recursive inline expansion is prevented, instead we do a -;;; recursive local call. -;;; -(proclaim '(function ir1-convert-global-inline - (continuation continuation t leaf inlinep list) - void)) -(defun ir1-convert-global-inline (start cont form var inlinep expansion) - (if (and (case inlinep - (:notinline nil) - (:inline t) - (t (policy nil (zerop space)))) - (not (functional-p var))) - (let* ((name (leaf-name var)) - (dummy (make-functional :name name))) - (setf (gethash name *free-functions*) dummy) - (let ((fun (ir1-convert-global-lambda expansion form))) - (setf (leaf-name fun) name) - (substitute-leaf fun dummy) - (setf (gethash name *free-functions*) - (if (eq inlinep :inline) - var - fun)) - (ir1-convert-combination start cont form fun))) - (ir1-convert-ok-combination start cont form var))) - - -;;;; Lambda hackery: - -;;; Varify-Lambda-Arg -- Internal -;;; -;;; Verify that a thing is a legal name for a variable and return a Var -;;; structure for it, filling in info if it is globally special. If it is -;;; losing, we punt with a Compiler-Error. Names-So-Far is an alist of names -;;; which have previously been bound. If the name is in this list, then we -;;; error out. -;;; -(proclaim '(function varify-lambda-arg (t list) var)) -(defun varify-lambda-arg (name names-so-far) - (unless (symbolp name) - (compiler-error "Lambda-variable is not a symbol: ~S." name)) - (when (member name names-so-far) - (compiler-error "Repeated variable in lambda-list: ~S." name)) - (let ((kind (info variable kind name))) - (when (or (keywordp name) (eq kind :constant)) - (compiler-error "Name of lambda-variable is a constant: ~S." name)) - (if (eq kind :special) - (let ((specvar (find-free-variable name))) - (make-lambda-var :name name - :type (leaf-type specvar) - :where-from (leaf-where-from specvar) - :specvar specvar)) - (make-lambda-var :name name)))) - - -;;; Make-Keyword -- Internal -;;; -;;; Make the keyword for a keyword arg, checking that the keyword isn't -;;; already used by one of the Vars. We also check that the keyword isn't the -;;; magical :allow-other-keys. -;;; -(proclaim '(function make-keyword (symbol list) keyword)) -(defun make-keyword (symbol vars) - (let ((key (if (keywordp symbol) symbol - (intern (symbol-name symbol) "KEYWORD")))) - (when (eq key :allow-other-keys) - (compiler-error "You can't have a keyword arg called :allow-other-keys.")) - (dolist (var vars) - (let ((info (lambda-var-arg-info var))) - (when (and info - (eq (arg-info-kind info) :keyword) - (eq (arg-info-keyword info) key)) - (compiler-error "Multiple uses of keyword ~S in lambda-list." key)))) - key)) - - -;;; Find-Lambda-Vars -- Internal -;;; -;;; Parse a lambda-list into a list of Var structures, stripping off any aux -;;; bindings. Each arg name is checked for legality, and duplicate names are -;;; checked for. If an arg is globally special, the var is marked as :special -;;; instead of :lexical. Keyword, optional and rest args are annotated with an -;;; arg-info structure which contains the extra information. If we hit -;;; something losing, we bug out with Compiler-Error. These values are -;;; returned: -;;; 1] A list of the var structures for each top-level argument. -;;; 2] A flag indicating whether &key was specified. -;;; 3] A flag indicating whether other keyword args are allowed. -;;; 4] A list of the &aux variables. -;;; 5] A list of the &aux values. -;;; -(proclaim '(function find-lambda-vars (list) (values list boolean list list))) -(defun find-lambda-vars (list) - (multiple-value-bind (required optional restp rest keyp keys allowp aux) - (parse-lambda-list list) - (collect ((vars) - (names-so-far) - (aux-vars) - (aux-vals)) - ;; - ;; Parse-Default deals with defaults and supplied-p args for optionals - ;; and keywords args. - (flet ((parse-default (spec info) - (when (consp (cdr spec)) - (setf (arg-info-default info) (second spec)) - (when (consp (cddr spec)) - (let* ((supplied-p (third spec)) - (supplied-var (varify-lambda-arg supplied-p (names-so-far)))) - (setf (arg-info-supplied-p info) supplied-var) - (names-so-far supplied-p) - (when (> (length spec) 3) - (compiler-error "Arg specifier is too long: ~S." spec))))))) - - (dolist (name required) - (let ((var (varify-lambda-arg name (names-so-far)))) - (vars var) - (names-so-far name))) - - (dolist (spec optional) - (if (atom spec) - (let ((var (varify-lambda-arg spec (names-so-far)))) - (setf (lambda-var-arg-info var) (make-arg-info :kind :optional)) - (vars var) - (names-so-far spec)) - (let* ((name (first spec)) - (var (varify-lambda-arg name (names-so-far))) - (info (make-arg-info :kind :optional))) - (setf (lambda-var-arg-info var) info) - (vars var) - (names-so-far name) - (parse-default spec info)))) - - (when restp - (let ((var (varify-lambda-arg rest (names-so-far)))) - (setf (lambda-var-arg-info var) (make-arg-info :kind :rest)) - (vars var) - (names-so-far rest))) - - (dolist (spec keys) - (cond ((atom spec) - (let ((var (varify-lambda-arg spec (names-so-far)))) - (setf (lambda-var-arg-info var) - (make-arg-info :kind :keyword - :keyword (make-keyword spec (vars)))) - (vars var) - (names-so-far spec))) - ((atom (first spec)) - (let* ((name (first spec)) - (var (varify-lambda-arg name (names-so-far))) - (info (make-arg-info :kind :keyword - :keyword (make-keyword name (vars))))) - (setf (lambda-var-arg-info var) info) - (vars var) - (names-so-far name) - (parse-default spec info))) - (t - (let ((head (first spec))) - (unless (= (length head) 2) - (error "Malformed keyword arg specifier: ~S." spec)) - (let* ((name (second head)) - (var (varify-lambda-arg name (names-so-far))) - (info (make-arg-info :kind :keyword - :keyword (make-keyword (first head) (vars))))) - (setf (lambda-var-arg-info var) info) - (vars var) - (names-so-far name) - (parse-default spec info)))))) - - (dolist (spec aux) - (cond ((atom spec) - (let ((var (varify-lambda-arg spec (names-so-far)))) - (aux-vars var) - (aux-vals nil) - (names-so-far spec))) - (t - (unless (<= 1 (length spec) 2) - (compiler-error "Malformed &aux binding specifier: ~S." spec)) - (let* ((name (first spec)) - (var (varify-lambda-arg name (names-so-far)))) - (aux-vars var) - (aux-vals (second spec)) - (names-so-far name))))) - - (values (vars) keyp allowp (aux-vars) (aux-vals)))))) - - -;;; Find-In-Bindings -- Internal -;;; -;;; Given a list of Lambda-Var structures and a variable name, return the -;;; structure for that name, or NIL if it isn't found. -;;; -(proclaim '(function find-in-bindings (list symbol) (or lambda-var null))) -(defun find-in-bindings (vars name) - (dolist (var vars) - (when (eq (leaf-name var) name) (return var)) - (let ((info (lambda-var-arg-info var))) - (when info - (let ((supplied-p (arg-info-supplied-p info))) - (when (and supplied-p - (eq (leaf-name supplied-p) name)) - (return supplied-p))))))) - - -;;; Find-Lexically-Apparent-Function -- Internal -;;; -;;; Return the Leaf structure for the lexically apparent function definition -;;; of Name. The second value is the inlinep information which currently -;;; applies to the variable. -;;; -(proclaim '(function find-lexically-apparent-function (symbol string) - (values var inlinep))) -(defun find-lexically-apparent-function (name context) - (let ((var (cdr (assoc name *fenv* :test #'equal)))) - (cond (var - (unless (leaf-p var) - (assert (and (consp var) (eq (car var) 'macro)) () - "Strange *fenv* entry: ~S." var) - (compiler-error "Found macro name ~S ~A." name context)) - (values var (leaf-inlinep var))) - (t - (find-free-function name context))))) - - -;;; Process-Type-Declaration -- Internal -;;; -;;; Called by Process-Declarations to deal with a variable type declaration. -;;; We return a list of new *TYPE-RESTRICTIONS*. -;;; -(proclaim '(function process-type-declaration (list list) void)) -(defun process-type-declaration (decl vars) - (let ((type (specifier-type (first decl)))) - (collect ((res)) - (dolist (var-name (rest decl)) - (let* ((bound-var (find-in-bindings vars var-name)) - (var (or bound-var - (cdr (assoc var-name *venv*)) - (find-free-variable var-name))) - (old-type (or (cdr (assoc var *type-restrictions*)) - (leaf-type var))) - (int (if (or (function-type-p type) - (function-type-p old-type)) - type - (type-intersection old-type type)))) - (cond ((eq int *empty-type*) - (unless (policy nil (= brevity 3)) - (compiler-warning - "Conflicting type declarations ~S and ~S for ~S." - (type-specifier old-type) (type-specifier type) var-name))) - (bound-var (setf (leaf-type bound-var) int)) - (t - (res (cons var int)))))) - (res)))) - - -;;; Process-Ftype-Declaration -- Internal -;;; -;;; Somewhat similar to Process-Type-Declaration, but handles declarations -;;; for function variables. In addition to allowing declarations for functions -;;; being bound, we must also deal with declarations that constrain the type of -;;; lexically apparent functions. -;;; -;;; [In the non-pervasive case, we should propagate type constraints into the -;;; function getting the declaration. We should also think about checking for -;;; incompatible declarations and possibly intersecting the declared types. -;;; Handling of pervasive declarations is also sub-optimal, but with any luck -;;; this feature will go away.] -;;; -(proclaim '(function process-ftype-declaration (t list list) list)) -(defun process-ftype-declaration (spec names fvars) - (let ((type (specifier-type spec))) - (collect ((res)) - (dolist (name names) - (let ((found (find name fvars :key #'leaf-name))) - (if found - (setf (leaf-type found) type) - (res (cons (find-lexically-apparent-function - name "in a function type declaration") - type))))) - (res)))) - - - -;;; Process-Declarations -- Internal -;;; -;;; Use a list of Declare forms to annotate the lists of Lambda-Var and -;;; Functional structures which are being bound. In addition to filling in -;;; slots in the leaf structures, we return new values for *venv*, *inlines*, -;;; *type-restrictions* and *current-cookie* which reflect pervasive special -;;; and function type declarations, (not)inline declarations and optimize -;;; declarations. -;;; -(proclaim '(function process-declarations (list list list) (values list list list cookie))) -(defun process-declarations (decls vars fvars) - (let ((new-cookie *current-cookie*)) - (collect ((new-venv nil cons) - (new-inlines nil cons) - (new-restrictions *type-restrictions* nconc)) - (dolist (decl decls) - (dolist (spec (rest decl)) - (unless (consp spec) - (compiler-error "Malformed declaration specifier ~S in ~S." spec decl)) - (case (first spec) - (special - (dolist (name (cdr spec)) - (let ((var (find-in-bindings vars name)) - (specvar (specvar-for-binding name))) - (cond (var - (when (lambda-var-ignorep var) - (compiler-warning "Ignored variable ~S is being declared special." name)) - (setf (lambda-var-specvar var) specvar)) - ((assoc name (new-venv))) - (t - (new-venv (cons name specvar))))))) - (ftype - (unless (cdr spec) - (compiler-error "No type specified in FTYPE declaration: ~S." decl)) - (new-restrictions - (process-ftype-declaration (second spec) (cddr spec) fvars))) - (function - (unless (cdr spec) - (compiler-error "No function name specified in FUNCTION declaration: ~S." decl)) - (new-restrictions - (process-ftype-declaration `(function ,@(cddr spec)) (list (second spec)) - fvars))) - ((inline notinline maybe-inline) - (let ((sense (case (first spec) - (inline :inline) - (notinline :notinline) - (maybe-inline :maybe-inline)))) - (dolist (name (rest spec)) - (let* ((var (or (find name fvars :key #'leaf-name) - (find-lexically-apparent-function - name "in an inline or notinline declaration"))) - (found (cdr (assoc var (new-inlines))))) - (if found - (unless (eq found sense) - (compiler-warning "Conflicting inline/notinline declarations in ~S." decl)) - (new-inlines (cons var sense))))))) - ((ignore ignorable) - (dolist (name (rest spec)) - (let ((var (find-in-bindings vars name))) - (cond - ((not var) - (compiler-warning - "Ignore declaration for unknown variable ~S." name)) - ((lambda-var-specvar var) - (compiler-warning - "Declaring special variable ~S to be ignored." name)) - ((eq (first spec) 'ignorable) - (setf (leaf-ever-used var) t)) - (t - (setf (lambda-var-ignorep var) t)))))) - (optimize - (setq new-cookie (process-optimize-declaration spec new-cookie))) - (type - (new-restrictions (process-type-declaration (cdr spec) vars))) - (t - (let ((what (first spec))) - (cond ((member what type-specifier-symbols) - (new-restrictions (process-type-declaration spec vars))) - ((info declaration recognized what)) - (t - (compiler-warning "Unrecognized declaration: ~S." - spec)))))))) - - (values (nconc (new-venv) *venv*) (nconc (new-inlines) *inlines*) - (new-restrictions) new-cookie)))) - - -;;; Specvar-For-Binding -- Internal -;;; -;;; Return the Specvar for Name to use when we see a local SPECIAL -;;; declaration. If there is a global variable of that name, then check that -;;; it isn't a constant and return it. Otherwise, create an anonymous -;;; GLOBAL-VAR. -;;; -(defun specvar-for-binding (name) - (cond ((not (eq (info variable where-from name) :assumed)) - (let ((found (find-free-variable name))) - (when (or (not (global-var-p found)) - (eq (global-var-kind found) :constant)) - (compiler-error "Declaring a constant to be special: ~S." name)) - found)) - (t - (make-global-var :kind :special :name name :where-from :declared)))) - - -;;; IR1-Convert-Aux-Bindings -- Internal -;;; -;;; Similar to IR1-Convert-Progn-Body except that we sequentially bind each -;;; Aux-Var to the corresponding Aux-Val before converting the body. If there -;;; are no bindings, just convert the body, otherwise do one binding and -;;; recurse on the rest. -;;; -(proclaim '(function ir1-convert-aux-bindings - (continuation continuation list list list) - void)) -(defun ir1-convert-aux-bindings (start cont body source aux-vars aux-vals) - (if (null aux-vars) - (ir1-convert-progn-body start cont body) - (let ((fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body body (list (first aux-vars)) source - (rest aux-vars) (rest aux-vals)))) - (reference-leaf start fun-cont fun nil) - (ir1-convert-combination-args fun-cont cont source - (list (first aux-vals)))))) - - -;;; IR1-Convert-Special-Bindings -- Internal -;;; -;;; Similar to IR1-Convert-Progn-Body except that code to bind the Specvar -;;; for each Svar to the value of the variable is wrapped around the body. If -;;; there are no special bindings, we just convert the body, otherwise we do -;;; one special binding and recurse on the rest. -;;; -;;; We make a cleanup, bind *Current-Cleanup* to it, and also set the -;;; Block-End-Cleanup for the start block. If there are multiple special -;;; bindings, the cleanup for the blocks will end up being the innermost one. -;;; We force Cont to start a block outside of this cleanup, causing cleanup -;;; code to be emitted when the scope is exited. -;;; -(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals - svars source) - (declare (type continuation start cont) - (list body aux-vars aux-vals svars)) - (cond - ((null svars) - (ir1-convert-aux-bindings start cont body source aux-vars aux-vals)) - (t - (continuation-starts-block cont) - (let* ((cleanup (make-cleanup :kind :special-bind)) - (*current-cleanup* cleanup) - (var (first svars)) - (next-cont (make-continuation))) - (setf (cleanup-start cleanup) next-cont) - (setf (block-end-cleanup (continuation-block start)) cleanup) - (ir1-convert start next-cont - `(%special-bind ',(lambda-var-specvar var) ,var)) - (ir1-convert-special-bindings next-cont cont body aux-vars aux-vals - (rest svars) source))))) - - -;;; IR1-Convert-Lambda-Body -- Internal -;;; -;;; Create a lambda node out of some code, returning the result. The -;;; bindings are specified by the list of var structures Vars. We deal with -;;; adding the names to the *venv* for the conversion. The result is added to -;;; the New-Functions in the *Current-Component* and linked to the component -;;; head and tail. -;;; -;;; We detect special bindings here, replacing the original Var in the lambda -;;; list with a temporary variable. We then pass a list of the special vars to -;;; IR1-Convert-Special-Bindings, which actually emits the special binding -;;; code. -;;; -;;; We ignore any Arg-Info in the Vars, trusting that someone else is dealing -;;; with &nonsense. -;;; -;;; Aux-Vars is a list of Var structures for variables that are to be -;;; sequentially bound. Each Aux-Val is a form that is to be evaluated to get -;;; the initial value for the corresponding Aux-Var. -;;; -(proclaim '(function ir1-convert-lambda-body (list list t &optional list list) - lambda)) -(defun ir1-convert-lambda-body (body vars source &optional aux-vars aux-vals) - (let* ((bind (make-bind :source source)) - (lambda (make-lambda :vars vars :bind bind)) - (*current-lambda* lambda) - (*current-cleanup* lambda) - (result (make-continuation))) - (setf (lambda-home lambda) lambda) - (collect ((svars) - (new-venv *venv* cons)) - - (dolist (var vars) - (setf (lambda-var-home var) lambda) - (let ((specvar (lambda-var-specvar var))) - (cond (specvar - (svars var) - (new-venv (cons (leaf-name specvar) specvar))) - (t - (new-venv (cons (leaf-name var) var)))))) - - (setf (bind-lambda bind) lambda) - (let ((*venv* (new-venv)) - (cont1 (make-continuation)) - (cont2 (make-continuation))) - (continuation-starts-block cont1) - (prev-link bind cont1) - (use-continuation bind cont2) - (ir1-convert-special-bindings cont2 result body aux-vars aux-vals - (svars) source)) - - (let ((block (continuation-block result))) - (when block - (let ((return (make-return :source source :result result - :lambda lambda)) - (tail-set (make-tail-set :functions (list lambda))) - (dummy (make-continuation))) - (setf (lambda-tail-set lambda) tail-set) - (setf (lambda-return lambda) return) - (setf (continuation-dest result) return) - (setf (block-last block) return) - (prev-link return result) - (use-continuation return dummy)) - (link-blocks block (component-tail *current-component*))))) - - (link-blocks (component-head *current-component*) (node-block bind)) - (push lambda (component-new-functions *current-component*)) - lambda)) - - -;;; Convert-Optional-Entry -- Internal -;;; -;;; Create the actual entry-point function for an optional entry point. The -;;; lambda binds copies of each of the Vars, then calls Fun with the argument -;;; Vals and the Defaults. Presumably the Vals refer to the Vars by name. The -;;; Vals are passed in in reverse order. -;;; -;;; If any of the copies of the vars are referenced more than once, then we -;;; mark the corresponding var as Ever-Used to inhibit "defined but not read" -;;; warnings for arguments that are only used by default forms. -;;; -(proclaim '(function convert-optional-entry (lambda list list list t) lambda)) -(defun convert-optional-entry (fun vars vals defaults source) - (let* ((fvars (reverse vars)) - (arg-vars (mapcar #'(lambda (var) - (make-lambda-var - :name (leaf-name var) - :type (leaf-type var) - :where-from (leaf-where-from var) - :specvar (lambda-var-specvar var))) - fvars)) - (fun - (ir1-convert-lambda-body - `((%funcall ,fun ,@(reverse vals) ,@defaults)) - arg-vars source))) - (mapc #'(lambda (var arg-var) - (when (cdr (leaf-refs arg-var)) - (setf (leaf-ever-used var) t))) - fvars arg-vars) - fun)) - - -;;; Generate-Optional-Default-Entry -- Internal -;;; -;;; This function deals with supplied-p vars in optional arguments. If the -;;; there is no supplied-p arg, then we just call IR1-Convert-Hairy-Args on the -;;; remaining arguments, and generate a optional entry that calls the result. -;;; If there is a supplied-p var, then we add it into the default vars and -;;; throw a T into the entry values. The resulting entry point function is -;;; returned. -;;; -(proclaim '(function generate-optional-default-entry - (optional-dispatch list list list list list boolean list - list list list) - lambda)) -(defun generate-optional-default-entry (res default-vars default-vals - entry-vars entry-vals - vars supplied-p-p body source - aux-vars aux-vals) - (let* ((arg (first vars)) - (arg-name (leaf-name arg)) - (info (lambda-var-arg-info arg)) - (supplied-p (arg-info-supplied-p info)) - (ep (if supplied-p - (ir1-convert-hairy-args - res - (list* supplied-p arg default-vars) - (list* (leaf-name supplied-p) arg-name default-vals) - (cons arg entry-vars) - (list* t arg-name entry-vals) - (rest vars) t body source aux-vars aux-vals) - (ir1-convert-hairy-args - res - (cons arg default-vars) - (cons arg-name default-vals) - (cons arg entry-vars) - (cons arg-name entry-vals) - (rest vars) supplied-p-p body source aux-vars aux-vals)))) - - (convert-optional-entry ep default-vars default-vals - (if supplied-p - (list (arg-info-default info) nil) - (list (arg-info-default info))) - source))) - - -;;; Convert-More-Entry -- Internal -;;; -;;; Create the More-Entry function for the Optional-Dispatch Res. -;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var -;;; for any Rest arg. Keys is a list of the keyword arg vars. -;;; -;;; The most interesting thing that we do is parse keywords. We create a -;;; bunch of temporary variables to hold the result of the parse, and then loop -;;; over the supplied arguments, setting the appropriate temps for the supplied -;;; keyword. -;;; -;;; If there is no supplied-p var, then we initialize the temp to the -;;; default and just pass the temp into the main entry. Since non-constant -;;; keyword args are forcibly given a supplied-p var, we know that the default -;;; is constant, and thus safe to evaluate out of order. -;;; -;;; If there is a supplied-p var, then we create temps for both the value -;;; and the supplied-p, and pass them into the main entry, letting it worry -;;; about defaulting. -;;; -;;; We deal with :allow-other-keys by delaying unknown keyword errors until -;;; we have scanned all the keywords. -;;; -(proclaim '(function convert-more-entry - (optional-dispatch list list (or lambda-var null) - list list) - void)) -(defun convert-more-entry (res entry-vars entry-vals rest keys source) - (collect ((arg-vars) - (arg-vals (reverse entry-vals)) - (temps) - (body)) - - (dolist (var (reverse entry-vars)) - (arg-vars (make-lambda-var - :name (leaf-name var) - :type (leaf-type var) - :where-from (leaf-where-from var)))) - - (let* ((n-context (gensym)) - (context-temp (make-lambda-var :name n-context)) - (n-count (gensym)) - (count-temp (make-lambda-var :name n-count - :type (specifier-type 'fixnum)))) - (arg-vars context-temp count-temp) - - (when rest - (arg-vals `(%listify-rest-args ,n-context ,n-count))) - - (when (optional-dispatch-keyp res) - (let ((n-index (gensym)) - (n-key (gensym)) - (n-value-temp (gensym)) - (n-allowp (gensym)) - (n-losep (gensym)) - (allowp (or (optional-dispatch-allowp res) - (policy nil (zerop safety))))) - - (temps `(,n-index 0) n-key n-value-temp) - (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) - - (collect ((tests)) - (dolist (key keys) - (let* ((info (lambda-var-arg-info key)) - (default (arg-info-default info)) - (keyword (arg-info-keyword info)) - (supplied-p (arg-info-supplied-p info)) - (n-value (gensym))) - (cond (supplied-p - (let ((n-supplied (gensym))) - (temps n-value n-supplied) - (arg-vals n-value n-supplied) - (tests `((eq ,n-key ,keyword) - (setq ,n-supplied t) - (setq ,n-value ,n-value-temp))))) - (t - (temps `(,n-value ,default)) - (arg-vals n-value) - (tests `((eq ,n-key ,keyword) - (setq ,n-value ,n-value-temp))))))) - - (unless allowp - (temps n-allowp n-losep) - (tests `((eq ,n-key :allow-other-keys) - (setq ,n-allowp ,n-value-temp))) - (tests `(t - (setq ,n-losep ,n-key)))) - - (body - `(when (oddp ,n-count) - (%odd-keyword-arguments-error))) - - (body - `(locally - (declare (optimize (safety 0))) - (loop - (when (= ,n-index ,n-count) (return)) - (setq ,n-key (%more-arg ,n-context ,n-index)) - (incf ,n-index) - (setf ,n-value-temp (%more-arg ,n-context ,n-index)) - (incf ,n-index) - (cond ,@(tests))))) - - (unless allowp - (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-keyword-argument-error ,n-losep))))))) - - (let ((ep (ir1-convert-lambda-body - `((let ,(temps) - ,@(body) - (%funcall ,(optional-dispatch-main-entry res) - . ,(arg-vals)))) - (arg-vars) source))) - (setf (optional-dispatch-more-entry res) ep))))) - - -;;; IR1-Convert-More -- Internal -;;; -;;; Called by IR1-Convert-Hairy-Args when we run into a rest or keyword arg. -;;; The arguments are similar to that function, but we split off any rest arg -;;; and pass it in separately. Rest is the rest arg var, or NIL if there is no -;;; rest arg. Keys is a list of the keyword argument vars. -;;; -(proclaim '(function ir1-convert-more - (optional-dispatch list list list list (or lambda-var null) - list boolean list list list list) - lambda)) -(defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals - rest keys supplied-p-p body source aux-vars - aux-vals) - (collect ((main-vars (reverse default-vars)) - (main-vals default-vals cons) - (bind-vars) - (bind-vals)) - (when rest - (main-vars rest) - (main-vals '())) - - (dolist (key keys) - (let* ((info (lambda-var-arg-info key)) - (default (arg-info-default info)) - (hairy-default (not (compiler-constantp default))) - (supplied-p (arg-info-supplied-p info)) - (n-val (gensym)) - (val-temp (make-lambda-var :name n-val))) - (main-vars val-temp) - (bind-vars key) - (cond ((or hairy-default supplied-p) - (let* ((n-supplied (gensym)) - (supplied-temp (make-lambda-var :name n-supplied))) - (unless supplied-p - (setf (arg-info-supplied-p info) supplied-temp)) - (setf (arg-info-default info) nil) - (main-vars supplied-temp) - (main-vals nil nil) - (bind-vals `(if ,n-supplied ,n-val ,default)) - (when supplied-p - (bind-vars supplied-p) - (bind-vals n-supplied)))) - (t - (main-vals (arg-info-default info)) - (bind-vals n-val))))) - - (let* ((main-entry (ir1-convert-lambda-body body (main-vars) source - (append (bind-vars) aux-vars) - (append (bind-vals) aux-vals))) - (last-entry (convert-optional-entry main-entry default-vars - (main-vals) () source))) - (setf (optional-dispatch-main-entry res) main-entry) - (convert-more-entry res entry-vars entry-vals rest keys source) - - (push (if supplied-p-p - (convert-optional-entry last-entry entry-vars entry-vals - () source) - last-entry) - (optional-dispatch-entry-points res)) - last-entry))) - - -;;; IR1-Convert-Hairy-Args -- Internal -;;; -;;; This function generates the entry point functions for the -;;; optional-dispatch Res. We accomplish this by recursion on the list of -;;; arguments, analyzing the arglist on the way down and generating entry -;;; points on the way up. -;;; -;;; Default-Vars is a reversed list of all the argument vars processed so -;;; far, including supplied-p vars. Default-Vals is a list of the names of the -;;; Default-Vars. -;;; -;;; Entry-Vars is a reversed list of processed argument vars, excluding -;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get -;;; the values for all the vars from the Entry-Vars. It has the var name for -;;; each required or optional arg, and has T for each supplied-p arg. -;;; -;;; Vars is a list of the Lambda-Var structures for arguments that haven't -;;; been processed yet. Supplied-p-p is true if a supplied-p argument has -;;; already been processed; only in this case are the Default-XXX and Entry-XXX -;;; different. -;;; -;;; The result at each point is a lambda which should be called by the above -;;; level to default the remaining arguments and evaluate the body. We cause -;;; the body to be evaluated by converting it and returning it as the result -;;; when the recursion bottoms out. -;;; -;;; Each level in the recursion also adds its entry point function to the -;;; result Optional-Dispatch. For most arguments, the defaulting function and -;;; the entry point function will be the same, but when supplied-p args are -;;; present they may be different. -;;; -;;; When we run into a rest or keyword arg, we punt out to -;;; IR1-Convert-More, which finishes for us in this case. -;;; -(proclaim '(function ir1-convert-hairy-args - (optional-dispatch list list list list list boolean list - list list list) - lambda)) -(defun ir1-convert-hairy-args (res default-vars default-vals - entry-vars entry-vals - vars supplied-p-p body source aux-vars - aux-vals) - (cond ((not vars) - (let ((fun (ir1-convert-lambda-body body (reverse default-vars) source - aux-vars aux-vals))) - (setf (optional-dispatch-main-entry res) fun) - (push (if supplied-p-p - (convert-optional-entry fun entry-vars entry-vals - () source) - fun) - (optional-dispatch-entry-points res)) - fun)) - ((not (lambda-var-arg-info (first vars))) - (let* ((arg (first vars)) - (nvars (cons arg default-vars)) - (nvals (cons (leaf-name arg) default-vals))) - (ir1-convert-hairy-args res nvars nvals nvars nvals - (rest vars) nil body source aux-vars - aux-vals))) - (t - (let* ((arg (first vars)) - (info (lambda-var-arg-info arg)) - (kind (arg-info-kind info))) - (ecase kind - (:optional - (let ((ep (generate-optional-default-entry - res default-vars default-vals - entry-vars entry-vals vars supplied-p-p body source - aux-vars aux-vals))) - (push (if supplied-p-p - (convert-optional-entry ep entry-vars entry-vals - () source) - ep) - (optional-dispatch-entry-points res)) - ep)) - (:rest - (ir1-convert-more res default-vars default-vals entry-vars entry-vals - arg (rest vars) supplied-p-p body source - aux-vars aux-vals)) - (:keyword - (ir1-convert-more res default-vars default-vals entry-vars entry-vals - nil vars supplied-p-p body source aux-vars - aux-vals))))))) - - -;;; IR1-Convert-Hairy-Lambda -- Internal -;;; -;;; This function deals with the case where we have to make an -;;; Optional-Dispatch to represent a lambda. We cons up the result and call -;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the -;;; min-args and max-args. -;;; -(proclaim '(function ir1-convert-hairy-lambda - (list list boolean boolean list list list) - optional-dispatch)) -(defun ir1-convert-hairy-lambda (body vars keyp allowp source aux-vars aux-vals) - (let ((res (make-optional-dispatch :arglist vars :allowp allowp - :keyp keyp)) - (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) - (push res (component-new-functions *current-component*)) - (ir1-convert-hairy-args res () () () () vars nil body source aux-vars - aux-vals) - (setf (optional-dispatch-min-args res) min) - (setf (optional-dispatch-max-args res) - (+ (1- (length (optional-dispatch-entry-points res))) min)) - - (flet ((frob (ep) - (when ep - (setf (functional-kind ep) :optional) - (setf (lambda-optional-dispatch ep) res)))) - (dolist (ep (optional-dispatch-entry-points res)) (frob ep)) - (frob (optional-dispatch-more-entry res)) - (frob (optional-dispatch-main-entry res))) - - res)) - - -;;; IR1-Convert-Lambda -- Internal -;;; -;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf. -;;; -(proclaim '(function ir1-convert-lambda (t &optional t) functional)) -(defun ir1-convert-lambda (form &optional (source form)) - (unless (and (consp form) (eq (car form) 'lambda) (consp (cdr form)) - (listp (cadr form))) - (compiler-error "Malformed lambda expression: ~S." form)) - - (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) - (find-lambda-vars (cadr form)) - (multiple-value-bind - (body decls) - (system:parse-body (cddr form) *fenv* t) - (multiple-value-bind - (*venv* *inlines* *type-restrictions* *current-cookie*) - (process-declarations decls (append aux-vars vars) nil) - (let ((res (if (or (find-if #'lambda-var-arg-info vars) keyp) - (ir1-convert-hairy-lambda body vars keyp - allow-other-keys source - aux-vars aux-vals) - (ir1-convert-lambda-body body vars source aux-vars - aux-vals)))) - (setf (functional-inline-expansion res) form) - (setf (functional-arg-documentation res) (cadr form)) - res))))) - - -;;;; Variable hacking: - - -;;; Find-Free-Really-Function -- Internal -;;; -;;; Return a Global-Var structure usable for referencing the global function -;;; Name. -;;; -(defun find-free-really-function (name) - (unless (info function kind name) - (setf (info function kind name) :function) - (setf (info function where-from name) :assumed)) - - (make-global-var :kind :global-function :name name - :type (info function type name) - :where-from (info function where-from name))) - - -;;; Find-Slot-Accessor -- Internal -;;; -;;; Return a Slot-Accessor structure usable for referencing the slot -;;; accessor Name. Info is the structure definition. -;;; -(defun find-slot-accessor (info name) - (declare (type defstruct-description info)) - (let* ((accessor (if (listp name) (cadr name) name)) - (slot (find accessor (dd-slots info) - :key #'dsd-accessor)) - (type (dd-name info)) - (slot-type (dsd-type slot))) - (assert slot () "Can't find slot ~S." type) - (make-slot-accessor - :name name - :type (specifier-type - (if (listp name) - `(function (,type ,slot-type) ,slot-type) - `(function (,type) ,slot-type))) - :for info - :slot slot))) - - -;;; Find-Free-Function -- Internal -;;; -;;; If Name is already entered in *free-functions*, then return the value. -;;; Otherwise, make a new Global-Var using information from the global -;;; environment and enter it in *free-functions*. If Name names a macro or -;;; special form, then we error out using the supplied context which indicates -;;; what we were trying to do that demanded a function. The second value is -;;; the inlinep information which currently applies to the variable. -;;; -(proclaim '(function find-free-function (t string) (values global-var inlinep))) -(defun find-free-function (name context) - (let ((found (gethash name *free-functions*))) - (if found - (values found (leaf-inlinep found)) - (ecase (info function kind name) - (:macro - (compiler-error "Found macro name ~S ~A." name context)) - (:special-form - (compiler-error "Found special-form name ~S ~A." name context)) - ((:function nil) - (check-function-name name) - (let ((info (info function accessor-for name))) - (values (setf (gethash name *free-functions*) - (if info - (find-slot-accessor info name) - (find-free-really-function name))) - (info function inlinep name)))))))) - - -;;; IR1-Convert-Variable -- Internal -;;; -;;; Convert a reference to a symbolic constant or variable. If the symbol -;;; is entered in *venv*, then we use that definition, otherwise we find the -;;; current global definition. -;;; -(proclaim '(function ir1-convert-variable (continuation continuation symbol) void)) -(defun ir1-convert-variable (start cont name) - (let ((var (or (cdr (assoc name *venv*)) (find-free-variable name)))) - (when (and (lambda-var-p var) (lambda-var-ignorep var)) - (compiler-warning "Reading an ignored variable: ~S." name)) - (if (lisp::ct-a-val-p var) - (ir1-convert start cont `(alien-value ,name)) - (reference-leaf start cont var nil)))) - - -;;; Find-Free-Variable -- Internal -;;; -;;; Return the Leaf node for a global variable reference to Name. If Name -;;; is already entered in *free-variables*, then we just return the -;;; corresponding value. Otherwise, we make a new leaf using information from -;;; the global environment and enter it in *free-variables*. If the variable -;;; is unknown, then we emit a warning. -;;; -(proclaim '(function find-free-variable (symbol) leaf)) -(defun find-free-variable (name) - (unless (symbolp name) - (compiler-error "Variable name is not a symbol: ~S." name)) - (or (gethash name *free-variables*) - (let ((kind (info variable kind name)) - (type (info variable type name)) - (where-from (info variable where-from name))) - (when (and (eq where-from :assumed) (eq kind :global)) - (note-undefined-reference name :variable)) - - (multiple-value-bind (val valp) - (info variable constant-value name) - (setf (gethash name *free-variables*) - (if (and (eq kind :constant) valp) - (make-constant :value val :name name - :type (ctype-of val) - :where-from where-from) - (make-global-var :kind kind :name name :type type - :where-from where-from))))))) - - -;;; Reference-Constant -- Internal -;;; -;;; Generate a reference to a manifest constant, creating a new leaf if -;;; necessary. -;;; -(proclaim '(function reference-constant (continuation continuation t t) - void)) -(defun reference-constant (start cont value source) - (let* ((leaf (find-constant value)) - (res (make-ref (leaf-type leaf) source leaf nil))) - (push res (leaf-refs leaf)) - (prev-link res start) - (use-continuation res cont))) - - -;;; Reference-Leaf -- Internal -;;; -;;; Generate a Ref node for a Leaf, frobbing the Leaf structure as -;;; needed. Inlinep specifies the legality of inline coding for a -;;; function-valued variable. -;;; -(proclaim '(function reference-leaf - (continuation continuation leaf inlinep) - void)) -(defun reference-leaf (start cont leaf inlinep) - (let ((res (make-ref (or (cdr (assoc leaf *type-restrictions*)) - (leaf-type leaf)) - (leaf-name leaf) - leaf - inlinep))) - (push res (leaf-refs leaf)) - (setf (leaf-ever-used leaf) t) - (prev-link res start) - (use-continuation res cont))) - - -;;; Set-Variable -- Internal -;;; -;;; Kind of like Reference-Leaf, but we generate a Set node. This -;;; should only need to be called in Setq. -;;; -(proclaim '(function set-variable (continuation continuation basic-var t list) void)) -(defun set-variable (start cont var value source) - (let ((dest (make-continuation))) - (setf (continuation-asserted-type dest) (leaf-type var)) - (ir1-convert start dest value) - (let ((res (make-set :source source :var var :value dest))) - (setf (continuation-dest dest) res) - (setf (leaf-ever-used var) t) - (push res (basic-var-sets var)) - (prev-link res dest) - (use-continuation res cont)))) - - -;;;; Some flow-graph hacking utilities: - -;;; Prev-Link -- Internal -;;; -;;; This function sets up the back link between the node and the -;;; continuation which continues at it. -;;; -(proclaim '(function prev-link (node continuation) void)) -(defun prev-link (node cont) - (assert (not (continuation-next cont)) () "~S already has a next." cont) - (assert (not (node-prev node)) () "Garbage in Prev for ~S." node) - (setf (continuation-next cont) node) - (setf (node-prev node) cont)) - - -;;; Use-Continuation -- Internal -;;; -;;; This function is used to set the continuation for a node, and thus -;;; determine what recieves the value and what is evaluated next. If the -;;; continuation has no block, then we make it be in the block that the node is -;;; in. If the continuation heads its block, we end our block and link it to -;;; that block. If the continuation is not currently used, then we set the -;;; derived-type for the continuation to that of the node, so that a little -;;; type propagation gets done. -;;; -(proclaim '(function use-continuation (node continuation) void)) -(defun use-continuation (node cont) - (let ((block (continuation-block cont)) - (node-block (continuation-block (node-prev node)))) - (assert (not (node-cont node)) () "Garbage in Cont for ~S." node) - (ecase (continuation-kind cont) - (:unused - (setf (continuation-block cont) node-block) - (setf (continuation-kind cont) :inside-block) - (setf (continuation-use cont) node) - (setf (node-cont node) cont)) - (:block-start - (assert (not (block-last node-block)) () "~S has already ended." - node-block) - (setf (block-last node-block) node) - (assert (null (block-succ node-block)) () "~S already has successors." - node-block) - (setf (block-succ node-block) (list block)) - (assert (not (member node-block (block-pred block))) () - "~S is already a predecessor of ~S." node-block block) - (push node-block (block-pred block)) - (add-continuation-use node cont))))) - - -;;; Continuation-Starts-Block -- Internal -;;; -;;; 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. -;;; -;;; Note that the block is made in the *current-lambda*, so continuations -;;; without blocks cannot be passed across function boundaries since they might -;;; get a block assigned which is in the wrong function. Basically this means -;;; that BLOCK and TAGBODY must make sure that their named continuations have -;;; blocks. -;;; -;;; 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)))) - - -;;;; Exported functions: - -;;; IR1-Top-Level -- Interface -;;; -;;; This function takes a form and the top-level form number for that form, -;;; and returns a lambda representing the translation of that form in the -;;; current global environment. The lambda is top-level lambda that can be -;;; called to cause evaluation of the forms. This lambda is in the initial -;;; component. If For-Value is T, then the value of the form is returned from -;;; the function, otherwise NIL is returned. -;;; -;;; This function may have arbitrary effects on the global environment due -;;; to processing of Proclaims and Eval-Whens. All syntax error checking is -;;; done, with erroneous forms being replaced by a proxy which signals an error -;;; if it is evaluated. Warnings about possibly inconsistent or illegal -;;; changes to the global environment will also be given. -;;; -;;; We make the initial component and convert the form in a progn (and an -;;; optional NIL tacked on the end.) We then return the lambda. We bind all -;;; of our state variables here, rather than relying on the global value (if -;;; any) so that IR1 conversion will be reentrant. This is necessary for -;;; eval-when processing, etc. -;;; -;;; The hashtables used to hold global namespace info must be reallocated -;;; elsewhere. Note also that *fenv* is not rebound, so that local macro -;;; definitions can be introduced by enclosing code. -;;; -(defun ir1-top-level (form tlf-num for-value) - (declare (type index tlf-num)) - (let* ((*current-path* (or (gethash form *source-paths*) - *current-path* - (list 0 tlf-num))) - (*inlines* ()) - (*type-restrictions* ()) - (*venv* ()) - (*benv* ()) - (*tenv* ()) - (*current-cookie* (make-cookie)) - (*current-lambda* nil) - (*current-cleanup* nil) - (*current-form* nil) - (component (make-empty-component)) - (*current-component* component)) - (setf (component-name component) "initial component") - (setf (component-kind component) :initial) - (let* ((forms (if for-value `(,form) `(,form nil))) - (res (ir1-convert-lambda-body forms () `(progn ,@forms)))) - (setf (leaf-name res) "Top-Level Form") - (setf (functional-entry-function res) res) - (setf (functional-arg-documentation res) ()) - (setf (functional-kind res) :top-level) - res))) - - -;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the form -;;; number to associate with a source path. This should be bound to 0 around -;;; the processing of each truly top-level form. -;;; -(proclaim '(type index *current-form-number*)) -(defvar *current-form-number*) - -;;; Find-Source-Paths -- Interface -;;; -;;; This function is called on freshly read forms to record the initial -;;; location of each form (and subform.) Form is the form to find the paths -;;; in, and TLF-Num is the top-level form number of the truly top-level form. -;;; -;;; This gets a bit interesting when the source code is circular. This can -;;; (reasonably?) happen in the case of circular list constants. -;;; -(defun find-source-paths (form tlf-num) - (declare (type index tlf-num)) - (let ((*current-form-number* 0)) - (sub-find-source-paths form (list tlf-num))) - (undefined-value)) -;;; -(defun sub-find-source-paths (form path) - (unless (gethash form *source-paths*) - (setf (gethash form *source-paths*) - (cons *current-form-number* path)) - (incf *current-form-number*) - (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-find-source-paths fm (cons pos path))) - (incf pos)) - (setq subform (cdr subform)) - (when (eq subform trail) (return))))) - (loop - (frob) - (frob) - (setq trail (cdr trail))))))) - - -;;;; Control special forms: - -(def-ir1-translator progn ((&rest forms) start cont) - "Progn Form* - Evaluates each Form in order, returing the values of the last form. With no - forms, returns NIL." - (ir1-convert-progn-body start cont forms)) - -(def-ir1-translator if ((test then &optional else &whole source) start cont) - "If Predicate Then [Else] - If Predicate evaluates to non-null, evaluate Then and returns its values, - otherwise evaluate Else and return its values. Else defaults to NIL." - (let* ((pred (make-continuation)) - (then-cont (make-continuation)) - (then-block (continuation-starts-block then-cont)) - (else-cont (make-continuation)) - (else-block (continuation-starts-block else-cont)) - (dummy-cont (make-continuation)) - (node (make-if :test pred - :consequent then-block :alternative else-block - :source source))) - (setf (continuation-dest pred) node) - (ir1-convert start pred test) - (prev-link node pred) - (use-continuation node dummy-cont) - - (let ((start-block (continuation-block pred))) - (setf (block-last start-block) node) - (continuation-starts-block cont) - - (link-blocks start-block then-block) - (link-blocks start-block else-block) - - (ir1-convert then-cont cont then) - (ir1-convert else-cont cont else)))) - - -;;;; Block and Tagbody: -;;; -;;; We make an Entry node to mark the start and a :Entry cleanup to -;;; mark its extent. When doing Go or Return-From, we emit an Exit node. -;;; - -;;; Block IR1 convert -- Internal -;;; -;;; Make a :entry cleanup and emit an Entry node, then convert the body in -;;; the modified environment. We make Cont start a block now, since if it was -;;; done later, the block would be in the wrong environment. -;;; -(def-ir1-translator block ((name &rest forms &whole source) start cont) - "Block Name Form* - Evaluate the Forms as a PROGN. Within the lexical scope of the body, - (RETURN-FROM Name Value-Form) can be used to exit the form, returning the - result of Value-Form." - (unless (symbolp name) - (compiler-error "Block name is not a symbol: ~S." name)) - (continuation-starts-block cont) - (let* ((dummy (make-continuation)) - (entry (make-entry :exits (list cont) :source source)) - (cleanup (make-cleanup :kind :entry :start dummy))) - (push entry (lambda-entries *current-lambda*)) - (prev-link entry start) - (use-continuation entry dummy) - (setf (block-end-cleanup (continuation-block dummy)) cleanup) - (let ((*benv* (acons name (list entry cont) *benv*)) - (*current-cleanup* cleanup)) - (ir1-convert-progn-body dummy cont forms)))) - -;;; We make Cont start a block just so that it will have a block assigned. -;;; People assume that when they pass a continuation into IR1-Convert as Cont, -;;; it will have a block when it is done. -;;; -(def-ir1-translator return-from ((name &optional value &whole source) - start cont) - "Return-From Block-Name Value-Form - Evaluate the Value-Form, returning its values from the lexically enclosing - BLOCK Block-Name. This is constrained to be used only within the dynamic - extent of the BLOCK." - (continuation-starts-block cont) - (let* ((found (or (cdr (assoc name *benv*)) - (compiler-error "Return for unknown block: ~S." name))) - (value-cont (make-continuation)) - (exit (make-exit :entry (first found) :value value-cont - :source source))) - (setf (continuation-dest value-cont) exit) - (ir1-convert start value-cont value) - (prev-link exit value-cont) - (use-continuation exit (second found)))) - - -;;; Parse-Tagbody -- Internal -;;; -;;; Return a list of the segments of a tagbody. Each segment looks like -;;; (<tag> <form>* (go <next tag>)). That is, we break up the tagbody into -;;; segments of non-tag statements, and explicitly represent the drop-through -;;; with a GO. The first segment has a dummy NIL tag, since it represents code -;;; before the first tag. The last segment (which may also be the first -;;; segment) ends in NIL rather than a GO. -;;; -(defun parse-tagbody (body) - (declare (list body)) - (collect ((segments)) - (let ((current (cons nil body))) - (loop - (let ((tag-pos (position-if #'atom current :start 1))) - (unless tag-pos - (segments `(,@current nil)) - (return)) - (let ((tag (elt current tag-pos))) - (when (assoc tag (segments)) - (compiler-error "Repeated tagbody tag: ~S." tag)) - (unless (or (symbolp tag) (integerp tag)) - (compiler-error "Illegal tagbody statement: ~S." tag)) - (segments `(,@(subseq current 0 tag-pos) (go ,tag)))) - (setq current (nthcdr tag-pos current))))) - (segments))) - - -;;; Tagbody IR1 convert -- Internal -;;; -;;; Set up the cleanup, emitting the entry node. Then make a block for each -;;; tag, building up the tag list for *tenv* as we go. Finally, convert each -;;; segment with the precomputed Start and Cont values. -;;; -(def-ir1-translator tagbody ((&rest statements &whole source) start cont) - "Tagbody {Tag | Statement}* - Define tags for used with GO. The Statements are evaluated in order - (skipping Tags) and NIL is returned. If a statement contains a GO to a - defined Tag within the lexical scope of the form, then control is transferred - to the next statement following that tag. A Tag must an integer or a - symbol. A statement must be a list. Other objects are illegal within the - body." - (continuation-starts-block cont) - (let* ((dummy (make-continuation)) - (entry (make-entry :source source)) - (*current-cleanup* (make-cleanup :kind :entry :start dummy)) - (segments (parse-tagbody statements))) - (push entry (lambda-entries *current-lambda*)) - (prev-link entry start) - (use-continuation entry dummy) - (setf (block-end-cleanup (continuation-block start)) *current-cleanup*) - - (collect ((tags) - (starts) - (conts)) - (starts dummy) - (dolist (segment (rest segments)) - (let ((tag-cont (make-continuation))) - (conts tag-cont) - (starts tag-cont) - (continuation-starts-block tag-cont) - (tags (list (car segment) entry tag-cont)))) - (conts cont) - - (setf (entry-exits entry) (rest (starts))) - - (let ((*tenv* (append (tags) *tenv*))) - (mapc #'(lambda (segment start cont) - (ir1-convert-progn-body start cont (rest segment))) - segments (starts) (conts)))))) - - -;;; Go IR1 convert -- Internal -;;; -;;; Emit an Exit node without any value. -;;; -(def-ir1-translator go ((tag &whole source) start cont) - "Go Tag - Transfer control to the named Tag in the lexically enclosing TAGBODY. This - is constrained to be used only within the dynamic extent of the TAGBODY." - (continuation-starts-block cont) - (let* ((found (or (cdr (assoc tag *tenv*)) - (compiler-error "Go to nonexistent tag: ~S." tag))) - (exit (make-exit :entry (first found) :source source))) - (prev-link exit start) - (use-continuation exit (second found)))) - - -;;;; Translators for compiler-magic special forms: - -(def-ir1-translator compiler-let ((bindings &rest body) start cont) - (collect ((vars) - (values)) - (dolist (bind bindings) - (typecase bind - (symbol - (vars bind) - (values nil)) - (list - (unless (= (length bind) 2) - (compiler-error "Bad compiler-let binding spec: ~S." bind)) - (vars (first bind)) - (values (eval (second bind)))) - (t - (compiler-error "Bad compiler-let binding spec: ~S." bind)))) - (progv (vars) (values) - (ir1-convert-progn-body start cont body)))) - - -#-new-compiler -;;; -;;; 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) - -#-new-compiler -;;; DO-EVAL-WHEN-STUFF -- Interface -;;; -;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1 convert -;;; method so that it can be shared by the special-case top-level form -;;; processing code. We play with the dynamic environment and eval stuff, then -;;; call Fun with a list of forms to be processed at load time. -;;; -;;; We have to go through serious contortions to ensure that the forms get -;;; eval'ed exactly once. If *already-evaled-this* is true then we *do not* -;;; eval since some enclosing eval-when already did. If we do eval, we -;;; throw a binding of the funny lexical variable %compiler-eval-when-marker% -;;; into the %venv% before we eval the code. This is to inform the eval-when -;;; in the interpreter that it should eval forms even if they contain only -;;; a COMPILE. We don't want to use a special as a flag, since that would -;;; pervasively alter the semantics of eval-when, when we just want to -;;; alter it within the lexical scope of this eval-when. -;;; -;;; We know we are eval'ing for load since we wouldn't get called otherwise. -;;; If LOAD is a situation we convert the body like a progn. If we eval'ed the -;;; body, then we bind *already-evaled-this* to T around the conversion of body -;;; inhibiting the evaluation of any nested eval-when's. If we aren't -;;; evaluating for load, then we just convert NIL for the result of the -;;; Eval-When. -;;; -(defun do-eval-when-stuff (situations body fun) - (when (or (not (listp situations)) - (set-difference situations '(compile load eval))) - (compiler-error "Bad Eval-When situation list: ~S." situations)) - - (let* ((compilep (member 'compile situations)) - (evalp (member 'eval situations)) - (do-eval (and compilep (not *already-evaled-this*)))) - (when do-eval - (let ((lisp::%venv% '((lisp::%compile-eval-when-marker% t)))) - (lisp::eval-as-progn body))) - (if (member 'load situations) - (let ((*already-evaled-this* (or do-eval (and *already-evaled-this* evalp)))) - (funcall fun body)) - (funcall fun ())))) - -#+new-compiler -(proclaim '(special lisp::*already-evaled-this*)) - -#+new-compiler -;;; DO-EVAL-WHEN-STUFF -- Interface -;;; -;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1 convert -;;; method so that it can be shared by the special-case top-level form -;;; processing code. We play with the dynamic environment and eval stuff, then -;;; call Fun with a list of forms to be processed at load time. -;;; -;;; Note: the EVAL situation is always ignored: this is conceptually a -;;; compile-only implementation. -;;; -;;; We have to interact with the interpreter to ensure that the forms get -;;; eval'ed exactly once. We bind *already-evaled-this* to true to inhibit -;;; evaluation of any enclosed EVAL-WHENs, either by IR1 conversion done by -;;; EVAL, or by conversion of the body for load-time processing. If -;;; *already-evaled-this* is true then we *do not* eval since some enclosing -;;; eval-when already did. -;;; -;;; We know we are eval'ing for load since we wouldn't get called otherwise. -;;; If LOAD is a situation we call Fun on body. If we aren't evaluating for -;;; load, then we call Fun on NIL for the result of the EVAL-WHEN. -;;; -(defun do-eval-when-stuff (situations body fun) - (when (or (not (listp situations)) - (set-difference situations '(compile load eval))) - (compiler-error "Bad Eval-When situation list: ~S." situations)) - - (let* ((do-eval (and (member 'compile situations) - (not lisp::*already-evaled-this*))) - (lisp::*already-evaled-this* t)) - (when do-eval - (eval `(progn ,@body))) - (if (member 'load situations) - (funcall fun body) - (funcall fun '(nil))))) - - -(def-ir1-translator eval-when ((situations &rest body) start cont) - (do-eval-when-stuff situations body - #'(lambda (forms) - (ir1-convert-progn-body start cont forms)))) - - -;;; DO-MACROLET-STUFF -- Interface -;;; -;;; Like DO-EVAL-WHEN-STUFF, only do a macrolet. Fun is not passed any -;;; arguments. We cleverly make the FENV entry for a macro look like the -;;; interpreter version so that we can pass in *fenv* as a macroexpansion -;;; environment. -;;; -(defun do-macrolet-stuff (definitions fun) - (declare (list definitions) (function fun)) - (let ((*fenv* *fenv*) - (whole (gensym)) - (environment (gensym))) - (dolist (def definitions) - (let ((name (first def)) - (arglist (second def)) - (body (cddr def))) - (multiple-value-bind (body local-decs) - (lisp::parse-defmacro - arglist whole body name - :environment environment - :error-string 'lisp::defmacro-error-string) - (unless (symbolp name) - (compiler-error "Macro name ~S is not a symbol." name)) - (when (< (length def) 3) - (compiler-error "Local macro ~S is too short to be a legal definition." name)) - #-new-compiler - (push `(,(first def) macro lambda - (,whole ,environment) ,@local-decs (block ,name ,body)) - *fenv*) - #+new-compiler - (push `(,(first def) macro . - ,(coerce `(lambda (,whole ,environment) - ,@local-decs (block ,name ,body)) - 'function)) - *fenv*)))) - (funcall fun)) - - (undefined-value)) - - -(def-ir1-translator macrolet ((definitions &rest body) start cont) - (do-macrolet-stuff definitions - #'(lambda () - (ir1-convert-progn-body start cont body)))) - - -;;; Not really a special form, but... -;;; -(def-ir1-translator declare ((&rest stuff) start cont) - (declare (ignore stuff)) - start cont; Ignore hack - (compiler-error "Misplaced declaration.")) - - -;;;; %Primitive: -;;; -;;; Uses of %primitive are either expanded into Lisp code or turned into a -;;; funny function. -;;; - -;;; Eval-Info-Args -- Internal -;;; -;;; Carefully evaluate a list of forms, returning a list of the results. -;;; -(defun eval-info-args (args) - (declare (list args)) - (handler-case (mapcar #'eval args) - (error (condition) - (compiler-error "Lisp error during evaluation of info args:~%~A" - condition)))) - -;;; A hashtable that translates from primitive names to translation functions. -;;; -(defvar *primitive-translators* (make-hash-table :test #'eq)) - -;;; IR1-Convert-%Primitive -- Internal -;;; -;;; If there is a primitive translator, then we expand the call. Otherwise, -;;; we convert to the %%Primitive funny function. The first argument is the -;;; template, the second is a list of the results of any codegen-info args, and -;;; the remaining arguments are the runtime arguments. -;;; -;;; We do a bunch of error checking now so that we don't bomb out with a -;;; fatal error during IR2 conversion. -;;; -(def-ir1-translator system:%primitive ((name &rest args &whole form) - start cont) - - (unless (symbolp name) - (compiler-error "%Primitive name is not a symbol: ~S." name)) - - (let* ((name (intern (symbol-name name) "C")) - (translator (gethash name *primitive-translators*))) - (if translator - (ir1-convert start cont (funcall translator (cdr form))) - (let* ((template (or (gethash name *template-names*) - (compiler-error "Undefined primitive name: ~A." - name))) - (required (length (template-arg-types template))) - (info (template-info-arg-count template)) - (min (+ required info)) - (nargs (length args))) - (if (template-more-args-type template) - (when (< nargs min) - (compiler-error "Primitive called with ~R argument~:P, ~ - but wants at least ~R." - nargs min)) - (unless (= nargs min) - (compiler-error "Primitive called with ~R argument~:P, ~ - but wants exactly ~R." - nargs min))) - - (when (eq (template-result-types template) :conditional) - (compiler-error "%Primitive used with a conditional template.")) - - (when (template-more-results-type template) - (compiler-error - "%Primitive used with an unknown values template.")) - - (ir1-convert start cont - `(%%primitive ',template - ',(eval-info-args - (subseq args required min)) - ,@(subseq args 0 required) - ,@(subseq args min))))))) - - -;;;; Quote and Function: - -(def-ir1-translator quote ((thing &whole source) start cont) - (reference-constant start cont thing source)) - - -(def-ir1-translator function ((thing) start cont) - (if (and (consp thing) (eq (car thing) 'lambda)) - (reference-leaf start cont (ir1-convert-lambda thing) nil) - (multiple-value-bind (var inlinep) - (find-lexically-apparent-function - thing "as the argument to FUNCTION") - (reference-leaf start cont var inlinep)))) - - -;;;; Magic functions: -;;; -;;; Various global functions must be treated magically in IR1 conversion. -;;; If a function is always magical, then we just define an IR1-Convert method -;;; for it. If the magic is effectively a form of inline expansion, then we -;;; define a source transform which transforms to an internal thing which we -;;; pretend is a special form. -;;; -;;; %Funcall is used by people who want the call to be open-coded regardless of -;;; user policy settings. -;;; - -(def-source-transform funcall (function &rest args) - `(%funcall ,function ,@args)) - -(def-ir1-translator %funcall ((function &rest args) start cont) - (let ((fun-cont (make-continuation))) - (ir1-convert start fun-cont function) - (ir1-convert-combination-args fun-cont cont `(funcall ,function ,@args) - args))) - - -;;;; Proclaim: -;;; -;;; Proclaim changes the global environment, so we must special-case it if -;;; we are to keep the information in the *FREE-xxx* variables up to date. -;;; When there is a var structure we disown it by replacing it with an updated -;;; copy. Uses of the variable which were translated before the PROCLAIM will -;;; get the old version, while subsequent references will get the updated -;;; information. - - -;;; Get-Old-Vars -- Internal -;;; -;;; Look up some symbols in *free-variables*, returning the var structures -;;; for any which exist. If any of the names aren't symbols, we complain. -;;; -(proclaim '(function get-old-vars (list) list)) -(defun get-old-vars (names) - (collect ((vars)) - (dolist (name names (vars)) - (unless (symbolp name) - (compiler-error "Name is not a symbol: ~S." name)) - (let ((old (gethash name *free-variables*))) - (when old (vars old)))))) - - -;;; Process-Type-Proclamation -- Internal -;;; -;;; Replace each old var entry with one having the new type. If the new -;;; type doesn't intersect with the old type, give a warning. -;;; -;;; We also check that the old type of each variable intersects with the new -;;; one, giving a warning if not. This isn't as serious as conflicting local -;;; declarations, since we assume a redefinition semantics rather than an -;;; intersection semantics. -;;; -(proclaim '(function process-type-proclamation (t list) void)) -(defun process-type-proclamation (spec names) - (let ((type (specifier-type spec))) - (unless (policy nil (= brevity 3)) - (dolist (name names) - (let ((old-type (info variable type name))) - (unless (types-intersect type old-type) - (compiler-warning - "New proclaimed type ~S for ~S conflicts with old type ~S." - (type-specifier type) name (type-specifier old-type)))))) - - (dolist (var (get-old-vars names)) - (let ((new (etypecase var - (global-var (copy-global-var var)) - (constant (copy-constant var))))) - (setf (leaf-type new) type) - (setf (leaf-where-from new) :declared) - (setf (gethash (leaf-name var) *free-variables*) new))))) - - - -;;; Process-1-Ftype-Proclamation -- Internal -;;; -;;; For now, just update the type of any old var and remove the name from -;;; the list of undefined functions. Eventually we whould check for -;;; incompatible redefinition. -;;; -(defun process-1-ftype-proclamation (name type) - (declare (type function-type type)) - (let ((var (gethash (define-function-name name) *free-functions*))) - (when var - (let ((new (copy-global-var var)) - (name (leaf-name var))) - (setf (leaf-type new) type) - (setf (leaf-where-from new) :declared) - (setf (gethash name *free-functions*) new)))) - - (note-name-defined name :function) - (undefined-value)) - - -;;; Process-Ftype-Proclamation -- Internal -;;; -(proclaim '(function process-ftype-proclamation (t list) void)) -(defun process-ftype-proclamation (spec names) - (let ((type (specifier-type spec))) - (unless (csubtypep type (specifier-type 'function)) - (compiler-error - "Declared functional type is not a function type: ~S." spec)) - (dolist (name names) - (process-1-ftype-proclamation name type)))) - - -(def-ir1-translator proclaim ((what) start cont :kind :function) - (when (constantp what) - (let ((form (eval what))) - (unless (consp form) - (compiler-error "Malformed PROCLAIM spec: ~S." form)) - - (let ((name (first form)) - (args (rest form))) - (case (first form) - (special - (dolist (old (get-old-vars (rest form))) - (when (or (constant-p old) - (eq (global-var-kind old) :constant)) - (compiler-error - "Attempt to proclaim constant ~S to be special." name)) - - (ecase (global-var-kind old) - (:special) - (:global - (let ((new (copy-global-var old))) - (setf (global-var-kind new) :special) - (setf (gethash name *free-variables*) new)))))) - (type - (when (endp args) - (compiler-error "Malformed TYPE proclamation: ~S." form)) - (process-type-proclamation (first args) (rest args))) - (function - (when (endp args) - (compiler-error "Malformed FUNCTION proclamation: ~S." form)) - (process-ftype-proclamation `(function . ,(rest args)) - (list (first args)))) - (ftype - (when (endp args) - (compiler-error "Malformed FTYPE proclamation: ~S." form)) - (process-ftype-proclamation (first args) (rest args))) - ;; - ;; No non-global state to be updated. - ((inline notinline maybe-inline optimize declaration)) - (t - (cond ((member name type-specifier-symbols) - (process-type-proclamation name args)) - ((info declaration recognized name)) - (t - (compiler-warning "Unrecognized proclamation: ~S." form)))))) - - (funcall #'%proclaim form))) - (ir1-convert start cont `(%proclaim ,what))) - - -;;; %Compiler-Defstruct IR1 Convert -- Internal -;;; -;;; This is a frob that DEFMACRO expands into to establish the compiler -;;; semantics. This is similar to the translator for proclaim: its job is to -;;; keep the *free-functions* in sync. -;;; -(def-ir1-translator %compiler-defstruct ((info) start cont :kind :function) - (let* ((info (eval info)) - (name (dd-name info)) - (copier (dd-copier info)) - (predicate (dd-predicate info))) - (setf (info type kind name) :structure) - (setf (info type structure-info name) info) - (dolist (slot (dd-slots info)) - (let ((fun (dsd-accessor slot)) - (type (dsd-type slot))) - (process-1-ftype-proclamation - fun - (specifier-type `(function (,name) ,type))) - (unless (dsd-read-only slot) - (process-1-ftype-proclamation - `(setf ,fun) - (specifier-type `(function (,name ,type) ,type)))))) - - (collect ((forms)) - (when copier - (forms `(proclaim '(ftype (function (,name) ,name) ,copier)))) - - (when predicate - (forms `(proclaim '(ftype (function (t) boolean) ,predicate)))) - - (funcall #'%%compiler-defstruct info) - (ir1-convert start cont `(progn - ,@(forms) - (%%compiler-defstruct ',info)))))) - - -;;;; Let and Let*: -;;; -;;; Let and Let* can't be implemented as macros due to the fact that -;;; any pervasive declarations also affect the evaluation of the arguments. - -;;; Extract-Let-Variables -- Internal -;;; -;;; Given a list of binding specifiers in the style of Let, return: -;;; 1] The list of var structures for the variables bound. -;;; 2] The initial value form for each variable. -;;; -;;; The variable names are checked for legality and globally special variables -;;; are marked as such. Context is the name of the form, for error reporting -;;; purposes. -;;; -(proclaim '(function extract-let-variables (list symbol) (values list list))) -(defun extract-let-variables (bindings context) - (collect ((vars) - (vals) - (names)) - (dolist (spec bindings) - (cond ((atom spec) - (let ((var (varify-lambda-arg spec (names)))) - (vars var) - (names (cons spec var)) - (vals nil))) - (t - (when (/= (length spec) 2) - (compiler-error "Malformed ~S binding spec: ~S." context spec)) - (let* ((name (first spec)) - (var (varify-lambda-arg name (names)))) - (vars var) - (names name) - (vals (second spec)))))) - - (values (vars) (vals) (names)))) - - -(def-ir1-translator let ((bindings &body (body decls) &whole source) start cont) - (multiple-value-bind (vars values) - (extract-let-variables bindings 'let) - (multiple-value-bind (*venv* *inlines* *type-restrictions* *current-cookie*) - (process-declarations decls vars nil) - - (let ((fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body body vars source))) - (reference-leaf start fun-cont fun nil) - (ir1-convert-combination-args fun-cont cont source values))))) - - -(def-ir1-translator let* ((bindings &body (body decls) &whole source) start cont) - (multiple-value-bind (vars values) - (extract-let-variables bindings 'let*) - (multiple-value-bind (*venv* *inlines* *type-restrictions* *current-cookie*) - (process-declarations decls vars nil) - (ir1-convert-aux-bindings start cont body source vars values)))) - - -;;;; Flet and Labels: - -;;; Extract-Flet-Variables -- Internal -;;; -;;; Given a list of local function specifications in the style of Flet, -;;; return lists of the function names and of the lambdas which are their -;;; definitions. -;;; -;;; The function names are checked for legality. Context is the name of the -;;; form, for error reporting. -;;; -(proclaim '(function extract-flet-variables (list symbol) (values list list))) -(defun extract-flet-variables (definitions context) - (collect ((names) - (defs)) - (dolist (def definitions) - (when (or (atom def) (< (length def) 2)) - (compiler-error "Malformed ~S definition spec: ~S." context def)) - - (let ((name (check-function-name (first def)))) - (names name) - (defs `(lambda ,(second def) - (block ,(if (consp name) (second name) name) - (cddr def)))))) - (values (names) (defs)))) - - -(def-ir1-translator flet ((definitions &body (body decls)) - start cont) - (multiple-value-bind (names defs) - (extract-flet-variables definitions 'flet) - (let ((fvars (mapcar #'(lambda (n d) - (let ((res (ir1-convert-lambda d))) - (setf (leaf-name res) n) - res)) - names defs))) - (multiple-value-bind (*venv* *inlines* *type-restrictions* *current-cookie*) - (process-declarations decls nil fvars) - (let ((*fenv* (pairlis names fvars *fenv*))) - (ir1-convert-progn-body start cont body)))))) - - -;;; For Labels, we have to create dummy function vars and add them to *fenv* -;;; while converting the functions. We then modify all the references to these -;;; leaves so that they point to the real functional leaves. -;;; -;;; [Perhaps not totally correct, since the declarations aren't processed until -;;; after the function definitions. This means that declarations for local -;;; functions may not have their full effect on references within the local -;;; functions.] -;;; -(def-ir1-translator labels ((definitions &body (body decls)) start cont) - (multiple-value-bind (names defs) - (extract-flet-variables definitions 'labels) - (let* ((dummies (mapcar #'(lambda (x) - (make-functional :name x)) names)) - (real-funs - (let ((*fenv* (pairlis names dummies *fenv*))) - (mapcar #'(lambda (n d) - (let ((res (ir1-convert-lambda d))) - (setf (leaf-name res) n) - res)) - names defs)))) - - (mapc #'substitute-leaf real-funs dummies) - - (multiple-value-bind - (*venv* *inlines* *type-restrictions* *current-cookie*) - (process-declarations decls nil real-funs) - - (let ((*fenv* (pairlis names real-funs *fenv*))) - (ir1-convert-progn-body start cont body)))))) - - -;;;; THE -;;; -;;; This is somewhat involved, since a type assertion may only be made on a -;;; continuation, not on a node. If the continuation has no uses before the -;;; form is converted, then we may make the type the assertion for the -;;; continuation. If there are other uses, then we accept some loss of -;;; information, but try to retain as much as possible. In this case, we make -;;; the type assertion the union of the pre-existing type assertion and the new -;;; type. - -(def-ir1-translator the ((type value) start cont) - (let ((ctype (values-specifier-type type))) - (if (null (find-uses cont)) - (let* ((old-type (continuation-asserted-type cont)) - (int (values-type-intersection old-type ctype))) - (when (and (eq int *empty-type*) - (not (policy nil (= brevity 3)))) - (compiler-warning - "Type ~S in THE declaration conflicts with previous type ~S." - (type-specifier ctype) (type-specifier old-type))) - (setf (continuation-asserted-type cont) int)) - (setf (continuation-asserted-type cont) - (values-type-union ctype (continuation-asserted-type cont))))) - (ir1-convert start cont value)) - - -;;; Truly-The IR1 convert -- Internal -;;; -;;; Since the Continuation-Derive-Type is computed as the union of its -;;; uses's types, setting it won't work. Instead we must intersect the type -;;; with the uses's Derived-Type. -;;; -(def-ir1-translator truly-the ((type value) start cont) - "Truly-The Type Value - Like the THE special form, except that it believes whatever you tell it. It - will never generate a type check, but will cause a warning if the compiler - can prove the assertion is wrong." - (let ((type (values-specifier-type type)) - (old (find-uses cont))) - (ir1-convert start cont value) - (do-uses (use cont) - (unless (member use old) - (derive-node-type use type))))) - - -;;;; Setq -;;; -;;; If there is a definition in *venv*, just set that, otherwise -;;; look at the global information. If the name is for a constant, then -;;; error out. - -(def-ir1-translator setq ((&rest things &whole source) start cont) - (let ((len (length things))) - (when (oddp len) - (compiler-error "Odd number of args to SETQ: ~S." source)) - (if (= len 2) - (let* ((name (first things)) - (leaf (or (cdr (assoc name *venv*)) - (find-free-variable name)))) - (when (or (constant-p leaf) - (and (global-var-p leaf) - (eq (global-var-kind leaf) :constant))) - (compiler-error "Attempt to set constant ~S." name)) - (when (and (lambda-var-p leaf) - (lambda-var-ignorep leaf)) - (compiler-warning "Setting an ignored variable: ~S." name)) - (set-variable start cont leaf (second things) source)) - (collect ((sets)) - (do ((thing things (cddr thing))) - ((endp thing) - (ir1-convert-progn-body start cont (sets))) - (sets `(setq ,(first thing) ,(second thing)))))))) - -;;;; Catch, Throw and Unwind-Protect: -;;; - -;;; Throw -- Public -;;; -;;; Although throw could be a macro, it seems this would cause unnecessary -;;; confusion. We turn THROW into a multiple-value-call of a magical function, -;;; since as as far as IR1 is concerned, it has no interesting properties other -;;; than receiving multiple-values. -;;; -(def-ir1-translator throw ((tag result) start cont) - "Throw Tag Form - Do a non-local exit, return the values of Form from the CATCH whose tag - evaluates to the same thing as Tag." - (ir1-convert start cont - `(multiple-value-call #'%throw ,tag ,result))) - - -;;; This is a special special form used to instantiate a cleanup as the current -;;; cleanup within the body. Kind is a the kind of cleanup to make. We make -;;; the Start be Start, then set Block-End-Cleanup and bind *Current-Cleanup*. -;;; -(def-ir1-translator %within-cleanup ((kind &body body) start cont) - (let* ((cleanup (make-cleanup :kind kind :start start)) - (*current-cleanup* cleanup)) - (setf (block-end-cleanup (continuation-block start)) cleanup) - (ir1-convert-progn-body start cont body))) - -;;; This is a special special form that makes an "escape function" which -;;; returns unknown values from named block. We convert the function, set its -;;; kind to :Escape, and then reference it. The :Escape kind indicates that -;;; this function's purpose is to represent a non-local control transfer, and -;;; that it might not actually have to be compiled. -;;; -;;; Note that environment analysis replaces references to escape functions -;;; with references to the corresponding NLX-Info structure. -;;; -(def-ir1-translator %escape-function ((tag) start cont) - (let ((fun (ir1-convert-lambda - `(lambda () - (return-from ,tag (%unknown-values)))))) - (setf (functional-kind fun) :escape) - (reference-leaf start cont fun nil))) - -;;; Yet another special special form. This one looks up a local function and -;;; smashes it to a :Cleanup function, as well as referencing it. -;;; -(def-ir1-translator %cleanup-function ((name) start cont) - (let ((fun (cdr (assoc name *fenv*)))) - (assert (lambda-p fun)) - (setf (functional-kind fun) :cleanup) - (reference-leaf start cont fun nil))) - - -;;; Catch -- Public -;;; -;;; Catch could be a macro, but it's somewhat tasteless to expand into -;;; implementation-dependent special forms. -;;; -;;; We represent the possibility of the control transfer by making an -;;; "escape function" that does a lexical exit, and instantiate the cleanup -;;; using %within-cleanup. It is crucial that %Within-Cleanup immediately -;;; follows the %Catch call so that the Cleanup-Start's Use will be the -;;; combination node for the %Catch. -;;; -(def-ir1-translator catch ((tag &body body) start cont) - "Catch Tag Form* - Evaluates Tag and instantiates it as a catcher while the body forms are - evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic - scope of the body, then control will be transferred to the end of the body - and the thrown values will be returned." - (ir1-convert - start cont - (let ((exit-block (gensym))) - `(block ,exit-block - (%catch (%escape-function ,exit-block) ,tag) - (%within-cleanup :catch - ,@body))))) - - -;;; Unwind-Protect -- Public -;;; -;;; Unwind-Protect is similar to Catch, but more hairy. We make the cleanup -;;; forms into a local function so that they can be referenced both in the case -;;; where we are unwound and in any local exits. We use %Cleanup-Function on -;;; this to indicate that reference by %Unwind-Protect isn't "real", and thus -;;; doesn't cause creation of an XEP. -;;; -(def-ir1-translator unwind-protect ((protected &body cleanup) start cont) - "Unwind-Protect Protected Cleanup* - Evaluate the form Protected, returning its values. The cleanup forms are - evaluated whenever the dynamic scope of the Protected form is exited (either - due to normal completion or a non-local exit such as THROW)." - (ir1-convert - start cont - (let ((cleanup-fun (gensym)) - (drop-thru-tag (gensym)) - (exit-tag (gensym)) - (next (gensym)) - (start (gensym)) - (count (gensym))) - `(flet ((,cleanup-fun () ,@cleanup nil)) - (block ,drop-thru-tag - (multiple-value-bind - (,next ,start ,count) - (block ,exit-tag - (%unwind-protect (%escape-function ,exit-tag) - (%cleanup-function ,cleanup-fun)) - (%within-cleanup :unwind-protect - (return-from ,drop-thru-tag ,protected))) - (,cleanup-fun) - (%continue-unwind ,next ,start ,count))))))) - - -;;;; MV stuff. - -;;; If there are arguments, multiple-value-call turns into an MV-Combination. -;;; -;;; If there are no arguments, then we convert to a normal combination, -;;; ensuring that a MV-Combination always has at least one argument. This can -;;; be regarded as an optimization, but it is more important for simplifying -;;; compilation of MV-Combinations. -;;; -(def-ir1-translator multiple-value-call ((fun &rest args &whole source) - start cont) - (let* ((fun-cont (make-continuation)) - (node (if args - (make-mv-combination source fun-cont) - (make-combination source fun-cont)))) - (ir1-convert start fun-cont fun) - (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) - (collect ((arg-conts)) - (let ((this-start fun-cont)) - (dolist (arg args) - (let ((this-cont (make-continuation node))) - (ir1-convert this-start this-cont arg) - (setq this-start this-cont) - (arg-conts this-cont))) - (prev-link node this-start) - (use-continuation node cont) - (setf (basic-combination-args node) (arg-conts)))))) - - -;;; IR1 convert Multiple-Value-Prog1 -- Internal -;;; -;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a the -;;; result code use result continuation (CONT), but transfer control to the -;;; evaluation of the body. In other words, the result continuation isn't -;;; Immediately-Used-P by the nodes that compute the result. -;;; -;;; In order to get the control flow right, we convert the result with a dummy -;;; result continuation, then convert all the uses of the dummy to be uses of -;;; CONT. If a use is an Exit, then we also substitute CONT for the dummy in -;;; the corresponding Entry node so that they are consistent. Note that this -;;; doesn't amount to changing the exit target, since the control destination -;;; of an exit is determined by the block successor; we are just indicating the -;;; continuation that the result is delivered to. -;;; -;;; We then convert the body, using another dummy continuation in its own block -;;; as the result. After we are done converting the body, we move all -;;; predecessors of the dummy end block to CONT's block. -;;; -;;; Note that we both exploit and maintain the invariant that the CONT to an -;;; IR1 convert method either has no block or starts the block that control -;;; should transfer to after completion for the form. Nested MV-Prog1's work -;;; because during conversion of the result form, we use dummy continuation -;;; whose block is the true control destination. -;;; -(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont) - (continuation-starts-block cont) - (let* ((dummy-result (make-continuation)) - (dummy-start (make-continuation)) - (cont-block (continuation-block cont))) - (continuation-starts-block dummy-start) - (ir1-convert start dummy-start result) - - (substitute-continuation-uses cont dummy-start) - - (continuation-starts-block dummy-result) - (ir1-convert-progn-body dummy-start dummy-result forms) - (let ((end-block (continuation-block dummy-result))) - (dolist (pred (block-pred end-block)) - (unlink-blocks pred end-block) - (link-blocks pred cont-block)) - (assert (not (continuation-dest dummy-result))) - (delete-continuation dummy-result) - (remove-from-dfo end-block)))) - - -;;;; Interface to defining macros: -;;; -;;; DEFMACRO, DEFUN and DEFCONSTANT expand into calls to %DEFxxx functions -;;; so that we get a chance to see what is going on. We define IR1 translators -;;; for these functions which look at the definition and then generate a call -;;; to the %%DEFxxx function. -;;; - -;;; Warn about incompatible or illegal definitions and add the macro to the -;;; compiler environment. -;;; -;;; Someday we could check for macro arguments being incompatibly redefined. -;;; Doing this right will involve finding the old macro lambda-list and -;;; comparing it with the new one. We don't want to use min-args and max-args -;;; since they don't completely describe the macro's syntax. -;;; -(def-ir1-translator %defmacro ((name def lambda-list doc) start cont - :kind :function) - (let ((name (eval name)) - (def (second def))) ; Don't want to make a function just yet... - (unless (symbolp name) - (compiler-error "Macro name is not a symbol: ~S." name)) - - (force-output) - (ecase (info function kind name) - ((nil)) - (:function - (remhash name *free-functions*) - (compiler-warning - "Defining ~S to be a macro when it was ~(~A~) to be a function." - name (info function where-from name))) - (:macro) - (:special-form - (compiler-error "Attempt to redefine special form ~S as a macro." - name))) - - (setf (info function kind name) :macro) - (setf (info function where-from name) :defined) - - (when *compile-time-define-macros* - (setf (info function macro-function name) - #+new-compiler (coerce def 'function) - #-new-compiler def)) - - (let ((fun (ir1-convert-lambda def))) - (setf (leaf-name fun) - (concatenate 'string "DEFMACRO " (symbol-name name))) - (setf (functional-arg-documentation fun) (eval lambda-list)) - - (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) - - (compiler-mumble "Converted ~S.~%" name))) - -;;; -;;; Convert the definition and substitute for previous global uses. We only -;;; do the substitution if the function is in the null environment, ensuring -;;; that the function cannot be called outside of the correct environment. -;;; Emit top-level code to install the definition. -;;; -(def-ir1-translator %defun ((name def doc source) start cont - :kind :function) - (let* ((name (define-function-name (eval name))) - (expansion - (if (and (member (info function inlinep name) - '(:inline :maybe-inline)) - (in-null-environment)) - (cadr def) nil))) - (setf (info function where-from name) :defined) - (setf (info function inline-expansion name) expansion) - ;; - ;; If there is a previous defun for the same name, disown the leaf for it. - (let ((old (gethash name *free-functions*))) - (when (functional-p old) (remhash name *free-functions*))) - - (let ((fun (ir1-convert-lambda (cadr def) (cadr source))) - (new (gethash name *free-functions*)) - (info (info function info name))) - (setf (leaf-name fun) name) - (cond ((and (in-null-environment t) - (not (eq (info function inlinep name) :notinline)) - (or (not info) - (and (null (function-info-transforms info)) - (null (function-info-templates info)) - (not (function-info-ir2-convert info))))) - (setf (gethash name *free-functions*) fun) - (when new (substitute-leaf fun new))) - (t - (let ((var (find-free-function name "in a strange place"))) - (setf (leaf-where-from var) :defined)))) - - (ir1-convert start cont - `(%%defun ',name ,fun ,doc - ,@(when expansion `(',expansion)))) - (compiler-mumble "Converted ~S.~%" name)))) - - -;;; Update the global environment to correspond to the new definition. We only -;;; record a constant-value when the value is obviously constant. We can have -;;; an optimizer for %%Defconstant that notices when the value becomes constant -;;; and substitutes for the Global-Var structure. -;;; -(def-ir1-translator %defconstant ((name value doc) start cont - :kind :function) - (let ((name (eval name))) - (unless (symbolp name) - (compiler-error "Constant name is not a symbol: ~S." name)) - - (setf (info variable kind name) :constant) - (setf (info variable where-from name) :defined) - - (when (and (constantp value) (not (symbolp value))) - (setf (info variable constant-value name) (eval value))) - (remhash name *free-variables*)) - - (ir1-convert start cont `(%%defconstant ,name ,value ,doc))) diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp deleted file mode 100644 index d93c986402c57953937aaabd9263f687e152b4a7..0000000000000000000000000000000000000000 --- a/compiler/ir1util.lisp +++ /dev/null @@ -1,1611 +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 random utilities used for manipulating the IR1 -;;; representation. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Cleanup hackery: - -;;; Find-Enclosing-Cleanup -- Interface -;;; -;;; Chain up the Lambda-Cleanup thread until we find a Cleanup or null. -;;; -(defun find-enclosing-cleanup (thing) - (declare (type (or cleanup clambda null) thing)) - (etypecase thing - ((or cleanup null) thing) - (clambda (find-enclosing-cleanup (lambda-cleanup thing))))) - - -;;; 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. -;;; -(defun insert-cleanup-code (block1 block2 node form) - (declare (type cblock block1 block2) (type node node)) - (with-ir1-environment node - (setf (component-reanalyze *current-component*) t) - (let* ((start (make-continuation)) - (block (continuation-starts-block start)) - (cont (make-continuation))) - (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)) - - -;;; 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 :lambda nil - :start-cleanup nil :end-cleanup nil - :component nil)) - (setf (continuation-kind cont) :deleted-block-start)) - (t - (node-ends-block (continuation-use cont)))))))) - (undefined-value)) - - -;;; Substitute-Continuation-Uses -- Interface -;;; -;;; Replace all uses of Old with uses of New, where New has an arbitary -;;; number of uses. If a use is an Exit, then we also substitute New for Old -;;; in the Entry's Exits to maintain consistency between the two. -;;; -;;; 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) - (when (exit-p node) - (let ((entry (exit-entry node))) - (when entry - (setf (entry-exits entry) - (nsubst new old (entry-exits entry)))))) - (delete-continuation-use node) - (add-continuation-use node new)) - - (reoptimize-continuation new) - (undefined-value)) - -#| -;;; Substitute-Node-Cont -- Interface -;;; -;;; Replace Old's single use with a use of New. This is used in contexts -;;; where we know that New has no use and Old has a single use. -;;; -(defun substitute-node-cont (new old) - (declare (type continuation new old)) - (assert (member (continuation-kind new) '(:block-start :unused))) - (assert (eq (continuation-kind old) :inside-block)) - - (let ((use (continuation-use old))) - (delete-continuation-use use) - (add-continuation-use use new)) - - (undefined-value)) -|# - - -;;; NODE-BLOCK, NODE-ENVIRONMENT, NODE-TLF-NUMBER -- Interface -;;; -;;; Shorthand for common idiom. -;;; -(proclaim '(inline node-block node-environment node-tlf-number)) -(defun node-block (node) - (declare (type node node)) - (the cblock (continuation-block (node-prev node)))) -;;; -(defun node-environment (node) - (declare (type node node)) - (the environment (lambda-environment (block-lambda (node-block node))))) -;;; -(defun node-tlf-number (node) - (declare (type node node)) - (car (last (node-source-path node)))) - - -;;;; Flow/DFO/Component hackery: - -;;; Link-Blocks, Unlink-Blocks -- Interface -;;; -;;; Join or separate Block1 and Block2. -;;; -(proclaim '(ftype (function (block block) void) link-blocks unlink-blocks)) -(defun link-blocks (block1 block2) - (assert (not (member block2 (block-succ block1)))) - (push block2 (block-succ block1)) - (push block1 (block-pred block2))) -;;; -(defun unlink-blocks (block1 block2) - (assert (member block2 (block-succ block1))) - (setf (block-succ block1) - (delete block2 (block-succ block1))) - (setf (block-pred block2) - (delete block1 (block-pred block2)))) - - -;;; 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. -;;; -(defun change-block-successor (block old new) - (declare (type cblock new old block)) - (unlink-blocks block old) - (unless (member new (block-succ block)) - (link-blocks block new)) - - (let ((last (block-last block))) - (when (if-p last) - (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)) -(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. -;;; -(proclaim '(function add-to-dfo (block block) void)) -(defun add-to-dfo (block after) - (let ((next (block-next after))) - (setf (block-component block) (block-component after)) - (setf (block-next after) block) - (setf (block-prev block) after) - (setf (block-next block) next) - (setf (block-prev next) block))) - - -;;; 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 :lambda nil :start-cleanup nil - :end-cleanup nil :component nil)) - (tail (make-block-key :start nil :lambda nil :start-cleanup nil - :end-cleanup 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. -;;; -;;; If the mess-up for one of Block's End-Cleanups is moved into the new -;;; block, then we must adjust the end/start cleanups of the new and old blocks -;;; to reflect the movement of the mess-up. If any of the old end cleanups -;;; were in the new block, then we scan up from that cleanup trying to find one -;;; that isn't. When we do, that becomes the new start/end cleanup of the -;;; old/new block. We set the start/end as a pair, since we don't want anyone -;;; to think that a cleanup is necessary. -;;; -(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 (eq (continuation-kind start) :inside-block)) - (let* ((succ (block-succ block)) - (cleanup (block-end-cleanup block)) - (new-block - (make-block-key :start start - :lambda (block-lambda block) - :start-cleanup cleanup - :end-cleanup cleanup - :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) - - (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)) - - (let ((start-cleanup (block-start-cleanup block))) - (do ((cup (find-enclosing-cleanup cleanup) - (find-enclosing-cleanup (cleanup-enclosing cup)))) - ((null cup)) - (when (eq (node-block (continuation-use (cleanup-start cup))) - new-block) - (do ((cup (find-enclosing-cleanup (cleanup-enclosing cup)) - (find-enclosing-cleanup (cleanup-enclosing cup)))) - ((null cup) - (setf (block-end-cleanup block) start-cleanup) - (setf (block-start-cleanup new-block) start-cleanup)) - (let ((cb (node-block (continuation-use (cleanup-start cup))))) - (unless (eq cb new-block) - (setf (block-end-cleanup block) cup) - (setf (block-start-cleanup new-block) cup) - (return)))) - (return)))) - - (setf (block-type-asserted block) t) - (setf (block-test-modified block) t)))) - - (undefined-value)) - - -;;;; Deleting stuff: - -;;; 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. -;;; -;;; 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))) - (flush-dest (elt args n)) - (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-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 Component-Lambdas (it won't be there before local -;;; call analysis, but no matter.) -;;; -;;; 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))) - (assert (not (member kind '(:deleted :optional :top-level)))) - (setf (functional-kind leaf) :deleted) - (dolist (let (lambda-lets leaf)) - (setf (functional-kind let) :deleted)) - - (if (or (eq kind :let) (eq kind :mv-let)) - (let ((home (lambda-home leaf))) - (setf (lambda-lets home) (delete leaf (lambda-lets home)))) - (let* ((bind-block (node-block (lambda-bind leaf))) - (component (block-component bind-block)) - (return (lambda-return leaf))) - (unlink-blocks (component-head component) bind-block) - (when return - (unlink-blocks (node-block return) (component-tail component))) - (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)) - (maybe-let-convert 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 :external :let :mv-let :escape :cleanup) - (delete-lambda leaf)) - ((:deleted :optional)))) - (optional-dispatch - (unless (eq (functional-kind leaf) :deleted) - (delete-optional-dispatch leaf))))) - ((null (rest refs)) - (typecase leaf - (clambda (maybe-let-convert leaf)) - (lambda-var (reoptimize-lambda-var leaf)))))) - - (undefined-value)) - - -;;; Delete-Return -- Interface -;;; -;;; Do stuff to indicate that the return node Node is being deleted. We set -;;; the RETURN to NIL and remove the function from its tail set. -;;; -;;; As a rather random special case, we leave the function in the tail set -;;; when there are uses of the result continuation marked TAIL-P. This is done -;;; to prevent the tail set from being blown away when the back end deletes the -;;; return because it discovers that all calls are tail-recursive. -;;; -(defun delete-return (node) - (declare (type creturn node)) - (let* ((fun (return-lambda node)) - (tail-set (lambda-tail-set fun))) - (assert (lambda-return fun)) - (unless (do-uses (use (return-result node) nil) - (when (node-tail-p use) (return t))) - (setf (tail-set-functions tail-set) - (delete fun (tail-set-functions tail-set))) - (setf (lambda-tail-set fun) nil)) - (setf (lambda-return fun) nil)) - (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 Block-Flush-P in the blocks containing uses of -;;; Cont and set Component-Reoptimize. -;;; -;;; If the continuation is :Deleted, then we don't do anything, since all -;;; semantics have already been flushed. If the continuation is a -;;; :Deleted-Block-Start, then we delete the continuation, since its control -;;; semantics have already been deleted. Deleting the continuation causes its -;;; uses to be reoptimized. If the Prev of the use is deleted, then we blow -;;; off reoptimization. -;;; -(defun flush-dest (cont) - (declare (type continuation cont)) - - (ecase (continuation-kind cont) - (:deleted) - (:deleted-block-start - (assert (continuation-dest cont)) - (setf (continuation-dest cont) nil) - (delete-continuation cont)) - ((:inside-block :block-start) - (assert (continuation-dest cont)) - (setf (continuation-dest cont) nil) - (setf (component-reoptimize (block-component (continuation-block cont))) - t) - (do-uses (use cont) - (let ((prev (node-prev use))) - (unless (eq (continuation-kind prev) :deleted) - (let ((block (continuation-block prev))) - (setf (block-flush-p block) t) - (setf (block-type-asserted block) 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) - (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-flush-p block) t) - (setf (block-type-asserted block) t) - (setf (component-reoptimize (block-component block)) t))))) - - (let ((dest (continuation-dest cont))) - (when dest - (let ((block (node-block dest))) - (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.") - (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)) - (basic-combination - (flush-dest (basic-combination-fun node)) - (dolist (arg (basic-combination-args node)) - (when arg (flush-dest arg)))) - (cif - (flush-dest (if-test node))) - (bind - (let ((lambda (bind-lambda node))) - (unless (eq (functional-kind lambda) :deleted) - (assert (member (functional-kind lambda) '(:let :mv-let))) - (delete-lambda lambda)))) - (exit - (let ((value (exit-value node))) - (when value - (flush-dest value)))) - (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)) - - -;;; 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 :source (node-source node))) - (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 (find-enclosing-cleanup (block-start-cleanup block)) - (find-enclosing-cleanup (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)))))))) - - -;;;; 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) - (derive-node-type ref (leaf-type leaf)) - (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)) - - -;;; 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. -;;; -(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)) - (dolist (nlx (environment-nlx-info (node-environment entry)) nil) - (let* ((cleanup (nlx-info-cleanup nlx)) - (entry-cleanup (ecase (cleanup-kind cleanup) - ((:catch :unwind-protect) - (cleanup-enclosing cleanup)) - (:entry cleanup)))) - (when (and (eq (nlx-info-continuation nlx) cont) - (eq (continuation-use (cleanup-start entry-cleanup)) - entry)) - (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) lambda)) -(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.) -;;; -(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 global function reference, then return the -;;; referenced symbol, otherwise NIL. -;;; -(defun continuation-function-name (cont) - (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)) - (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 (eq (functional-kind fun) :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. -;;; -(defun combination-lambda (call) - (declare (type basic-combination call)) - (assert (eq (basic-combination-kind call) :local)) - (ref-leaf (continuation-use (basic-combination-fun call)))) - - -;;;; Compiler error context determination: - -(proclaim '(special *current-path* *current-form*)) - - -;;; 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. -;;; -(defstruct (compiler-error-context - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (format stream "#<Compiler-Error-Context>")))) - ;; - ;; The form immediately responsible for this error (may be the result of - ;; mecroexpansion, etc.) - source - ;; - ;; The form in the original source that expanded into Source. - original-source - ;; - ;; A list of prefixes of "interesting" forms that enclose original-source. - context - ;; - ;; Source for a form enclosing this one, or NIL if unknown. - enclosing-source - ;; - ;; Description of how the value of SOURCE is used by ENCLOSING-SOURCE such as - ;; "third argument", "set value", etc. Null when there is no - ;; ENCLOSING-SOURCE. - (enclosed-how nil :type (or simple-string null))) - - -;;; 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) - - -;;; A list of "DEFxxx" forms for which we should we should compute the source -;;; context by taking the CAR of the first arg when it is a list. -;;; -(defparameter defmumble-take-car-forms '(defstruct)) - - -;;; 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)) - (assert path) - (let* ((rpath (reverse (rest path))) - (root (find-source-root (first rpath) *source-info*))) - (collect ((context)) - (let ((form root) - (current (rest rpath))) - (loop - (let ((head (first form))) - (when (symbolp head) - (let ((name (symbol-name head))) - (when (and (>= (length name) 3) (string= name "DEF" :end1 3)) - (if (>= (length form) 2) - (let ((next (second form))) - (context - (list head - (if (and (listp next) - (member head - defmumble-take-car-forms)) - (car next) - next)))) - (context (list head))))))) - (when (null current) (return)) - (setq form (nth (pop current) form))) - - (cond ((context) - (values form (context))) - ((and path root) - (if (listp root) - (values form (list (subseq root 0 (min 2 (length root))))) - (values form ()))) - (t - (values '(unable to locate source) - '((some strange place))))))))) - - -;;; FIND-ENCLOSING-SOURCE -- Internal -;;; -;;; Look at the DEST of node, and return the source for it, along with a -;;; description of how the value is used by the DEST. This is inhibited when -;;; the DEST has a different source path from NODE. This ensures that the -;;; enclosing source results from macroexpansion of the orignal source (or is -;;; the orignal source). Otherwise, we might return a form enclosing the -;;; orignal source, which would be confusing. -;;; -(defun find-enclosing-source (node) - (declare (type node node)) - (let* ((cont (node-cont node)) - (dest (continuation-dest cont))) - (when (and dest - (equal (node-source-path dest) (node-source-path node))) - (values - (node-source dest) - (etypecase dest - (cif "conditional test value") - (cset "assigned value") - (creturn "function return value") - (exit "RETURN'ed value") - (basic-combination - (if (eq cont (basic-combination-fun dest)) - "called function" - (format nil "~:R argument" - (1+ (position cont - (basic-combination-args dest))))))))))) - - -;;; FIND-ERROR-CONTEXT -- Interface -;;; -;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error -;;; context, or NIL if we can't figure anything out. -;;; -(defun find-error-context () - (let ((context *compiler-error-context*)) - (if (compiler-error-context-p context) - context - (let ((source (cond (*current-form*) - (context (node-source context)) - (t nil))) - (path (if context (node-source-path context) *current-path*))) - (when (and *source-info* path) - (multiple-value-bind (form src-context) - (find-original-source path) - (multiple-value-bind (enclosing how) - (when (and context (not *current-form*)) - (find-enclosing-source context)) - (make-compiler-error-context - :source source - :original-source form - :context src-context - :enclosing-source enclosing - :enclosed-how how)))))))) - - -;;;; 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."))) - -;;; 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*)) -(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.") - - -;;; We save the context information that we printed out most recently so that -;;; we don't print it out redundantly. -;;; -(proclaim '(list *last-source-context*)) -(defvar *last-source-context* nil) -(defvar *last-original-source* nil) -(defvar *last-source-form* nil) -(defvar *last-enclosing-source* nil) -(defvar *last-format-string* nil) -(defvar *last-format-args* nil) -(defvar *last-message-count* 0) - -;;; The stream that compiler error output is directed to, or NIL if error -;;; output is inhibited. -;;; -(defvar *compiler-error-output* (make-synonym-stream '*error-output*)) -(proclaim '(type (or stream null) *compiler-error-output*)) - - -;;; 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 (string what format-string) (list format-args)) - (let* ((*print-level* *error-print-level*) - (*print-length* *error-print-length*) - (stream *compiler-error-output*) - (context (find-error-context))) - - (unless stream (return-from print-error-message (undefined-value))) - - (cond - (context - (let ((context (compiler-error-context-context context)) - (form (compiler-error-context-original-source context)) - (source (compiler-error-context-source context)) - (enclosing (compiler-error-context-enclosing-source context)) - (how (compiler-error-context-enclosed-how context))) - - (unless (tree-equal context *last-source-context*) - (note-message-repeats) - (setq *last-source-context* context) - (setq *last-original-source* '#(invalid)) - (format stream "~2&In:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" context)) - - (unless (tree-equal form *last-original-source*) - (note-message-repeats) - (setq *last-original-source* form) - (setq *last-enclosing-source* '#(invalid)) - (setq *last-format-string* nil) - (format stream " ~S~%" form)) - - (unless (or (tree-equal source form) - (and (member source form) (member source format-args))) - (unless (or (tree-equal enclosing *last-enclosing-source*) - (tree-equal enclosing form)) - (note-message-repeats) - (setq *last-source-form* '#(invalid)) - (setq *last-enclosing-source* enclosing) - (when enclosing - (format stream "==>~% ~S~%" enclosing))) - - (unless (tree-equal source *last-source-form*) - (note-message-repeats) - (setq *last-source-form* source) - (setq *last-format-string* nil) - (unless (member source format-args) - (if *last-enclosing-source* - (format stream "The ~A:~% ~S~%" how source) - (format stream "==>~% ~S~%" source))))))) - (t - (note-message-repeats) - (format stream "~2&"))) - - (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 unsigned-byte *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) - (incf *compiler-note-count*) - (unless (if *compiler-error-context* - (policy *compiler-error-context* (= brevity 3)) - (policy nil (= brevity 3))) - (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-source-context* nil) - (setq *last-format-string* 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: - - -;;; A list of UNDEFINED-WARNING structures representing the calls to unknown -;;; functions. This is bound by WITH-COMPILATION-UNIT. -;;; -(defvar *undefined-warnings*) -(proclaim '(list *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) - (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) - (undefined-warning-warnings res))) - (incf (undefined-warning-count res))) - (undefined-value)) - - -;;; NOTE-NAME-DEFINED -- Interface -;;; -;;; Delete any undefined warnings for Name and Kind. -;;; -(defun note-name-defined (name kind) - (setq *undefined-warnings* - (delete-if #'(lambda (x) - (and (equal (undefined-warning-name x) name) - (eq (undefined-warning-kind x) kind))) - *undefined-warnings*)) - - (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 (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: - -;;; 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) - #-new-compiler - (if clc::*in-the-compiler* - (get-setf-method place env) - (lisp::foo-get-setf-method place env)) - #+new-compiler - (lisp::foo-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) - #-new-compiler - (if clc::*in-the-compiler* - (get-setf-method place env) - (lisp::foo-get-setf-method place env)) - #+new-compiler - (lisp::foo-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/ir2tran.lisp b/compiler/ir2tran.lisp deleted file mode 100644 index 14a1d3be70f98d1236b52b0ca7a85051700c05ae..0000000000000000000000000000000000000000 --- a/compiler/ir2tran.lisp +++ /dev/null @@ -1,1534 +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/ir2tran.lisp,v 1.14 1990/05/12 20:35:59 ram Exp $ -;;; -;;; This file contains the virtual machine independent parts of the code -;;; which does the actual translation of nodes to VOPs. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Moves and type checks: - -;;; Emit-Move -- Internal -;;; -;;; Move X to Y unless they are EQ. -;;; -(defun emit-move (node block x y) - (declare (type node node) (type ir2-block block) (type tn x y)) - (unless (eq x y) - (vop move node block x y)) - (undefined-value)) - - -;;; Type-Check-Template -- Interface -;;; -;;; If there is any CHECK-xxx template for Type, then return it, otherwise -;;; return NIL. -;;; -(defun type-check-template (type) - (declare (type ctype type)) - (multiple-value-bind (check-ptype exact) - (primitive-type type) - (if exact - (primitive-type-check check-ptype) - (let ((name (hairy-type-check-template type))) - (if name - (template-or-lose name) - nil))))) - - -;;; Emit-Type-Check -- Internal -;;; -;;; Emit code in Block to check that Value is of the specified Type, -;;; yielding the checked result in Result. Value and result may be of any -;;; primitive type. There must be CHECK-xxx VOP for Type. Any other type -;;; checks should have been converted to an explicit type test. -;;; -(defun emit-type-check (node block value result type) - (declare (type tn value result) (type node node) (type ir2-block block) - (type ctype type)) - (emit-move-template node block (type-check-template type) value result) - (undefined-value)) - - -;;;; Leaf reference: - -;;; Find-In-Environment -- Internal -;;; -;;; Return the TN that holds the value of Thing in the environment Env. -;;; -(defun find-in-environment (thing env) - (declare (type (or nlx-info lambda-var) thing) (type environment env)) - (or (cdr (assoc thing (ir2-environment-environment (environment-info env)))) - (etypecase thing - (lambda-var - (assert (eq env (lambda-environment (lambda-var-home thing)))) - (leaf-info thing)) - (nlx-info - (assert (eq env - (lambda-environment - (block-lambda - (continuation-block (nlx-info-continuation thing)))))) - (ir2-nlx-info-home (nlx-info-info thing)))))) - - -;;; Constant-TN -- Internal -;;; -;;; If Leaf already has a constant TN, return that, otherwise make a TN for -;;; it. -;;; -(defun constant-tn (leaf) - (declare (type constant leaf)) - (or (leaf-info leaf) - (setf (leaf-info leaf) - (make-constant-tn leaf)))) - - -;;; Leaf-TN -- Internal -;;; -;;; Return a TN that represents the value of Leaf, or NIL if Leaf isn't -;;; directly represented by a TN. Env is the environment that the reference is -;;; done in. -;;; -(defun leaf-tn (leaf env) - (declare (type leaf leaf) (type environment env)) - (typecase leaf - (lambda-var - (unless (lambda-var-indirect leaf) - (find-in-environment leaf env))) - (constant (constant-tn leaf)) - (t nil))) - - -;;; Emit-Constant -- Internal -;;; -;;; Used to conveniently get a handle on a constant TN during IR2 -;;; conversion. Returns a constant TN representing the Lisp object Value. -;;; -(defun emit-constant (value) - (constant-tn (find-constant value))) - - -;;; IR2-Convert-Hairy-Function-Ref -- Internal -;;; -;;; Handle a function Ref that can't be converted to a symbol access. We -;;; convert a call to FDEFINITION with Name as the argument. -;;; -(defun ir2-convert-hairy-function-ref (node block name) - (declare (type ref node) (type ir2-block block) (type tn name)) - (when (policy node (> speed brevity)) - (let ((*compiler-error-context* node)) - (compiler-note "Compiling a full call to FDEFINITION."))) - (let* ((arg (standard-argument-location 0)) - (res (standard-argument-location 0)) - (fun (emit-constant 'fdefinition)) - (fp (make-normal-tn *any-primitive-type*))) - (vop allocate-full-call-frame node block 1 fp) - (vop* call-named node block (fp fun name nil) (res nil) (list arg) 1 1) - (move-continuation-result node block (list res) (node-cont node))) - (undefined-value)) - - -;;; IR2-Convert-Ref -- Internal -;;; -;;; Convert a Ref node. The reference must not be delayed. -;;; -(defun ir2-convert-ref (node block) - (declare (type ref node) (type ir2-block block)) - (let* ((cont (node-cont node)) - (leaf (ref-leaf node)) - (name (leaf-name leaf)) - (locs (continuation-result-tns - cont (list (primitive-type (leaf-type leaf))))) - (res (first locs))) - (etypecase leaf - (lambda-var - (let ((tn (find-in-environment leaf (node-environment node)))) - (if (lambda-var-indirect leaf) - (vop value-cell-ref node block tn res) - (emit-move node block tn res)))) - (constant - (emit-move node block (constant-tn leaf) res)) - (functional - (ir2-convert-closure node block leaf res)) - (global-var - (let ((name-tn (emit-constant name)) - (unsafe (policy node (zerop safety)))) - (ecase (global-var-kind leaf) - ((:special :global :constant) - (assert (symbolp name)) - (if unsafe - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res))) - (:global-function - (unless (symbolp name) - (ir2-convert-hairy-function-ref node block name-tn) - (return-from ir2-convert-ref (undefined-value))) - - (if unsafe - (vop fast-symbol-function node block name-tn res) - (vop symbol-function node block name-tn res))))))) - - (move-continuation-result node block locs cont)) - (undefined-value)) - - -;;; IR2-Convert-Closure -- Internal -;;; -;;; Emit code to load a function object representing Leaf into Res. This -;;; gets interesting when the referenced function is a closure: we must make -;;; the closure and move the closed over values into it. -;;; -;;; Leaf is the XEP lambda for the called function, since local call analysis -;;; converts all closure references. -;;; -(defun ir2-convert-closure (node block leaf res) - (declare (type ref node) (type ir2-block block) - (type functional leaf) (type tn res)) - (let ((entry (make-load-time-constant-tn :entry leaf))) - (cond ((and (lambda-p leaf) - (environment-closure (lambda-environment leaf))) - (let ((this-env (node-environment node)) - (closure (environment-closure (lambda-environment leaf)))) - (vop make-closure node block (emit-constant (length closure)) - entry res) - (let ((n (1- system:%function-closure-variables-offset))) - (dolist (what closure) - (vop closure-init node block - res (find-in-environment what this-env) - (incf n)))))) - (t - (emit-move node block entry res)))) - (undefined-value)) - - -;;; IR2-Convert-Set -- Internal -;;; -;;; Convert a Set node. If the node's cont is annotated, then we also -;;; deliver the value to that continuation. If the var is a lexical variable -;;; with no refs, then we don't actually set anything, since the variable has -;;; been deleted. -;;; -(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) - (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 - (make-normal-tn *any-primitive-type*)))))) - - (when locs - (emit-move node block val (first locs)) - (move-continuation-result node block locs cont))) - (undefined-value)) - - -;;;; Utilities for receiving single values: - -;;; Continuation-TN -- Internal -;;; -;;; Return a TN that can be referenced to get the value of Cont. Cont must -;;; be LTN-Annotated either as a delayed leaf ref or as a fixed, single-value -;;; continuation. -;;; -(defun continuation-tn (node block cont) - (declare (type node node) (type ir2-block block) (type continuation cont)) - (let ((2cont (continuation-info cont))) - (ecase (ir2-continuation-kind 2cont) - (:delayed - (let* ((ref (continuation-use cont)) - (tn (leaf-tn (ref-leaf ref) (node-environment ref))) - (ptype (ir2-continuation-primitive-type 2cont))) - (assert tn) - (if (eq (continuation-type-check cont) t) - (let ((temp (make-normal-tn ptype))) - (emit-type-check node block tn temp - (continuation-asserted-type cont)) - temp) - tn))) - (:fixed - (assert (= (length (ir2-continuation-locs 2cont)) 1)) - (first (ir2-continuation-locs 2cont)))))) - - -;;;; Utilities for delivering values to continuations: - -;;; Continuation-Result-TNs -- Internal -;;; -;;; Return a list of TNs that can be used as result TNs to evaluate an -;;; expression with fixed result types specified by RTypes into the -;;; continuation Cont. This is used together with Move-Continuation-Result to -;;; deliver a fixed values of to a continuation. -;;; -;;; If the continuation isn't annotated (meaning the values are discarded), -;;; or wants a type check, then we make temporaries for each supplied value. -;;; This provides a place to compute the result until we figure out what (if -;;; anything) to do with it. -;;; -;;; If the continuation is fixed-values, and wants the same number of values -;;; as the user wants to deliver, then we just return the -;;; IR2-Continuation-Locs. Otherwise we make a new list padded as necessary by -;;; discarded TNs. -;;; -;;; If the continuation is unknown-values, then we make a boxed TN to -;;; compute each desired result in. -;;; -;;; Currently, we totally ignore the types, always allocating TNs of type T -;;; when we can't use a continuation's TN. This affects unused values and -;;; values needing to be checked. But representation selection cleverly -;;; replaces dummy result TNs with ones in a good representation, so the first -;;; isn't a problem. It seems important to allow non-standard representations -;;; in type checking for numeric subranges, but these checks are hairy, so the -;;; right thing happens. -;;; -(defun continuation-result-tns (cont rtypes) - (declare (type continuation cont) (list rtypes)) - (let ((2cont (continuation-info cont))) - (if (or (not 2cont) (eq (continuation-type-check cont) t)) - (make-n-tns (length rtypes) *any-primitive-type*) - (ecase (ir2-continuation-kind 2cont) - (:fixed - (let ((locs (ir2-continuation-locs 2cont))) - (if (= (length locs) (length rtypes)) - locs - (collect ((res)) - (do ((loc locs (cdr loc)) - (rtype rtypes (cdr rtype))) - ((null rtype)) - (if loc - (res (car loc)) - (res (make-normal-tn *any-primitive-type*)))) - (res))))) - (:unknown - (make-n-tns (length rtypes) *any-primitive-type*)))))) - - -;;; Make-Standard-Value-Tns -- Internal -;;; -;;; Make the first N standard value TNs, returning them in a list. -;;; -(defun make-standard-value-tns (n) - (declare (type unsigned-byte n)) - (collect ((res)) - (dotimes (i n) - (res (standard-argument-location i))) - (res))) - - -;;; Standard-Result-TNs -- Internal -;;; -;;; Return a list of TNs wired to the standard value passing conventions -;;; that can be used to receive values according to the unknown-values -;;; convention. This is used with together Move-Continuation-Result for -;;; delivering unknown values to a fixed values continuation. -;;; -;;; If the continuation isn't annotated, then we treat as 0-values, -;;; returning an empty list of temporaries. -;;; -;;; If the continuation is annotated, then it must be :Fixed. -;;; -(defun standard-result-tns (cont) - (declare (type continuation cont)) - (let ((2cont (continuation-info cont))) - (if 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed - (make-standard-value-tns (length (ir2-continuation-locs 2cont))))) - ()))) - - -;;; Move-Results-Checked -- Internal -;;; -;;; Move the values in the list of TNs Src to the list of TNs Dest, checking -;;; that the types of the values match the Asserted-Type in Cont. What we do -;;; is look at the number of values supplied, desired and asserted, padding out -;;; shorter lists appropriately. -;;; -;;; Missing supplied values are defaulted to NIL. Undesired supplied values -;;; are just checked against the asserted type. If more values are computed -;;; than the type assertion expects, then we don't check these values. We -;;; ignore assertions on values neither supplied nor received. So if there is -;;; an assertion for an unsupplied value, it will be checked against NIL. This -;;; will cause a wrong-type error (if any) rather than a wrong number of values -;;; error. This is consistent with our general policy of not checking values -;;; count. -;;; -(defun move-results-checked (node block src dest cont) - (declare (type node node) (type ir2-block block) - (list src dest) (type ctype type)) - (multiple-value-bind (check types) - (continuation-check-types cont) - (assert (eq check :simple)) - (let* ((count (length types)) - (nsrc (length src)) - (ndest (length dest)) - (nmax (max ndest nsrc))) - (mapc #'(lambda (from to assertion) - (if assertion - (emit-type-check node block from to assertion) - (emit-move node block from to))) - (if (> ndest nsrc) - (append src (make-list (- ndest nsrc) - :initial-element (emit-constant nil))) - src) - (if (< ndest nsrc) - (append dest (nthcdr ndest src)) - dest) - (if (< count nmax) - (append types (make-list (- nmax count) :initial-element nil)) - types)))) - (undefined-value)) - - -;;; Move-Results-Coerced -- Internal -;;; -;;; Just move each Src TN into the corresponding Dest TN, defaulting any -;;; unsupplied source values to NIL. We let Emit-Move worry about doing the -;;; appropriate coercions. -;;; -(defun move-results-coerced (node block src dest) - (declare (type node node) (type ir2-block block) (list src dest)) - (let ((nsrc (length src)) - (ndest (length dest))) - (mapc #'(lambda (from to) - (unless (eq from to) - (emit-move node block from to))) - (if (> ndest nsrc) - (append src (make-list (- ndest nsrc) - :initial-element (emit-constant nil))) - src) - dest)) - (undefined-value)) - - -;;; Move-Continuation-Result -- Internal -;;; -;;; If necessary, emit type-checking/coercion code needed to deliver the -;;; Results to the specified continuation. Node and block provide context for -;;; emitting code. Although usually obtained from Standard-Result-TNs or -;;; Continuation-Result-TNs, Results my be a list of any type or number of TNs. -;;; -;;; If the continuation is fixed values, then move the results into the -;;; continuation locations, doing type checks and defaulting unsupplied values. -;;; -;;; If the continuation is unknown values, then do the moves/checks into the -;;; standard value locations, and use Push-Values to put the values on the -;;; stack. -;;; -(defun move-continuation-result (node block results cont) - (declare (type node node) (type ir2-block block) - (list results) (type continuation cont)) - (let* ((2cont (continuation-info cont)) - (check (eq (continuation-type-check cont) t))) - (when 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed - (let ((locs (ir2-continuation-locs 2cont))) - (cond ((eq locs results)) - (check - (move-results-checked node block results locs cont)) - (t - (move-results-coerced node block results locs))))) - (:unknown - (let* ((nvals (length results)) - (locs (make-standard-value-tns nvals))) - (if check - (move-results-checked node block results locs cont) - (move-results-coerced node block results locs)) - (vop* push-values node block - ((reference-tn-list locs nil)) - ((reference-tn-list (ir2-continuation-locs 2cont) t)) - nvals)))))) - (undefined-value)) - - -;;;; Template conversion: - - -;;; Reference-Arguments -- Internal -;;; -;;; Build a TN-Refs list that represents access to the values of the -;;; specified list of continuations Args for Template. Any :CONSTANT arguments -;;; are returned in the second value as a list rather than being accessed as a -;;; normal argument. Node and Block provide the context for emitting any -;;; necessary type-checking code. -;;; -(defun reference-arguments (node block args template) - (declare (type node node) (type ir2-block block) (list args) - (type template template)) - (collect ((info-args)) - (let ((last nil) - (first nil)) - (do ((args args (cdr args)) - (types (template-arg-types template) (cdr types))) - ((null args)) - (let ((type (first types)) - (arg (first args))) - (if (and (consp type) (eq (car type) ':constant)) - (info-args (continuation-value arg)) - (let ((ref (reference-tn (continuation-tn node block arg) nil))) - (if last - (setf (tn-ref-across last) ref) - (setf first ref)) - (setq last ref))))) - - (values (the (or tn-ref null) first) (info-args))))) - - -;;; IR2-Convert-Conditional -- Internal -;;; -;;; Convert a conditional template. We try to exploit any drop-through, but -;;; emit an unconditional branch afterward if we fail. Not-P is true if the -;;; sense of the Template's test should be negated. -;;; -(defun ir2-convert-conditional (node block template args info-args if not-p) - (declare (type node node) (type ir2-block block) - (type template template) (type (or tn-ref null) args) - (list info-args) (type cif if) (type boolean not-p)) - (assert (= (template-info-arg-count template) (+ (length info-args) 2))) - (let ((consequent (if-consequent if)) - (alternative (if-alternative if))) - (cond ((drop-thru-p if consequent) - (emit-template node block template args nil - (list* (block-label alternative) (not not-p) - info-args))) - (t - (emit-template node block template args nil - (list* (block-label consequent) not-p info-args)) - (unless (drop-thru-p if alternative) - (vop branch node block (block-label alternative))))))) - - -;;; IR2-Convert-IF -- Internal -;;; -;;; Convert an IF that isn't the DEST of a conditional template. -;;; -(defun ir2-convert-if (node block) - (declare (type ir2-block block) (type cif node)) - (let* ((test (if-test node)) - (test-ref (reference-tn (continuation-tn node block test) nil)) - (nil-ref (reference-tn (emit-constant nil) nil))) - (setf (tn-ref-across test-ref) nil-ref) - (ir2-convert-conditional node block (template-or-lose 'if-eq) - test-ref () node t))) - - -;;; IR2-Convert-Template -- Internal -;;; -;;; Get the operands into TNs, make TN-Refs for them, and then call the -;;; template emit function. -;;; -(defun ir2-convert-template (call block) - (declare (type combination call) (type ir2-block block)) - (let* ((template (combination-info call)) - (cont (node-cont call)) - (rtypes (template-result-types template))) - (multiple-value-bind - (args info-args) - (reference-arguments call block (combination-args call) template) - (assert (not (template-more-results-type template))) - (if (eq rtypes :conditional) - (ir2-convert-conditional call block template args info-args - (continuation-dest cont) nil) - (let* ((results (continuation-result-tns cont rtypes)) - (r-refs (reference-tn-list results t))) - (assert (= (length info-args) - (template-info-arg-count template))) - (if info-args - (emit-template call block template args r-refs info-args) - (emit-template call block template args r-refs)) - (move-continuation-result call block results cont))))) - (undefined-value)) - - -;;; %%Primitive IR2 Convert -- Internal -;;; -;;; We don't have to do much because operand count checking is done by IR1 -;;; conversion. The only difference between this and the function case of -;;; IR2-Convert-Template is that there can be codegen-info arguments. -;;; -(defoptimizer (%%primitive ir2-convert) ((template info &rest args) call block) - (let* ((template (continuation-value template)) - (info (continuation-value info)) - (cont (node-cont call)) - (rtypes (template-result-types template)) - (results (continuation-result-tns cont rtypes)) - (r-refs (reference-tn-list results t))) - (multiple-value-bind - (args info-args) - (reference-arguments call block (cddr (combination-args call)) - template) - (assert (not (template-more-results-type template))) - (assert (not (eq rtypes :conditional))) - (assert (null info-args)) - - (if info - (emit-template call block template args r-refs info) - (emit-template call block template args r-refs)) - - (move-continuation-result call block results cont))) - (undefined-value)) - - -;;;; Local call: - -;;; IR2-Convert-Let -- Internal -;;; -;;; Convert a let by moving the argument values into the variables. Since a -;;; a let doesn't have any passing locations, we move the arguments directly -;;; into the variables. We must also allocate any indirect value cells, since -;;; there is no function prologue to do this. -;;; -(defun ir2-convert-let (node block fun) - (declare (type combination node) (type ir2-block block) (type clambda fun)) - (mapc #'(lambda (var arg) - (when arg - (let ((src (continuation-tn node block arg)) - (dest (leaf-info var))) - (if (lambda-var-indirect var) - (vop make-value-cell node block src dest) - (emit-move node block src dest))))) - (lambda-vars fun) (basic-combination-args node)) - (undefined-value)) - - -;;; IR2-Convert-Tail-Local-Call -- Internal -;;; -;;; A tail-recursive local call is done by emitting moves of stuff into the -;;; appropriate passing locations. After setting up the args and environment, -;;; we just move our return-pc and old-fp into the called function's passing -;;; locations. -;;; -(defun ir2-convert-tail-local-call (node block fun) - (declare (type combination node) (type ir2-block block) (type clambda fun)) - (let* ((called-env (environment-info (lambda-environment fun))) - (arg-locs (ir2-environment-arg-locs called-env)) - (this-1env (node-environment node)) - (this-env (environment-info this-1env))) - (dolist (arg (basic-combination-args node)) - (when arg - (emit-move node block (continuation-tn node block arg) - (pop arg-locs)))) - - (dolist (thing (ir2-environment-environment called-env)) - (emit-move node block (find-in-environment (car thing) this-1env) - (pop arg-locs))) - - (emit-move node block (ir2-environment-old-fp this-env) - (ir2-environment-old-fp-pass called-env)) - (emit-move node block (ir2-environment-return-pc this-env) - (ir2-environment-return-pc-pass called-env))) - - (undefined-value)) - - -;;; IR2-CONVERT-LOCAL-CALL-ARGS -- Internal -;;; -;;; Do stuff to set up the arguments to a non-tail local call (including -;;; implicit environment args.) We allocate a frame (returning the FP and -;;; NFP), and also compute the TN-Refs list for the values to pass and the list -;;; of passingt location TNs. -;;; -(defun ir2-convert-local-call-args (node block env) - (declare (type combination node) (type ir2-block block) - (type ir2-environment env)) - (let ((fp (make-normal-tn *any-primitive-type*)) - (nfp (make-normal-tn *any-primitive-type*)) - (old-fp (make-normal-tn *any-primitive-type*)) - (this-1env (node-environment node))) - - (vop current-fp node block old-fp) - (vop allocate-frame node block env fp nfp) - - (let* ((args (reference-tn old-fp nil)) - (tail args)) - (dolist (arg (basic-combination-args node)) - (when arg - (let ((arg-ref (reference-tn (continuation-tn node block arg) nil))) - (setf (tn-ref-across tail) arg-ref) - (setf tail arg-ref)))) - - (dolist (thing (ir2-environment-environment env)) - (let ((arg-ref (reference-tn - (find-in-environment (car thing) this-1env) - nil))) - (setf (tn-ref-across tail) arg-ref) - (setf tail arg-ref))) - - (values fp nfp args - (cons (ir2-environment-old-fp-pass env) - (ir2-environment-arg-locs env)))))) - - -;;; IR2-Convert-Local-Known-Call -- Internal -;;; -;;; Handle a non-TR known-values local call. We Emit the call, then move -;;; the results to the continuation's destination. -;;; -(defun ir2-convert-local-known-call (node block env returns cont start) - (declare (type node node) (type ir2-block block) (type ir2-environment env) - (type return-info returns) (type continuation cont) - (type label start)) - (multiple-value-bind (fp nfp args arg-locs) - (ir2-convert-local-call-args node block env) - (let ((locs (return-info-locations returns))) - (vop* known-call-local node block - (fp nfp args) - ((reference-tn-list locs t)) - arg-locs env start) - (move-continuation-result node block locs cont))) - (undefined-value)) - - -;;; IR2-Convert-Local-Unknown-Call -- Internal -;;; -;;; Handle a non-TR unknown-values local call. We do different things -;;; depending on what kind of values the continuation wants. -;;; -;;; If Cont is :Unknown, then we use the "Multiple-" variant, directly -;;; specifying the continuation's Locs as the VOP results so that we don't have -;;; to do anything after the call. -;;; -;;; Otherwise, we use Standard-Result-Tns to get wired result TNs, and -;;; then call Move-Continuation-Result to do any necessary type checks or -;;; coercions. -;;; -(defun ir2-convert-local-unknown-call (node block env cont start) - (declare (type node node) (type ir2-block block) (type ir2-environment env) - (type continuation cont) (type label start)) - (multiple-value-bind (fp nfp args arg-locs) - (ir2-convert-local-call-args node block env) - (let ((2cont (continuation-info cont))) - (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (vop* multiple-call-local node block (fp nfp args) - ((reference-tn-list (ir2-continuation-locs 2cont) t)) - arg-locs env start) - (let ((temps (standard-result-tns cont))) - (vop* call-local node block - (fp nfp args) - ((reference-tn-list temps t)) - arg-locs env start (length temps)) - (move-continuation-result node block temps cont))))) - (undefined-value)) - - -;;; IR2-Convert-Local-Call -- Internal -;;; -;;; Dispatch to the appropriate function, depending on whether we have a -;;; let, tail or normal call. -;;; -(defun ir2-convert-local-call (node block) - (declare (type combination node) (type ir2-block block)) - (let ((fun (ref-leaf (continuation-use (basic-combination-fun node))))) - (cond ((eq (functional-kind fun) :let) - (ir2-convert-let node block fun)) - ((node-tail-p node) - (ir2-convert-tail-local-call node block fun)) - (t - (let* ((env (environment-info (lambda-environment fun))) - (start (block-label (node-block (lambda-bind fun)))) - (returns (tail-set-info (lambda-tail-set fun))) - (cont (node-cont node))) - (ecase (return-info-kind returns) - (:unknown - (ir2-convert-local-unknown-call node block env cont start)) - (:fixed - (ir2-convert-local-known-call node block env returns - cont start))))))) - (undefined-value)) - - -;;;; Full call: - - -;;; Function-Continuation-TN -- Internal -;;; -;;; Given a function continuation Fun, return as values a TN holding the -;;; thing that we call and true if the thing is a symbol (false if it is a -;;; function). -;;; -(defun function-continuation-tn (node block cont) - (declare (type continuation cont)) - (let* ((2cont (continuation-info cont)) - (name (if (eq (ir2-continuation-kind 2cont) :delayed) - (let ((res (continuation-function-name cont))) - (assert res) - res) - nil))) - (if name - (values (emit-constant name) t) - (let ((locs (ir2-continuation-locs 2cont)) - (type (ir2-continuation-primitive-type 2cont))) - (assert (and (eq (ir2-continuation-kind 2cont) :fixed) - (= (length locs) 1))) - (if (eq (primitive-type-name type) 'function) - (values (first locs) nil) - (let ((temp (make-normal-tn *any-primitive-type*))) - (when (policy node (> speed brevity)) - (let ((*compiler-error-context* node)) - (compiler-note "Called function might be a symbol, so ~ - must coerce at run-time."))) - (vop coerce-to-function node block (first locs) temp) - (values temp nil))))))) - - -;;; MOVE-TAIL-FULL-CALL-ARGS -- Internal -;;; -;;; Set up the args to Node in the current frame, and return a tn-ref list -;;; for the passing locations. -;;; -(defun move-tail-full-call-args (node block) - (declare (type combination node) (type ir2-block block)) - (let ((args (basic-combination-args node)) - (last nil) - (first nil)) - (dotimes (num (length args)) - (let ((loc (standard-argument-location num))) - (emit-move node block (continuation-tn node block (elt args num)) loc) - (let ((ref (reference-tn loc nil))) - (if last - (setf (tn-ref-across last) ref) - (setf first ref)) - (setq last ref)))) - first)) - - -;;; IR2-Convert-Tail-Full-Call -- Internal -;;; -;;; Move the arguments into the passing locations and do a (possibly named) -;;; tail call. -;;; -(defun ir2-convert-tail-full-call (node block) - (declare (type combination node) (type ir2-block block)) - (let* ((env (environment-info (node-environment node))) - (args (basic-combination-args node)) - (nargs (length args)) - (pass-refs (move-tail-full-call-args node block)) - (old-fp (ir2-environment-old-fp env)) - (return-pc (ir2-environment-return-pc env))) - - (multiple-value-bind - (fun-tn named) - (function-continuation-tn node block (basic-combination-fun node)) - (if named - (vop* tail-call-named node block - (fun-tn old-fp return-pc pass-refs) - (nil) - nargs) - (vop* tail-call node block - (fun-tn old-fp return-pc pass-refs) - (nil) - nargs)))) - - (undefined-value)) - - -;;; IR2-CONVERT-FULL-CALL-ARGS -- Internal -;;; -;;; Like IR2-CONVERT-LOCAL-CALL-ARGS, only different. -;;; -(defun ir2-convert-full-call-args (node block) - (declare (type combination node) (type ir2-block block)) - (let* ((args (basic-combination-args node)) - (fp (make-normal-tn *any-primitive-type*)) - (nargs (length args))) - (vop allocate-full-call-frame node block nargs fp) - (collect ((locs)) - (let ((last nil) - (first nil)) - (dotimes (num nargs) - (locs (standard-argument-location num)) - (let ((ref (reference-tn (continuation-tn node block (elt args num)) - nil))) - (if last - (setf (tn-ref-across last) ref) - (setf first ref)) - (setq last ref))) - - (values fp first (locs) nargs))))) - - -;;; IR2-Convert-Fixed-Full-Call -- Internal -;;; -;;; Do full call when a fixed number of values are desired. We make -;;; Standard-Result-TNs for our continuation, then deliver the result using -;;; Move-Continuation-Result. We do named or normal call, as appropriate. -;;; -(defun ir2-convert-fixed-full-call (node block) - (declare (type combination node) (type ir2-block block)) - (multiple-value-bind (fp args arg-locs nargs) - (ir2-convert-full-call-args node block) - (let* ((cont (node-cont node)) - (locs (standard-result-tns cont)) - (loc-refs (reference-tn-list locs t)) - (nvals (length locs))) - (multiple-value-bind - (fun-tn named) - (function-continuation-tn node block (basic-combination-fun node)) - (if named - (vop* call-named node block (fp fun-tn args) (loc-refs) - arg-locs nargs nvals) - (vop* call node block (fp fun-tn args) (loc-refs) - arg-locs nargs nvals)) - (move-continuation-result node block locs cont)))) - (undefined-value)) - - -;;; IR2-Convert-Multiple-Full-Call -- Internal -;;; -;;; Do full call when unknown values are desired. -;;; -(defun ir2-convert-multiple-full-call (node block) - (declare (type combination node) (type ir2-block block)) - (multiple-value-bind (fp args arg-locs nargs) - (ir2-convert-full-call-args node block) - (let* ((cont (node-cont node)) - (locs (ir2-continuation-locs (continuation-info cont))) - (loc-refs (reference-tn-list locs t))) - (multiple-value-bind - (fun-tn named) - (function-continuation-tn node block (basic-combination-fun node)) - (if named - (vop* multiple-call-named node block (fp fun-tn args) (loc-refs) - arg-locs nargs) - (vop* multiple-call node block (fp fun-tn args) (loc-refs) - arg-locs nargs))))) - (undefined-value)) - - -;;; IR2-Convert-Full-Call -- Internal -;;; -;;; If the call is in a TR position and the return convention is standard, -;;; then do a tail full call. If one or fewer values are desired, then use a -;;; single-value call, otherwise use a multiple-values call. -;;; -(defun ir2-convert-full-call (node block) - (declare (type combination node) (type ir2-block block)) - (let ((2cont (continuation-info (node-cont node)))) - (cond ((node-tail-p node) - (ir2-convert-tail-full-call node block)) - ((and 2cont - (eq (ir2-continuation-kind 2cont) :unknown)) - (ir2-convert-multiple-full-call node block)) - (t - (ir2-convert-fixed-full-call node block)))) - (undefined-value)) - - -;;;; Function entry: - -;;; Init-XEP-Environment -- Internal -;;; -;;; Do all the stuff that needs to be done on XEP entry: -;;; -- Create frame -;;; -- Copy any more arg -;;; -- Set up the environment, accessing any closure variables -;;; -(defun init-xep-environment (node block fun) - (declare (type bind node) (type ir2-block block) (type clambda fun)) - (vop xep-allocate-frame node block (entry-info-offset (leaf-info fun))) - (let ((ef (functional-entry-function fun))) - (when (and (optional-dispatch-p ef) - (optional-dispatch-more-entry ef)) - (vop copy-more-arg node block (optional-dispatch-max-args ef)))) - - (let ((env (environment-info (node-environment node)))) - (if (ir2-environment-environment env) - (let ((closure (make-normal-tn *any-primitive-type*))) - (vop setup-closure-environment node block closure) - (let ((n (1- system:%function-closure-variables-offset))) - (dolist (loc (ir2-environment-environment env)) - (vop closure-ref node block closure (incf n) (cdr loc))))) - (vop setup-environment node block))) - - (undefined-value)) - - -;;; IR2-Convert-Bind -- Internal -;;; -;;; Emit moves from the passing locations to the internal locations. This -;;; is only called on bind nodes for functions that allocate environments. All -;;; semantics of let calls are handled by IR2-Convert-Let. -;;; -;;; We special-case XEPs by calling Init-XEP-Environment before moving the -;;; arguments. Init-XEP-Environment accesses any environment values from the -;;; closure, so initialization of the environment from implicit arguments is -;;; suppressed. -;;; -(defun ir2-convert-bind (node block) - (declare (type bind node) (type ir2-block block)) - (let* ((fun (bind-lambda node)) - (xep-p (external-entry-point-p fun)) - (env (environment-info (lambda-environment fun))) - (args (ir2-environment-arg-locs env))) - (assert (member (functional-kind fun) - '(nil :external :optional :top-level :cleanup))) - - (when xep-p - (init-xep-environment node block fun)) - - (dolist (arg (lambda-vars fun)) - (when (leaf-refs arg) - (let ((pass (pop args)) - (home (leaf-info arg))) - (if (lambda-var-indirect arg) - (vop make-value-cell node block pass home) - (emit-move node block pass home))))) - - (unless xep-p - (dolist (loc (ir2-environment-environment env)) - (emit-move node block (pop args) (cdr loc)))) - - (when (ir2-environment-old-fp env) - (emit-move node block (ir2-environment-old-fp-pass env) - (ir2-environment-old-fp env))) - - (when (ir2-environment-return-pc env) - (emit-move node block (ir2-environment-return-pc-pass env) - (ir2-environment-return-pc env))) - - (let ((lab (gen-label))) - (setf (ir2-environment-environment-start env) lab) - (vop note-environment-start node block lab))) - - (undefined-value)) - - -;;;; Function return: - -;;; IR2-Convert-Return -- Internal -;;; -;;; Do stuff to return from a function with the specified values and -;;; convention. If the return convention is :Fixed and we aren't returning -;;; from an XEP, then we move the return values to the passing locs and do a -;;; Known-Return. Otherwise, we use the unknown-values convention. If there -;;; is a fixed number of return values, then use Return, otherwise use -;;; Return-Multiple. -;;; -(defun ir2-convert-return (node block) - (declare (type creturn node) (type ir2-block block)) - (let* ((cont (continuation-info (return-result node))) - (cont-kind (ir2-continuation-kind cont)) - (cont-locs (ir2-continuation-locs cont)) - (fun (return-lambda node)) - (env (environment-info (lambda-environment fun))) - (old-fp (ir2-environment-old-fp env)) - (return-pc (ir2-environment-return-pc env)) - (returns (tail-set-info (lambda-tail-set fun)))) - (cond - ((and (eq (return-info-kind returns) :fixed) - (not (external-entry-point-p fun))) - (vop* known-return node block - (old-fp return-pc (reference-tn-list cont-locs nil)) - (nil) - (return-info-locations returns))) - ((eq cont-kind :fixed) - (let* ((nvals (length cont-locs)) - (locs (make-standard-value-tns nvals))) - (mapc #'(lambda (val loc) - (emit-move node block val loc)) - cont-locs - locs) - (vop* return node block - (old-fp return-pc (reference-tn-list locs nil)) - (nil) - nvals))) - (t - (assert (eq cont-kind :unknown)) - (vop* return-multiple node block - (old-fp return-pc (reference-tn-list cont-locs nil)) - (nil))))) - - (undefined-value)) - - -;;;; Multiple values: - -;;; IR2-Convert-MV-Bind -- Internal -;;; -;;; Almost identical to IR2-Convert-Let. Since LTN annotates the -;;; continuation for the correct number of values (with the continuation user -;;; responsible for defaulting), we can just pick them up from the -;;; continuation. -;;; -(defun ir2-convert-mv-bind (node block) - (declare (type mv-combination node) (type ir2-block block)) - (let ((cont (continuation-info (first (basic-combination-args node)))) - (fun (ref-leaf (continuation-use (basic-combination-fun node))))) - (assert (eq (functional-kind fun) :mv-let)) - (mapc #'(lambda (src var) - (when (leaf-refs var) - (let ((dest (leaf-info var))) - (if (lambda-var-indirect var) - (vop make-value-cell node block src dest) - (emit-move node block src dest))))) - (ir2-continuation-locs cont) (lambda-vars fun))) - (undefined-value)) - - -;;; IR2-Convert-MV-Call -- Internal -;;; -;;; Emit the appropriate fixed value, unknown value or tail variant of -;;; Call-Variable. Note that we only need to pass the values start for the -;;; first argument: all the other argument continuation TNs are ignored. This -;;; is because we require all of the values globs to be contiguous and on stack -;;; top. -;;; -(defun ir2-convert-mv-call (node block) - (declare (type mv-combination node) (type ir2-block block)) - (assert (basic-combination-args node)) - (let* ((start-cont (continuation-info (first (basic-combination-args node)))) - (start (first (ir2-continuation-locs start-cont))) - (tails (node-tail-p node)) - (cont (node-cont node)) - (2cont (continuation-info cont))) - (multiple-value-bind - (fun named) - (function-continuation-tn node block (basic-combination-fun node)) - (assert (and (not named) - (eq (ir2-continuation-kind start-cont) :unknown))) - (cond - (tails - (let ((env (environment-info (node-environment node)))) - (vop tail-call-variable node block start fun - (ir2-environment-old-fp env) - (ir2-environment-return-pc env)))) - ((and 2cont - (eq (ir2-continuation-kind 2cont) :unknown)) - (vop* multiple-call-variable node block (start fun nil) - ((reference-tn-list (ir2-continuation-locs 2cont) t)))) - (t - (let ((locs (standard-result-tns cont))) - (vop* call-variable node block (start fun nil) - ((reference-tn-list locs t)) (length locs)) - (move-continuation-result node block locs cont))))))) - - -;;; %Pop-Values IR2 convert -- Internal -;;; -;;; Reset the stack pointer to the start of the specified unknown-values -;;; continuation (discarding it and all values globs on top of it.) -;;; -(defoptimizer (%pop-values ir2-convert) ((continuation) node block) - (let ((2cont (continuation-info (continuation-value continuation)))) - (assert (eq (ir2-continuation-kind 2cont) :unknown)) - (vop reset-stack-pointer node block - (first (ir2-continuation-locs 2cont))))) - - -;;; Values IR2 convert -- Internal -;;; -;;; Deliver the values TNs to Cont using Move-Continuation-Result. -;;; -(defoptimizer (values ir2-convert) ((&rest values) node block) - (let ((tns (mapcar #'(lambda (x) - (continuation-tn node block x)) - values))) - (move-continuation-result node block tns (node-cont node)))) - - -;;; Values-List IR2 convert -- Internal -;;; -;;; In the normal case where unknown values are desired, we use the -;;; Values-List VOP. In the relatively unimportant case of Values-List for a -;;; fixed number of values, we punt by doing a full call to the Values-List -;;; function. This gets the full call VOP to deal with defaulting any -;;; unsupplied values. It seems unworthwhile to optimize this case. -;;; -(defoptimizer (values-list ir2-convert) ((list) node block) - (let* ((cont (node-cont node)) - (2cont (continuation-info cont))) - (when 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed (ir2-convert-full-call node block)) - (:unknown - (let ((locs (ir2-continuation-locs 2cont))) - (vop* values-list node block - ((continuation-tn node block list) nil) - ((reference-tn-list locs t))))))))) - - -;;;; Special binding: - -;;; %Special-Bind, %Special-Unbind IR2 convert -- Internal -;;; -;;; Trivial, given our assumption of a shallow-binding implementation. -;;; -(defoptimizer (%special-bind ir2-convert) ((var value) node block) - (let ((name (leaf-name (continuation-value var)))) - (vop bind node block (continuation-tn node block value) - (emit-constant name)))) -;;; -(defoptimizer (%special-unbind ir2-convert) ((var) node block) - (vop unbind node block (emit-constant 1))) - - -;;; PROGV IR1 convert -- Internal -;;; -;;; ### Not clear that this really belongs in this file, or should really be -;;; done this way, but this is the least violation of abstraction in the -;;; current setup. We don't want to wire shallow-binding assumptions into -;;; IR1tran. -;;; -(def-ir1-translator progv ((vars vals &body body) start cont) - (ir1-convert - start cont - (if *converting-for-interpreter* - `(%progv ,vars ,vals #'(lambda () ,@body)) - (once-only ((n-save-bs '(%primitive current-binding-pointer))) - `(unwind-protect - (progn - (mapc #'(lambda (var val) - (%primitive bind val var)) - ,vars - ,vals) - ,@body) - (%primitive unbind-to-here ,n-save-bs)))))) - - -;;;; Non-local exit: - -;;; IR2-Convert-Exit -- Internal -;;; -;;; Convert a non-local lexical exit. First find the NLX-Info in our -;;; environment. After indirecting the value cell, we invalidate the exit by -;;; setting the cell to 0. Note that this is never called on the escape exits -;;; for Catch and Unwind-Protect, since the escape functions aren't IR2 -;;; converted. -;;; -(defun ir2-convert-exit (node block) - (declare (type exit node) (type ir2-block block)) - (let ((loc (find-in-environment (find-nlx-info (exit-entry node) - (node-cont node)) - (node-environment node))) - (temp (make-normal-tn *any-primitive-type*)) - (value (exit-value node))) - (vop value-cell-ref node block loc temp) - (vop value-cell-set node block loc (emit-constant 0)) - (if value - (let ((locs (ir2-continuation-locs (continuation-info value)))) - (vop unwind node block temp (first locs) (second locs))) - (let ((0-tn (emit-constant 0))) - (vop unwind node block temp 0-tn 0-tn)))) - - (undefined-value)) - - -;;; This function invalidates a lexical exit on exiting from the dynamic -;;; extent. This is done by storing 0 into the indirect value cell that holds -;;; the closed unwind block. -;;; -(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))) - - -;;; IR2-Convert-Throw -- Internal -;;; -;;; We have to do a spurious move of no values to the result continuation so -;;; that lifetime analysis won't get confused. -;;; -(defun ir2-convert-throw (node block) - (declare (type mv-combination node) (type ir2-block block)) - (let ((args (basic-combination-args node))) - (vop* throw node block - ((continuation-tn node block (first args)) - (reference-tn-list - (ir2-continuation-locs (continuation-info (second args))) - nil)) - (nil))) - - (move-continuation-result node block () (node-cont node)) - (undefined-value)) - - -;;; Emit-NLX-Start -- Internal -;;; -;;; Emit code to set up a non-local-exit. Info is the NLX-Info for the -;;; exit, and Tag is the continuation for the catch tag (if any.) We get at -;;; the entry PC by making a :Label load-time constant TN. This is a -;;; non-immediate constant TN that is initialized to the offset of the -;;; specified label. -;;; -(defun emit-nlx-start (node block info tag) - (declare (type node node) (type ir2-block block) (type nlx-info info) - (type (or continuation null) tag)) - (let* ((2info (nlx-info-info info)) - (kind (cleanup-kind (nlx-info-cleanup info))) - (block-tn (environment-live-tn - (make-representation-tn (sc-number-or-lose 'catch-block)) - (node-environment node))) - (res (make-normal-tn *any-primitive-type*)) - (target-tn - (make-load-time-constant-tn - :label - (block-label (nlx-info-target info))))) - - (vop* save-dynamic-state node block - (nil) - ((reference-tn-list (ir2-nlx-info-dynamic-state 2info) t))) - (vop current-stack-pointer node block (ir2-nlx-info-save-sp 2info)) - - (ecase kind - (:catch - (vop make-catch-block node block block-tn - (continuation-tn node block tag) target-tn res)) - ((:unwind-protect :entry) - (vop make-unwind-block node block block-tn target-tn res))) - - (ecase kind - (:entry - (vop make-value-cell node block res (ir2-nlx-info-home 2info))) - (:unwind-protect - (vop set-unwind-protect node block block-tn)) - (:catch))) - - (undefined-value)) - - -;;; IR2-Convert-Entry -- Internal -;;; -;;; Scan each of Entry's exits, setting up the exit for each lexical exit. -;;; -(defun ir2-convert-entry (node block) - (declare (type entry node) (type ir2-block block)) - (dolist (exit (entry-exits node)) - (let ((info (find-nlx-info node exit))) - (when (and info (eq (cleanup-kind (nlx-info-cleanup info)) :entry)) - (emit-nlx-start node block info nil) - (return)))) - (undefined-value)) - - -;;; %Catch, %Unwind-Protect IR2 convert -- Internal -;;; -;;; Set up the unwind block for these guys. -;;; -(defoptimizer (%catch ir2-convert) ((info-cont tag) node block) - (emit-nlx-start node block (continuation-value info-cont) tag)) -;;; -(defoptimizer (%unwind-protect ir2-convert) ((info-cont cleanup) node block) - (emit-nlx-start node block (continuation-value info-cont) nil)) - - -;;; %NLX-Entry IR2 convert -- Internal -;;; -;;; Emit the entry code for a non-local exit. We receive values and restore -;;; dynamic state. -;;; -;;; In the case of a lexical exit or Catch, we look at the exit continuation's -;;; kind to determine which flavor of entry VOP to emit. If unknown values, -;;; emit the xxx-MULTIPLE variant to the continuation locs. If fixed values, -;;; make the appropriate number of temps in the standard values locations and -;;; use the other variant, delivering the temps to the continuation using -;;; Move-Continuation-Result. -;;; -;;; In the Unwind-Protect case, we deliver the first register argument, the -;;; argument count and the argument pointer to our continuation as multiple -;;; values. These values are the block exited to and the values start and -;;; count. -;;; -;;; After receiving values, we restore dynamic state. Except in the -;;; Unwind-Protect case, the values receiving restores the stack pointer. In -;;; an Unwind-Protect cleanup, we want to leave the stack pointer alone, since -;;; the thrown values are still out there. -;;; -(defoptimizer (%nlx-entry ir2-convert) ((info-cont) node block) - (let* ((info (continuation-value info-cont)) - (cont (nlx-info-continuation info)) - (2cont (continuation-info cont)) - (2info (nlx-info-info info)) - (top-loc (ir2-nlx-info-save-sp 2info)) - (start-loc (make-old-fp-passing-location t)) - (count-loc (make-argument-count-location))) - - (ecase (cleanup-kind (nlx-info-cleanup info)) - ((:catch :entry) - (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (vop* nlx-entry-multiple node block - (top-loc start-loc count-loc nil) - ((reference-tn-list (ir2-continuation-locs 2cont) t))) - (let ((locs (standard-result-tns cont))) - (vop* nlx-entry node block - (top-loc start-loc count-loc nil) - ((reference-tn-list locs t)) - (length locs)) - (move-continuation-result node block locs cont)))) - (:unwind-protect - (let ((block-loc (standard-argument-location 0))) - (vop uwp-entry node block block-loc start-loc count-loc) - (move-continuation-result - node block - (list block-loc start-loc count-loc) - cont)))) - - (vop* restore-dynamic-state node block - ((reference-tn-list (ir2-nlx-info-dynamic-state 2info) nil)) - (nil)))) - - -;;;; N-arg functions: - -(macrolet ((frob (name) - `(defoptimizer (,name 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 (primitive-type (specifier-type 'list)))))) - (vop* ,name node block (refs) ((first res) nil) - (length args)) - (move-continuation-result node block res cont))))) - (frob list) - (frob list*)) - - -;;;; Structure accessors: -;;; -;;; These guys have to bizarrely determine the slot offset by looking at the -;;; called function. - -(defoptimizer (%slot-accessor ir2-convert) ((str) node block) - (let* ((cont (node-cont node)) - (res (continuation-result-tns cont (list *any-primitive-type*)))) - (vop structure-ref node block - (continuation-tn node block str) - (dsd-index - (slot-accessor-slot - (ref-leaf - (continuation-use - (combination-fun node))))) - (first res)) - (move-continuation-result node block res cont))) - -(defoptimizer (%slot-setter ir2-convert) ((str value) 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)))))) - - (move-continuation-result node block (list val) (node-cont node)))) - - -;;; IR2-Convert -- Interface -;;; -;;; Convert the code in a component into VOPs. -;;; -(defun ir2-convert (component) - (declare (type component component)) - (do-blocks (block component) - (ir2-convert-block block)) - (undefined-value)) - - -;;; Finish-IR2-Block -- Internal -;;; -;;; If necessary, emit a terminal unconditional branch to go to the -;;; successor block. When there is a deleted tail control transfer, no branch -;;; is necessary. -;;; -(defun finish-ir2-block (block) - (declare (type cblock block)) - (let* ((2block (block-info block)) - (last (block-last block)) - (succ (block-succ block))) - (unless (or (if-p last) (return-p last) - (and (null succ) - (or (node-tail-p last) - (exit-p last)))) - (assert (and succ (null (rest succ)))) - (let ((target (first succ))) - (unless (eq (ir2-block-next 2block) (block-info target)) - (vop branch last 2block (block-label target)))))) - (undefined-value)) - - -;;; IR2-Convert-Block -- Internal -;;; -;;; Convert the code in a block into VOPs. -;;; -(defun ir2-convert-block (block) - (declare (type cblock block)) - (let ((2block (block-info block))) - (do-nodes (node cont block) - (etypecase node - (ref - (let ((2cont (continuation-info cont))) - (when (and 2cont - (not (eq (ir2-continuation-kind 2cont) :delayed))) - (ir2-convert-ref node 2block)))) - (combination - (let ((kind (basic-combination-kind node))) - (case kind - (:local - (ir2-convert-local-call node 2block)) - (:full - (ir2-convert-full-call node 2block)) - (t - (let ((fun (function-info-ir2-convert kind))) - (cond (fun - (funcall fun node 2block)) - ((eq (basic-combination-info node) :full) - (ir2-convert-full-call node 2block)) - (t - (ir2-convert-template node 2block)))))))) - (cif - (when (continuation-info (if-test node)) - (ir2-convert-if node 2block))) - (bind - (let ((fun (bind-lambda node))) - (when (eq (lambda-home fun) fun) - (ir2-convert-bind node 2block)))) - (creturn - (ir2-convert-return node 2block)) - (cset - (ir2-convert-set node 2block)) - (mv-combination - (cond - ((eq (basic-combination-kind node) :local) - (ir2-convert-mv-bind node 2block)) - ((eq (continuation-function-name (basic-combination-fun node)) - '%throw) - (ir2-convert-throw node 2block)) - (t - (ir2-convert-mv-call node 2block)))) - (exit - (when (exit-entry node) - (ir2-convert-exit node 2block))) - (entry - (ir2-convert-entry node 2block))))) - - (finish-ir2-block block) - - (undefined-value)) diff --git a/compiler/knownfun.lisp b/compiler/knownfun.lisp deleted file mode 100644 index df9b9b5e371d9fe7a40f6eb6ef744e28783a2fd7..0000000000000000000000000000000000000000 --- a/compiler/knownfun.lisp +++ /dev/null @@ -1,165 +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 for maintaining a database of special -;;; information about functions known to the compiler. This includes semantic -;;; information such as side-effects and type inference functions as well as -;;; transforms and IR2 translators. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; IR1 boolean function attributes: -;;; -;;; There are a number of boolean attributes of known functions which we -;;; like to have in IR1. This information is mostly side effect information of -;;; a sort, but it is different from the kind of information we want in IR2. -;;; We aren't interested in a fine breakdown of side effects, since we do very -;;; little code motion on IR1. We are interested in some deeper semantic -;;; properties such as whether it is safe to pass stack closures to. -;;; -(def-boolean-attribute ir1 - ;; - ;; 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. - call - ;; - ;; May incorporate arguments in the result or somehow pass them upward. - unsafe - ;; - ;; May fail to return during correct execution. Errors are O.K. - unwind - ;; - ;; The (default) worst case. Includes all the other bad things, plus any - ;; other possible bad thing. If this is present, the above bad attributes - ;; will be explicitly present as well. - any - ;; - ;; May be constant-folded. The function has no side effects, but may be - ;; affected by side effects on the arguments. e.g. SVREF, MAPC. - foldable - ;; - ;; 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. - flushable - ;; - ;; May be moved with impunity. Has no side effects except possibly CONS, and - ;; is affected only by its arguments. - movable - ;; - ;; Function is a true predicate likely to be open-coded. Convert any - ;; non-conditional uses into (IF <pred> T NIL). - predicate) - - -(defstruct (function-info - (:print-function %print-function-info)) - ;; - ;; Boolean attributes of this function. - (attributes nil :type attributes) - ;; - ;; The transforms for this function. An alist of (Function-Type . Function), - ;; where Function-Type is the type that the call must have for Function to be - ;; an applicable transform. - (transforms () :type list) - ;; - ;; A function which computes the derived type for a call to this function by - ;; examining the arguments. This is null when there is no special method for - ;; this function. - (derive-type nil :type (or function null)) - ;; - ;; A function that does random unspecified code transformations by directly - ;; hacking the IR. Returns true if further optimizations of the call - ;; shouldn't be attempted. - (optimizer nil :type (or function null)) - ;; - ;; If true, a special-case LTN annotation method that is used in place of the - ;; standard type/policy template selection. It may use arbitrary code to - ;; choose a template, decide to do a full call, or conspire with the - ;; IR2-Convert method to do almost anything. The Combination node is passed - ;; as the argument. - (ltn-annotate nil :type (or function null)) - ;; - ;; If true, the special-case IR2 conversion method for this function. This - ;; deals with funny functions, and anything else that can't be handled using - ;; the template mechanism. The Combination node and the IR2-Block are passed - ;; as arguments. - (ir2-convert nil :type (or function null)) - ;; - ;; A list of all the templates that could be used to translate this function - ;; into IR2, sorted by increasing cost. - (templates nil :type list) - ;; - ;; If non-null, then this function is a unary type predicate for this type. - (predicate-type nil :type (or ctype null))) - -(defprinter function-info - (transforms :test transforms) - (derive-type :test derive-type) - (optimizer :test optimizer) - (ltn-annotate :test ltn-annotate) - (ir2-convert :test ir2-convert) - (templates :test templates) - (predicate-type :test predicate-type)) - - -;;;; Interfaces to defining macros: - -;;; %Deftransform -- Internal -;;; -;;; Grab the Function-Info and enter the function, replacing any old one -;;; with the same type. -;;; -(proclaim '(function %deftransform (t list function))) -(defun %deftransform (name type fun) - (let* ((ctype (specifier-type type)) - (info (function-info-or-lose name)) - (old (assoc ctype (function-info-transforms info) :test #'type=))) - (if old - (setf (cdr old) fun) - (push (cons ctype fun) (function-info-transforms info))) - name)) - - -;;; %Defknown -- Internal -;;; -;;; Make a function-info structure with the specified type, attributes and -;;; optimizers. -;;; -(proclaim '(function %defknown (list list attributes &key (derive-type function) - (optimizer function)))) -(defun %defknown (names type attributes &key derive-type optimizer) - (let ((ctype (specifier-type type)) - (info (make-function-info :attributes attributes -; :derive-type derive-type Until database is fixed... - :optimizer optimizer))) - (dolist (name names) - (setf (info function type name) ctype) - (setf (info function where-from name) :declared) - (setf (info function kind name) :function) - (setf (info function info name) info))) - names) - - -;;; Function-Info-Or-Lose -- Internal -;;; -;;; Return the Function-Info for name or die trying. Since this is used by -;;; people who want to modify the info, and the info may be shared, we copy it. -;;; We don't have to copy the lists, since each function that has generators or -;;; transforms has already been through here. -;;; -(proclaim '(function function-info-or-lose (t) function-info)) -(defun function-info-or-lose (name) - (let ((old (info function info name))) - (unless old (error "~S is not a known function." name)) - (setf (info function info name) (copy-function-info old)))) diff --git a/compiler/life.lisp b/compiler/life.lisp deleted file mode 100644 index b00bf1ca6b0554c5515db559192d2969eac6af92..0000000000000000000000000000000000000000 --- a/compiler/life.lisp +++ /dev/null @@ -1,810 +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 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) - - (let ((global-num (tn-number tn))) - (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))) - (when (eq kind :normal) - (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. -;;; -;;; We also set the Local and Local-Number slots in each TN. -;;; -(defun coalesce-more-ltn-numbers (block ops fixed) - (declare (type ir2-block block) (type tn-ref 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)) - (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)) - (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)) - (assert (not (find-local-references new))) - (init-global-conflict-kind new)))))))) - - (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-lambda 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: - -;;; Convert-To-Environment-TN -- Internal -;;; -;;; Convert a :Normal TN to an :Environment TN. This requires deleting the -;;; existing conflict info. -;;; -(defun convert-to-environment-tn (tn) - (declare (type tn tn)) - (assert (eq (tn-kind tn) :normal)) - (let ((confs (tn-global-conflicts tn))) - (if confs - (do ((conf confs (global-conflicts-tn-next conf))) - ((null conf)) - (let ((block (global-conflicts-block conf))) - (unless (eq (global-conflicts-kind conf) :live) - (let ((ltns (ir2-block-local-tns block)) - (num (global-conflicts-number conf))) - (assert (not (eq (svref ltns num) :more))) - (setf (svref ltns num) nil))) - (deletef-in global-conflicts-next (ir2-block-global-tns block) - conf))) - (setf (svref (ir2-block-local-tns (tn-local tn)) - (tn-local-number tn)) - nil)) - (setf (tn-local tn) nil) - (setf (tn-local-number tn) nil) - (setf (tn-global-conflicts tn) nil) - (setf (tn-kind tn) :environment) - (push tn (ir2-environment-live-tns - (environment-info - (tn-environment tn))))) - (undefined-value)) - - -;;; 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-list)) - (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 (setf (sbit live (tn-local-number tn)) 0)) - (:environment :component)))) - live)) - - -;;; 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. -;;; -;;; ### 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-bits (bit-vector-copy (ir2-block-live-in block))) - (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))) - (setf (tn-local-number tn) num) - (unless (eq (global-conflicts-kind conf) :live) - (unless (zerop (sbit live-bits num)) - (bit-vector-replace bits live-bits) - (setf (sbit bits num) 0) - (push-in tn-next* tn live-list)) - (setf (tn-local-conflicts tn) bits)))) - - (values live-bits live-list))) - - -(eval-when (compile eval) - -;;; Frob-More-TNs -- Internal -;;; -;;; Used in the guts of Conflict-Analyze-1-Block 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 return true if there where more TNs. -;;; -(defmacro frob-more-tns (action) - `(when (eq (svref ltns num) :more) - (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)) - t)) - -); 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)) - - (let ((save-p (vop-info-save-p (vop-info vop)))) - (when save-p - (let ((ss (compute-save-set vop live-bits))) - (setf (vop-save-set vop) ss) - (when (eq save-p :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)))))))) - - (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) - (when (frob-more-tns (deletef-in tn-next* live-list mtn)) - (return)))) - ((tn-ref-write-p ref) - (note-conflicts live-bits live-list tn num)) - (t - (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) - (when (frob-more-tns (push-in tn-next* mtn live-list)) - (return)))))))))) - - -;;; 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))) - - -;;; Lifetime-Analyze -- Interface -;;; -;;; -(defun lifetime-analyze (component) - (lifetime-pre-pass component) - (lifetime-flow-analysis component) - (lifetime-post-pass 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-Environment-Global -- Interface -;;; -;;; Return true if any of Y's blocks are in X's environment. -;;; -(defun tns-conflict-environment-global (x y) - (declare (type tn x y)) - (let ((env (tn-environment x))) - (do ((conf (tn-global-conflicts y) (global-conflicts-tn-next conf))) - ((null conf) - nil) - (when (eq (lambda-environment - (block-lambda - (ir2-block-block (global-conflicts-block conf)))) - env) - (return t))))) - - -;;; TNs-Conflict-Environment-Local -- Interface -;;; -;;; Return true if Y's block is in X's environment. -;;; -(defun tns-conflict-environment-local (x y) - (declare (type tn x y)) - (eq (lambda-environment - (block-lambda - (ir2-block-block (tn-local y)))) - (tn-environment x))) - - -;;; 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) - ((eq x-kind :environment) - (cond ((tn-global-conflicts y) - (tns-conflict-environment-global x y)) - ((eq (tn-kind y) :environment) - (eq (tn-environment x) (tn-environment y))) - (t - (tns-conflict-environment-local x y)))) - ((eq y-kind :environment) - (if (tn-global-conflicts x) - (tns-conflict-environment-global y x) - (tns-conflict-environment-local y x))) - ((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/loadcom.lisp b/compiler/loadcom.lisp deleted file mode 100644 index 25101d183c3d35aec1757e8e8291d3a5d26b9762..0000000000000000000000000000000000000000 --- a/compiler/loadcom.lisp +++ /dev/null @@ -1,134 +0,0 @@ -;;; -*- Package: C -*- -;;; -;;; Load up the compiler. -;;; -(in-package "C") - -#-new-compiler -(progn - (ext:gc-off) - - (load "code:fdefinition" :verbose t) - (load "c:globaldb" :verbose t) - (globaldb-init) - - (load "c:patch" :verbose t) - (load "code:macros" :verbose t) - (load "code:struct" :verbose t) - (load "c:proclaim" :verbose t) - (load "code:extensions" :verbose t) - (load "code:defmacro" :verbose t) - (load "code:sysmacs" :verbose t) - (load "code:defrecord" :verbose t) - (load "code:error" :verbose t) - (load "code:debug-info" :verbose t) - (load "code:defstruct" :verbose t) - (load "code:c-call" :verbose t) - (load "code:salterror" :verbose t) - (load "code:machdef" :verbose t) - - (load "c:boot-globaldb" :verbose t)) - -(load "c:macros" :verbose t) -(load "c:type" :verbose t) -(load "c:vm-type" :verbose t) -(load "c:type-init" :verbose t) -(load "c:sset" :verbose t) -(load "c:node" :verbose t) -(load "c:alloc" :verbose t) -(load "c:ctype" :verbose t) -(load "c:knownfun" :verbose t) -(load "c:fndb" :verbose t) -(load "c:ir1util" :verbose t) -(load "c:ir1tran" :verbose t) -(load "c:ir1final" :verbose t) -(load "c:srctran" :verbose t) -(load "c:seqtran" :verbose t) -(load "c:typetran" :verbose t) -(load "c:locall" :verbose t) -(load "c:dfo" :verbose t) -(load "c:ir1opt" :verbose t) -;(load "c:loop" :verbose t) -(load "c:checkgen" :verbose t) -(load "c:constraint" :verbose t) -(load "c:envanal" :verbose t) -(load "c:parms" :verbose t) -(load "c:vop" :verbose t) -(load "c:tn" :verbose t) -(load "c:bit-util" :verbose t) -(load "c:life" :verbose t) -(load "c:vmdef" :verbose t) -(load "c:gtn" :verbose t) -(load "c:ltn" :verbose t) -(load "c:stack" :verbose t) -(load "c:control" :verbose t) -(load "c:entry" :verbose t) -(load "c:ir2tran" :verbose t) -(load "c:pack" :verbose t) -(load "c:codegen" :verbose t) -(load "c:main" :verbose t) -(load "c:assembler" :verbose t) -(load "c:assem-insts" :verbose t) -(load "c:assem-macs" :verbose t) -(load "c:aliencomp" :verbose t) -(load "c:debug-dump" :verbose t) - -#-new-compiler -(load "code:alieneval" :verbose t) - -#+rt-target(progn -#-new-compiler -(handler-bind ((error #'(lambda (condition) - (format t "~%~A~%Continuing...~%" condition) - (continue)))) - (progn - (load "code:constants" :verbose t) - (load "assem:rompconst" :verbose t))) - -#-new-compiler -(load "c:fop" :verbose t) - -(load "c:dump" :verbose t) -#+new-compiler -(load "c:core" :verbose t) - -(load "c:vm" :verbose t) -(load "c:move" :verbose t) -(load "c:char" :verbose t) -(load "c:miscop" :verbose t) -(load "c:subprim" :verbose t) -(load "c:print" :verbose t) -(load "c:memory" :verbose t) -(load "c:cell" :verbose t) -(load "c:call" :verbose t) -(load "c:nlx" :verbose t) -(load "c:values" :verbose t) -(load "c:array" :verbose t) -(load "c:pred" :verbose t) -(load "c:system" :verbose t) -(load "c:type-vops" :verbose t) -(load "c:arith" :verbose t) -); #+RT-TARGET PROGN - -(load "c:pseudo-vops" :verbose t) -(load "c:vm-tran" :verbose t) -(load "c:debug" :verbose t) -(load "c:represent" :verbose t) - -#+new-compiler -(load "c:eval-comp" :verbose t) -#+new-compiler -(load "c:eval" :verbose t) - - -#-new-compiler -(progn - #+rt-target - (load "assem:assembler" :verbose t) - (%proclaim '(optimize (debug-info 2))) - - (setq *info-environment* - (list (make-info-environment :name "Working") - (compact-info-environment (car *info-environment*)))) - (lisp::purify :root-structures '(ncompile-file)) - (ext:gc-on)) diff --git a/compiler/locall.lisp b/compiler/locall.lisp deleted file mode 100644 index df4f1f2b24a930968667f204ff7f9b372ebcd6b7..0000000000000000000000000000000000000000 --- a/compiler/locall.lisp +++ /dev/null @@ -1,713 +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 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 modify the flow graph to -;;; represent the control transfers previously implicit in the call. This -;;; change allows us to do inter-routine flow analysis. -;;; -;;; We cannot always do a local call even when we do have the function being -;;; called. Local call can be explicitly disabled by a NOTINLINE declaration. -;;; Calls that cannot be shown to have legal arg counts are also not converted. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; Propagate-To-Args -- Internal -;;; -;;; This function propagates information from the variables in the function -;;; Fun to the actual arguments in Call. -;;; -;;; 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)) - - -;;; 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, 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. -;;; -(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 (lambda-home (block-lambda (node-block call))))) - (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 (lambda-bind fun) (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 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 ((res (ir1-convert-lambda (make-xep-lambda fun)))) - (setf (functional-kind res) :external) - (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 -;;; cannot be :Notinline, and must be the function for a call. 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. -;;; -;;; Except in the interpreter, we don't attempt to convert calls that appear -;;; in a top-level lambda unless there is only one reference. This ensures -;;; that top-level components will contain only load-time code: any references -;;; to run-time functions will be as closures. -;;; -;;; If we cannot convert a reference, then we mark the referenced function -;;; as an entry-point, creating a new XEP if necessary. -;;; -;;; 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))) - (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) - (or (null (rest refs)) - *converting-for-interpreter* - (not (eq (functional-kind - (lambda-home - (block-lambda (node-block ref)))) - :top-level)))) - (ecase (ref-inlinep ref) - ((nil :inline) - (convert-call-if-possible ref dest)) - ((:notinline))) - - (unless (eq (basic-combination-kind dest) :local) - (reference-entry-point ref))) - (t - (reference-entry-point ref)))))) - - (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. -;;; -(defun local-call-analyze (component) - (declare (type component component)) - (loop - (unless (component-new-functions component) (return)) - (let ((fun (pop (component-new-functions component)))) - (unless (eq (functional-kind fun) :deleted) - (when (lambda-p fun) - (push fun (component-lambdas component))) - (local-call-analyze-1 fun) - (when (lambda-p fun) - (maybe-let-convert fun))))) - - (undefined-value)) - - -;;; 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 already :Local, we do nothing. If the call is in the top-level -;;; component, also do nothing, since we don't want to join top-level code into -;;; normal components. -;;; -;;; 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 ((fun (let ((fun (ref-leaf ref))) - (if (external-entry-point-p fun) - (functional-entry-function fun) - fun))) - (*compiler-error-context* call)) - (cond ((eq (basic-combination-kind call) :local)) - ((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. -;;; -(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))))) - (change-ref-leaf ref ep) - (setf (basic-combination-kind call) :local) - (pushnew ep - (lambda-calls (lambda-home (block-lambda (node-block call))))) - - (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 Ref as :Notinline to remove it from future -;;; consideration. If the argcount is O.K. then we just convert it. -;;; -(proclaim '(function convert-lambda-call (ref combination lambda) void)) -(defun convert-lambda-call (ref call 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 (ref-inlinep ref) :notinline))))) - - - -;;;; 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 (ref-inlinep ref) :notinline)) - ((<= call-args max-args) - (convert-call ref call - (elt (optional-dispatch-entry-points fun) - (- call-args min-args)))) - ((not (optional-dispatch-more-entry fun)) - (compiler-warning "Function called with ~R argument~:P, but wants at most ~R." - call-args max-args) - (setf (ref-inlinep ref) :notinline)) - ((optional-dispatch-keyp fun) - (cond ((oddp (- call-args max-args)) - (compiler-warning "Function called with odd number of ~ - arguments in keyword portion.")) - (t - (convert-keyword-call ref call fun)))))) - - (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. -;;; -(proclaim '(function convert-hairy-fun-entry - (ref combination lambda list list list))) -(defun convert-hairy-fun-entry (ref call entry vars ignores args) - (let ((new-fun - (with-ir1-environment call - (ir1-convert-lambda - `(lambda ,vars - (declare (ignore . ,ignores)) - (%funcall ,entry . ,args)) - (node-source call))))) - (convert-call ref call new-fun) - (dolist (ref (leaf-refs entry)) - (convert-call-if-possible ref (continuation-dest (node-cont ref)))))) - - -;;; Convert-Keyword-Call -- Internal -;;; -;;; Use Convert-Hairy-Fun-Entry to convert a keyword call to a known -;;; functions 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. -;;; -(defun convert-keyword-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)) - (keys (nthcdr max args)) - (loser nil)) - (collect ((temps) - (ignores) - (supplied) - (key-vars)) - - (dolist (var arglist) - (let ((info (lambda-var-arg-info var))) - (when info - (ecase (arg-info-kind info) - (:rest - (setf (ref-inlinep ref) :notinline) - (return-from convert-keyword-call)) - (:keyword - (key-vars var)) - (:optional))))) - - (dotimes (i max) - (temps (gensym))) - - (do ((key keys (cddr key))) - ((null key)) - (let ((cont (first key))) - (unless (constant-continuation-p cont) - (when (policy call (or (> speed brevity) (> space brevity))) - (compiler-note "Non-constant keyword in keyword call.")) - (setf (ref-inlinep ref) :notinline) - (return-from convert-keyword-call)) - - (let ((name (continuation-value cont))) - (dolist (var (key-vars) - (let ((dummy1 (gensym)) - (dummy2 (gensym))) - (temps dummy1 dummy2) - (ignores dummy1 dummy2) - (setq loser name))) - (let ((info (lambda-var-arg-info var))) - (when (eq (arg-info-keyword info) name) - (let ((dummy (gensym)) - (temp (gensym))) - (temps dummy temp) - (ignores dummy) - (supplied (cons var temp))) - (return))))))) - - (when (and loser (not (optional-dispatch-allowp fun))) - (compiler-warning "Function called with unknown argument keyword ~S." - loser) - (setf (ref-inlinep ref) :notinline) - (return-from convert-keyword-call)) - - (collect ((call-args)) - (do ((var arglist (cdr var)) - (temp (temps) (cdr temp))) - (()) - (let ((info (lambda-var-arg-info (car var)))) - (if info - (case (arg-info-kind info) - (:optional - (call-args (car temp)) - (when (arg-info-supplied-p info) - (call-args t))) - (t - (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) - (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. - - -;;; Merge-Cleanups-And-Lets -- Internal -;;; -;;; Handle the environment semantics of let conversion. We add the lambda -;;; and its lets to lets for the call's home function and move any cleanups and -;;; calls to the 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. -;;; This must run after INSERT-LET-BODY, since the call to NODE-ENDS-BLOCK -;;; figures out the actual cleanup current at the let call (and sets the -;;; start/end cleanups accordingly.) -;;; -(defun merge-cleanups-and-lets (fun call) - (declare (type clambda fun) (type basic-combination call)) - (let* ((prev (node-prev call)) - (home (lambda-home (block-lambda (continuation-block prev)))) - (home-env (lambda-environment home))) - (push fun (lambda-lets home)) - (setf (lambda-home fun) home) - (setf (lambda-environment fun) home-env) - - (let ((cleanup (find-enclosing-cleanup - (block-end-cleanup (continuation-block prev)))) - (lets (lambda-lets fun))) - (dolist (let lets) - (setf (lambda-home let) home) - (setf (lambda-environment let) home-env)) - (when cleanup - (dolist (let lets) - (unless (lambda-cleanup let) - (setf (lambda-cleanup let) cleanup))) - (setf (lambda-cleanup fun) cleanup)) - - (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)) - - -;;; Insert-Let-Body -- Internal -;;; -;;; Handle the control semantics of let conversion. We split the call block -;;; immediately after the call, and link the head and tail of Fun to the call -;;; block and the following block. We also unlink the function head and tail -;;; from the component head and tail and flush the function from the -;;; Component-Lambdas. We set Component-Reanalyze to true to indicate that the -;;; DFO should be recomputed. -;;; -(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 ((*current-component* component)) - (node-ends-block call)) - (setf (component-lambdas component) - (delete fun (component-lambdas component))) - (assert (= (length (block-succ call-block)) 1)) - (let ((next-block (first (block-succ call-block)))) - (unlink-blocks call-block next-block) - (unlink-blocks (component-head component) bind-block) - (link-blocks call-block bind-block) - (let ((return (lambda-return fun))) - (when return - (let ((return-block (node-block return))) - (unlink-blocks return-block (component-tail component)) - (link-blocks return-block next-block))))) - (setf (component-reanalyze component) t)) - (undefined-value)) - - -;;; Move-Return-Uses -- Internal -;;; -;;; Handle the value semantics of let conversion. When Fun has a return -;;; node, we delete it and 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. -;;; -(defun move-return-uses (fun call) - (declare (type clambda fun) (type basic-combination call)) - (let ((return (lambda-return fun))) - (when return - (unlink-node return) - (delete-return return) - - (let ((result (return-result return)) - (cont (node-cont call))) - (when (eq (continuation-use cont) call) - (assert-continuation-type cont (continuation-asserted-type result))) - (delete-continuation-use call) - (add-continuation-use call (node-prev (lambda-bind fun))) - (substitute-continuation-uses cont result)))) - - (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)) - (insert-let-body fun call) - (merge-cleanups-and-lets fun call) - (move-return-uses fun call) - - (let* ((fun (or (lambda-optional-dispatch fun) fun)) - (entry (gethash (leaf-name fun) *free-functions*))) - (when (eq entry fun) - (remhash (leaf-name fun) *free-functions*))) - - (dolist (arg (basic-combination-args call)) - (when arg - (reoptimize-continuation arg))) - (reoptimize-continuation (node-cont call)) - (undefined-value)) - - -;;; 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. -;;; -;;; 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. Low-level -;;; control and environment optimizations can always be done later on. -;;; -;;; 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. -;;; -(defun maybe-let-convert (fun) - (declare (type clambda fun)) - (let ((refs (leaf-refs fun))) - (when (and refs (null (rest refs)) - (not (block-delete-p (node-block (first refs)))) - (not (functional-kind fun)) - (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)) - (let-convert fun dest) - (setf (functional-kind fun) - (if (mv-combination-p dest) :mv-let :let)))))) - (undefined-value)) diff --git a/compiler/ltn.lisp b/compiler/ltn.lisp deleted file mode 100644 index 1ef29fa9a700ab783e3440233e7c6d80d0b7add6..0000000000000000000000000000000000000000 --- a/compiler/ltn.lisp +++ /dev/null @@ -1,957 +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 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) - - -;;;; Utilities: - -;;; Translation-Policy -- Internal -;;; -;;; Return the policies keyword indicated by the node policy. -;;; -(defun translation-policy (node) - (declare (type node node)) - (let* ((cookie (node-cookie node)) - (dcookie (node-default-cookie node)) - (safety (or (cookie-safety cookie) - (cookie-safety dcookie))) - (space (max (or (cookie-space cookie) - (cookie-space dcookie)) - (or (cookie-cspeed cookie) - (cookie-cspeed dcookie)))) - (speed (or (cookie-speed cookie) - (cookie-speed dcookie)))) - (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))) - - -;;; 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 leaf) - ((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. -;;; -(defun annotate-1-value-continuation (cont) - (declare (type continuation cont)) - (let ((info (continuation-info cont))) - (assert (eq (ir2-continuation-kind info) :fixed)) - (if (continuation-delayed-leaf cont) - (setf (ir2-continuation-kind info) :delayed) - (setf (ir2-continuation-locs info) - (list (make-normal-tn (ir2-continuation-primitive-type info)))))) - (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) - (annotate-1-value-continuation cont) - (unless (policy-safe-p policy) (flush-type-check cont))) - (undefined-value)) - - -;;; Annotate-Full-Call-Continuation -- Internal -;;; -;;; Annotate a continuation that is an argument to a full call. Kind of -;;; like Annotate-Ordinary-Continuation, but we always clear the type-check -;;; flag, since it is assumed that the callee does appropriate checking. -;;; -(defun annotate-full-call-continuation (cont) - (declare (type continuation cont)) - (let ((info (or (continuation-info cont) - (setf (continuation-info cont) - (make-ir2-continuation *any-primitive-type*)))) - (leaf (continuation-delayed-leaf cont))) - (flush-type-check cont) - (setf (ir2-continuation-primitive-type info) *any-primitive-type*) - (if leaf - (setf (ir2-continuation-kind info) :delayed) - (setf (ir2-continuation-locs info) - (list (make-normal-tn *any-primitive-type*))))) - (undefined-value)) - - -;;; Annotate-Function-Continuation -- Internal -;;; -;;; Annotate the function continuation for a full call. If the only -;;; reference is to a global symbol 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. Note that in the common case of a delayed global function -;;; reference, the type checking is postponed, letting the call sequence do the -;;; type checking however it wants. -;;; -(defun annotate-function-continuation (cont policy &optional (delay t)) - (declare (type continuation cont) (type policies policy)) - (let* ((ptype (primitive-type (continuation-derived-type cont))) - (info (make-ir2-continuation ptype))) - (setf (continuation-info cont) info) - (unless (policy-safe-p policy) (flush-type-check cont)) - (let ((name (continuation-function-name cont))) - (if (and delay name (symbolp name)) - (setf (ir2-continuation-kind info) :delayed) - (setf (ir2-continuation-locs info) (list (make-normal-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 -;;; unlink the call from the return block (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 (node-tail-p 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))))) - (t - (setf (node-tail-p call) nil))))) - (undefined-value)) - - -;;; LTN-Default-Call -- Internal -;;; -;;; Set up stuff to do a full call for Call. We assume that that -;;; IR2-Continuation structures have already been assigned to the args. 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) - (dolist (arg (basic-combination-args call)) - (annotate-full-call-continuation 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 - (setf (basic-combination-info call) :full) - (flush-full-call-tail-transfer call)))) - - (undefined-value)) - - -;;; 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 () - (make-n-tns 2 *any-primitive-type*)) - - -;;; 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, to be kept in -;;; the list of TNs Locs. -;;; -(defun annotate-fixed-values-continuation (cont policy locs) - (declare (type continuation cont) (type policies policy) (list locs)) - (unless (policy-safe-p policy) (flush-type-check cont)) - - (let ((res (make-ir2-continuation nil))) - (setf (ir2-continuation-locs res) locs) - (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 kind is :Fixed, and the function being returned from isn't an -;;; XEP, then we allocate a fixed number of locations to compute the function -;;; result in. -;;; -;;; Otherwise, we are going to use the unknown return convention. We still -;;; try to annotate for a fixed number of values: -;;; -- 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, 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))) - (cond - ((and (eq (return-info-kind returns) :fixed) - (not (external-entry-point-p fun))) - (annotate-fixed-values-continuation cont policy - (mapcar #'make-normal-tn types))) - ((not (eq (return-info-count returns) :unknown)) - (annotate-fixed-values-continuation - cont policy - (make-n-tns (return-info-count returns) *any-primitive-type*))) - (t - (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)))) - - (multiple-value-bind (types kind) - (values-types (res)) - (if (eq kind :unknown) - (annotate-unknown-values-continuation cont policy) - (annotate-fixed-values-continuation - cont policy - (mapcar #'(lambda (x) - (make-normal-tn (primitive-type x))) - 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) - (make-normal-tn - (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 a -;;; tail call, swing the successor link to the start of the called function so -;;; that the return can be deleted. -;;; -(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) - (node-ends-block call) - (let ((block (node-block call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block - (node-block (lambda-bind (combination-lambda call)))))) - - (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 -- Internal -;;; -(proclaim '(inline operand-restriction-ok)) -(defun operand-restriction-ok (restr type &optional cont) - (declare (type (or (member *) cons) restr) - (type primitive-type type) - (type (or continuation null) cont)) - (if (eq restr '*) - t - (ecase (first restr) - (:or - (dolist (mem (rest restr) nil) - (when (eq mem type) (return t)))) - (:constant - (funcall (second restr) (continuation-value cont)))))) - - -;;; 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) 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)) - (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 - (let ((mtype (template-more-args-type template))) - (or (not mtype) - (operand-restriction-ok mtype (primitive-type result-type)))))))) - - -;;; 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. -;;; -;;; What we do: -;;; -- 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. -;;; -- We accept a template if the Node-Derived-Type satisfies the -;;; output assertion, since this type has been proven to be statisfied. -;;; -- Unless the policy is safe and the template is :Fast-Safe, we also accept -;;; a template when the continuation derived type satisfies the output -;;; assertion. We only attempt this when TYPE-CHECK is non-null, since when -;;; this is NIL, the assertion is a supertype of the node type. -;;; -(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)) - (guard (template-guard template))) - (when (and (or (not guard) (funcall guard)) - (template-args-ok template call safe-p)) - (let* ((cont (node-cont call)) - (atype (continuation-asserted-type cont)) - (dtype (node-derived-type call))) - (when (if (eq (template-result-types template) :conditional) - (let ((dest (continuation-dest cont))) - (and (if-p dest) - (immediately-used-p (if-test dest) call))) - (or (template-results-ok template dtype) - (and (or (not (eq (template-policy template) - :fast-safe)) - (not safe-p)) - (continuation-type-check cont) - (template-results-ok template - (values-type-intersection - dtype atype))))) - (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 rejected a template and Speed > Brevity, then we call -;;; Note-Rejected-Templates to emit any appropriate efficiency notes. -;;; -(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))) - (fallback) - ((or (not safe-p) (policy-safe-p tpolicy)) - (setq fallback template))))))))) - - -;;; 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))) - (dolist (try (function-info-templates (basic-combination-kind call))) - (when (eq try template) (return)) - (let ((guard (template-guard try))) - (when (and (template-note try) - (or (not guard) (funcall guard)) - (or (not safe-p) - (policy-safe-p (template-policy try))) - (valid-function-use - call (template-type try) - :argument-test #'types-intersect - :result-test #'values-types-intersect)) - (losers try))))) - - (when (losers) - (collect ((messages)) - (flet ((frob (string &rest stuff) - (messages string) - (messages stuff))) - (dolist (loser (losers)) - (let* ((type (template-type loser)) - (valid (valid-function-use call type)) - (strict-valid (valid-function-use call type - :strict-result t))) - (when (or (not valid) (not strict-valid)) - (frob "Unable to do ~A (cost ~D) because:" - (template-note loser) (template-cost loser))) - - (cond ((not valid) - (valid-function-use call type - :error-function #'frob - :warning-function #'frob)) - ((not strict-valid) - (assert (policy-safe-p policy)) - (frob "Can't trust output type assertion under safe ~ - policy.")))))) - - (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 type checks, but we must make the -;;; continuation type be *any-primitive-type* so that objects of the incorrect -;;; type can be represented. -;;; -(defun flush-type-checks-according-to-policy (call policy template) - (declare (type combination call) (type policies policy) - (type template template)) - (if (policy-safe-p policy) - (when (eq (template-policy template) :safe) - (dolist (arg (basic-combination-args call)) - (when (continuation-type-check arg) - (flush-type-check arg) - (setf (ir2-continuation-primitive-type (continuation-info arg)) - *any-primitive-type*)))) - (dolist (arg (basic-combination-args call)) - (flush-type-check arg))) - (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)))) - (not (function-info-ir2-convert - (basic-combination-kind call)))) - (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 (and (eq (node-cookie node) cookie) - (eq (node-default-cookie node) default-cookie)) - (setq policy (translation-policy node)) - (setq cookie (node-cookie node)) - (setq default-cookie (node-default-cookie node))) - - (etypecase node - (ref) - (combination - (case (basic-combination-kind node) - (:local (ltn-analyze-local-call node policy)) - (:full (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 (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)) - (cookie nil) - default-cookie 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 ((cookie nil) - default-cookie policy) - (ltn-analyze-block-macro)) - - (assert (not (ir2-block-popped (block-info block)))) - (undefined-value)) diff --git a/compiler/macros.lisp b/compiler/macros.lisp deleted file mode 100644 index ca793e2f3a78f8c310ab074e26c79703905bfaa8..0000000000000000000000000000000000000000 --- a/compiler/macros.lisp +++ /dev/null @@ -1,1146 +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). -;;; ********************************************************************** -;;; -;;; Random types and macros used in writing the compiler. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(export '(lisp::with-compilation-unit) "LISP") - -(proclaim '(special *wild-type* *universal-type* *compiler-error-context*)) - - -;;; Undefined-Value -- Public -;;; -;;; This is here until we figure out what to do with it. -;;; -(proclaim '(inline undefined-value)) -(eval-when (#-new-compiler compile load eval) -(defun undefined-value () - '%undefined%) -); - -;;;; 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 *current-cookie* *default-cookie*)) - -(eval-when (#-new-compiler 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-current (gensym)) - (n-default (gensym)) - (binds (mapcar - #'(lambda (name) - (let ((slot (cdr (assoc name policy-parameter-slots)))) - `(,name (or (,slot ,n-current) (,slot ,n-default))))) - (find-used-parameters form)))) - (if node - (let ((n-node (gensym))) - `(let* ((,n-node ,node) - (,n-default (node-default-cookie ,n-node)) - (,n-current (node-cookie ,n-node)) - ,@binds) - ,form)) - `(let* ((,n-default *default-cookie*) - (,n-current *current-cookie*) - ,@binds) - ,form)))) - - -;;;; Source-hacking defining forms: - -(eval-when (#-new-compiler 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) - - -;;; 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 - :error-string "Wrong number of arguments to special form ~S: ~D." - :doc-string-allowed t - :environment n-env) - `(progn - (proclaim '(function ,fn-name (continuation continuation t) void)) - (defun ,fn-name (,start-var ,cont-var ,n-form) - (let ((,n-env *fenv*)) - ,@decls - (macrolet ((error (&rest args) - `(compiler-error ,@args))) - ,body))) - ,@(when doc - `((setf (documentation ',name 'function) ,doc))) - (setf (info function ir1-convert ',name) #',fn-name) - (setf (info function kind ',name) ,kind))))) - - -;;; 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 - :error-string "Foo!" - :environment n-env) - `(progn - (defun ,fn-name (,n-form) - (let ((,n-env *fenv*)) - ,@decls - (macrolet ((error (&rest stuff) - (declare (ignore stuff)) - `(return-from ,',fn-name (values nil t)))) - ,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 - :error-string "Wrong number of arguments to primitive ~S: ~D." - :environment n-env) - `(progn - (defun ,fn-name (,n-form) - (let ((,n-env *fenv*)) - ,@decls - (macrolet ((error (&rest args) - `(compiler-error ,@args))) - ,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 (#-new-compiler compile load eval) - -;;; Parse-Lambda-List -- Interface -;;; -;;; Break a lambda-list into its component parts. We return eight values: -;;; 1] A list of the required args. -;;; 2] A list of the optional arg specs. -;;; 3] True if a rest arg was specified. -;;; 4] The rest arg. -;;; 5] A boolean indicating whether keywords args are present. -;;; 6] A list of the keyword arg specs. -;;; 7] True if &allow-other-keys was specified. -;;; 8] A list of the &aux specifiers. -;;; -;;; The top-level lambda-list syntax is checked for validity, but the arg -;;; specifiers are just passed through untouched. If something is wrong, we -;;; use Compiler-Error, aborting compilation to the last recovery point. -;;; -;;; [Eventually this should go into the code sources, since it is used in -;;; various random places such as the function type parsing.] -;;; -(proclaim '(function parse-lambda-list (list) - (values list list boolean t boolean list boolean list))) -(defun parse-lambda-list (list) - (collect ((required) - (optional) - (keys) - (aux)) - (let ((restp nil) - (rest nil) - (keyp nil) - (allowp nil) - (state :required)) - (dolist (arg list) - (if (and (symbolp arg) - (let ((name (symbol-name arg))) - (and (/= (length name) 0) - (char= (char name 0) #\&)))) - (case arg - (&optional - (unless (eq state :required) - (compiler-error "Misplaced &optional in lambda-list: ~S." list)) - (setq state '&optional)) - (&rest - (unless (member state '(:required &optional)) - (compiler-error "Misplaced &rest in lambda-list: ~S." list)) - (setq state '&rest)) - (&key - (unless (member state '(:required &optional :post-rest)) - (compiler-error "Misplaced &key in lambda-list: ~S." list)) - (setq keyp t) - (setq state '&key)) - (&allow-other-keys - (unless (eq state '&key) - (compiler-error "Misplaced &allow-other-keys in lambda-list: ~S." list)) - (setq allowp t state '&allow-other-keys)) - (&aux - (when (eq state '&rest) - (compiler-error "Misplaced &aux in lambda-list: ~S." list)) - (setq state '&aux)) - (t - (compiler-error "Unknown &keyword in lambda-list: ~S." arg))) - (case state - (:required (required arg)) - (&optional (optional arg)) - (&rest - (setq restp t rest arg state :post-rest)) - (&key (keys arg)) - (&aux (aux arg)) - (t - (compiler-error "Found garbage in lambda-list when expecting a keyword: ~S." arg))))) - (values (required) (optional) restp rest keyp (keys) allowp (aux))))) - - -;;; 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) - &body body) - "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*) - Declaration* 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. - - 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. - :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." - - (let ((n-args (gensym)) - (n-node (or node (gensym))) - (n-decls (gensym)) - (n-lambda (gensym))) - (multiple-value-bind (parsed-form vars) - (parse-deftransform - lambda-list - (if policy - `(progn - (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 ,@stuff) - `(%deftransform - ',name - '(function ,arg-types ,result-type) - #'(lambda ,@stuff))))))) - -;;;; 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. -;;; -(defmacro do-nodes ((node-var cont-var block &optional result) &body body) - "Do-Nodes (Node-Var Cont-Var Block [Result]) {Declaration}* {Form}* - Iterate over the nodes in Block, binding Node-Var to the each node and - Cont-Var to the node's Cont." - (let ((n-block (gensym)) - (n-last-cont (gensym))) - `(let* ((,n-block ,block) - (,n-last-cont (node-cont (block-last ,n-block)))) - (do* ((,node-var (continuation-next (block-start ,n-block)) - (continuation-next ,cont-var)) - (,cont-var (node-cont ,node-var) (node-cont ,node-var))) - (()) - ,@body - (when (eq ,cont-var ,n-last-cont) - (return ,result)))))) -;;; -(defmacro do-nodes-backwards ((node-var cont-var block &optional result) - &body body) - "Do-Nodes-Backwards (Node-Var Cont-Var Block [Result]) {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 ,result)))))) - - -;;; 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. - - Care must be taken to ensure that blocks have the correct cleanup. New - blocks will initially be created with the End-Cleanup of Node's block. This - is not an issue if newly created blocks are inside a new function -- it is - only a problem if IR1 convert or Make-Block is called directly, and not if - IR1-Convert-Lambda is called." - (let ((n-node (gensym)) - (n-block (gensym)) - (n-cont (gensym)) - (n-component (gensym))) - `(let* ((,n-node ,node) - (,n-cont (node-prev ,n-node)) - (,n-block (continuation-block ,n-cont)) - (,n-component (block-component ,n-block)) - (*current-cleanup* (block-end-cleanup ,n-block)) - (*current-cookie* (node-cookie ,n-node)) - (*default-cookie* (node-default-cookie ,n-node)) - (*current-lambda* (block-lambda ,n-block)) - (*current-component* ,n-component) - (*current-path* (node-source-path ,n-node)) - (*current-form* nil) - (*fenv* ()) - (*inlines* ()) - (*type-restrictions* ()) - (*venv* ()) - (*benv* ()) - (*tenv* ())) - ,@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)) - - -;;;; 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 fixnum) void) - defprinter-prin1 defprinter-princ)) -(defun defprinter-prin1 (name value stream indent) - (if *defprint-pretty* - (format stream "~&~VT ~A:~%~VT ~S" indent name indent value) - (format stream " ~A= ~S" name value))) -;;; -(defun defprinter-princ (name value stream indent) - (if *defprint-pretty* - (format stream "~&~VT ~A:~%~VT ~A" indent name indent value) - (format stream " ~A= ~A" name value))) - -;;; Start-Defprinter, Finish-Defprinter -- Internal -;;; -;;; Start and finish the the printing of a defprinter function. -;;; -(proclaim '(ftype (function (symbol stream fixnum t) void) - start-defprinter finish-defprinter)) -(defun start-defprinter (name stream indent object) - (declare (ignore indent)) - (format stream "#<~S ~X" name (system:%primitive make-fixnum object))) -;;; -(defun finish-defprinter (name stream indent) - (declare (ignore name)) - (if *defprint-pretty* - (format stream ">~%~VT" indent) - (format 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." - - (let ((n-indent (gensym))) - (flet ((sref (slot) `(,(symbolicate name "-" slot) structure))) - (collect ((prints)) - (dolist (slot slots) - (if (atom slot) - (prints `(defprinter-prin1 ',slot ,(sref slot) stream ,n-indent)) - (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 ,n-indent))))))) - (case (first option) - (:prin1 - (stuff `(defprinter-prin1 ',sname ,(second option) - stream ,n-indent))) - (:princ - (stuff `(defprinter-princ ',sname ,(second option) - stream ,n-indent))) - (:test (setq test (second option))) - (t - (error "Losing Defprinter option: ~S." (first option))))))))) - - `(defun ,(symbolicate "%PRINT-" name) (structure stream depth) - (let ((,n-indent (lisp::charpos stream))) - (start-defprinter ',name stream ,n-indent structure) - (let ((*print-level* (if *print-level* (- *print-level* depth 1)))) - (unless (and *print-level* (<= *print-level* 0)) - ,@(prints)) - (finish-defprinter ',name stream ,n-indent) - 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 (#-new-compiler 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. - - NAME-attributes attribute-name* - Return a set of the named attributes." - - (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))) - (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 ,(symbolicate name "-ATTRIBUTEP") - (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))) - - (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 (#-new-compiler compile load eval) - -(defstruct event-info - ;; - ;; The name of this event. - (name nil :type symbol) - ;; - ;; The string rescribing this event. - (description nil :type string) - ;; - ;; The name of the variable we stash this in. - (var nil :type symbol) - ;; - ;; The number of times this event has happened. - (count 0 :type fixnum) - ;; - ;; The level of significance of this event. - (level nil :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/main.lisp b/compiler/main.lisp deleted file mode 100644 index 9ff98a76fee5b62500f0785b8dec689a635d36eb..0000000000000000000000000000000000000000 --- a/compiler/main.lisp +++ /dev/null @@ -1,1256 +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 top-level interfaces to the compiler. -;;; -;;; Written by Rob MacLachlan -;;; -(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* *sb-list* - *undefined-warnings* *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* *fenv*)) - -(defparameter compiler-version "0.0") - -(defvar *check-consistency* t) -(defvar *all-components*) - -;;; The value of the :Block-Compile argument that Compile-File was called with. -;;; -(defvar *block-compile*) - -;;; When block compiling, used by PROCESS-FORM to accumulate top-level lambdas -;;; resulting from compiling subforms. (In reverse order.) -;;; -(defvar *top-level-lambdas*) - -;;; Used to control compiler verbosity. -;;; -(defvar *compile-verbose* nil) - -;;; The values of *Package* and *Default-Cookie* when compilation started. -;;; -(defvar *initial-package*) -(defvar *initial-cookie*) - -;;; The source-info structure for the current compilation. This is null -;;; globally to indicate that we aren't currently in any identifiable -;;; compilation. -;;; -(defvar *source-info* nil) - - -;;; Maybe-Mumble -- Internal -;;; -;;; Mumble conditional on *Compile-Verbose*. -;;; -(defun maybe-mumble (&rest foo) - (when *compile-verbose* - (apply #'compiler-mumble foo))) - -(deftype object () '(or fasl-file core-object null)) - - -;;;; Component compilation: - -(defparameter max-optimize-iterations 3 - "The upper limit on the number of times that we will consecutively do IR1 - optimization that doesn't introduce any new code. A finite limit is - necessary, since type inference may take arbitrarily long to converge.") - -(defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called.") -(defevent ir1-optimize-maxed-out "Hit MAX-OPTIMIZE-ITERATIONS limit.") - -;;; IR1-Optimize-Until-Done -- Internal -;;; -;;; Repeatedly optimize Component until no further optimizations can be -;;; found or we hit our iteration limit. When we hit the limit, we clear the -;;; component and block REOPTIMIZE flags to discourage following the next -;;; optimization attempt from pounding on the same code. -;;; -(defun ir1-optimize-until-done (component) - (declare (type component component)) - (maybe-mumble "Opt") - (event ir1-optimize-until-done) - (let ((count 0) - (cleared-reanalyze nil)) - (loop - (when (component-reanalyze component) - (setq count 0) - (setq cleared-reanalyze t) - (setf (component-reanalyze component) nil)) - (setf (component-reoptimize component) nil) - (ir1-optimize component) - (unless (component-reoptimize component) - (maybe-mumble " ") - (return)) - (incf count) - (when (= count max-optimize-iterations) - (event ir1-optimize-maxed-out) - (maybe-mumble "* ") - (setf (component-reoptimize component) nil) - (do-blocks (block component) - (setf (block-reoptimize block) nil)) - (return)) - (maybe-mumble ".")) - (when cleared-reanalyze - (setf (component-reanalyze component) t))) - (undefined-value)) - -(defparameter *constraint-propagate* t) -(defparameter *reoptimize-after-type-check-max* 5) - -(defevent reoptimize-maxed-out - "*REOPTIMIZE-AFTER-TYPE-CHECK-MAX* exceeded.") - -;;; IR1-Phases -- Internal -;;; -;;; Do all the IR1 phases for a non-top-level component. -;;; -(defun ir1-phases (component) - (declare (type component component)) - (let ((*constraint-number* 0) - (loop-count 1)) - (declare (special *constraint-number*)) - (loop - (ir1-optimize-until-done component) - (when (component-reanalyze component) - (maybe-mumble "DFO ") - (find-dfo component)) - (when *constraint-propagate* - (maybe-mumble "Constraint ") - (constraint-propagate component)) - (maybe-mumble "Type ") - (generate-type-checks component) - (unless (or (component-reoptimize component) - (component-reanalyze component)) - (return)) - (when (>= loop-count *reoptimize-after-type-check-max*) - (maybe-mumble "[Reoptimize Limit]") - (event reoptimize-maxed-out) - (return)) - (incf loop-count))) - (undefined-value)) - - -;;; Compile-Component -- Internal -;;; -(defun compile-component (component object) - (compiler-mumble "Compiling ~A: " (component-name component)) - - (ir1-phases component) - - #| - (maybe-mumble "Dom ") - (find-dominators component) - (maybe-mumble "Loop ") - (loop-analyze component) - |# - - (let ((*compile-component* component)) - (maybe-mumble "Env ") - (environment-analyze component) - (maybe-mumble "GTN ") - (gtn-analyze component) - (maybe-mumble "LTN ") - (ltn-analyze component) - (maybe-mumble "Control ") - (control-analyze component) - - (when (ir2-component-values-receivers (component-info component)) - (maybe-mumble "Stack ") - (stack-analyze component)) - - ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by environment - ;; or stack analysis. There shouldn't be any unreachable code after - ;; control, so this won't delete anything. - (when (component-reanalyze component) - (find-dfo component)) - - (maybe-mumble "IR2Tran ") - (init-assembler) - (entry-analyze component) - (ir2-convert component) - - (select-representations component) - - (when *check-consistency* - (maybe-mumble "Check2 ") - (check-ir2-consistency component)) - - (maybe-mumble "Life ") - (lifetime-analyze component) - - (when *compile-verbose* - (compiler-mumble "") ; Sync before doing random output. - (pre-pack-tn-stats component *compiler-error-output*)) - - (delete-unreferenced-tns component) - - (when *check-consistency* - (maybe-mumble "CheckL ") - (check-life-consistency component)) - - (maybe-mumble "Pack ") - (pack component) - - (when *compiler-trace-output* - (describe-component component *compiler-trace-output*)) - - (maybe-mumble "Code ") - (generate-code component)) - - (etypecase object - (fasl-file - (maybe-mumble "FASL") - (fasl-dump-component component *code-vector* *next-location* - *assembler-nodes* (1+ *current-assembler-node*) - *result-fixups* object)) - (core-object - (maybe-mumble "Core" - (make-core-component component *code-vector* *next-location* - *assembler-nodes* (1+ *current-assembler-node*) - *result-fixups* object))) - (null)) - - (compiler-mumble "~%") - (undefined-value)) - - -;;;; Clearing global data structures: - -;;; CLEAR-IR2-INFO -- Internal -;;; -;;; Clear all the INFO slots in sight in Component to allow the IR2 data -;;; structures to be reclaimed. We also clear the INFO in constants in the -;;; *FREE-VARIABLES*, etc. The latter is required for correct assignment of -;;; costant TNs, in addition to allowing stuff to be reclaimed. -;;; -;;; We don't clear the FUNCTIONAL-INFO slots, since they are used to keep -;;; track of functions across component boundaries. -;;; -(defun clear-ir2-info (component) - (declare (type component component)) - (nuke-ir2-component component) - (setf (component-info component) nil) - - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (leaf-info v) nil)) - *constants*) - - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (constant-p v) - (setf (leaf-info v) nil))) - *free-variables*) - - (undefined-value)) - - -;;; CLEAR-STUFF -- Interface -;;; -;;; Clear all the global variables used by the compiler. -;;; -(defun clear-stuff (&optional (debug-too t)) - ;; - ;; Clear global tables. - (clrhash *free-functions*) - (clrhash *free-variables*) - (clrhash *constants*) - (clrhash *failed-optimizations*) - ;; - ;; Clear debug counters and tables. - (clrhash *seen-blocks*) - (clrhash *seen-functions*) - (clrhash *list-conflicts-table*) - - (when debug-too - (clrhash *continuation-numbers*) - (clrhash *number-continuations*) - (setq *continuation-number* 0) - (clrhash *tn-ids*) - (clrhash *id-tns*) - (setq *tn-id* 0) - (clrhash *label-ids*) - (clrhash *id-labels*) - (setq *label-id* 0)) - ;; - ;; Clear some Pack data structures (for GC purposes only.) - (dolist (sb *sb-list*) - (when (finite-sb-p sb) - (fill (finite-sb-live-tns sb) nil))) - ;; - ;; Reset Gensym. - (setq lisp:*gensym-counter* 0) - - (values)) - - -;;; PRINT-SUMMARY -- Interface -;;; -;;; This function is called by WITH-COMPILATION-UNIT at the end of a -;;; compilation unit. It prints out any residual unknown function warnings and -;;; the total error counts. Abort-P should be true when the compilation unit -;;; was aborted by throwing out. Abort-Count is the number of dynamically -;;; enclosed nested compilation units that were aborted. -;;; -(defun print-summary (abort-p abort-count) - (unless abort-p - (let ((undefs (sort *undefined-warnings* #'string< - :key #'(lambda (x) - (let ((x (undefined-warning-name x))) - (if (symbolp x) - (symbol-name x) - (prin1-to-string x))))))) - (dolist (undef undefs) - (let ((name (undefined-warning-name undef)) - (kind (undefined-warning-kind undef)) - (warnings (undefined-warning-warnings undef)) - (count (undefined-warning-count undef))) - (dolist (*compiler-error-context* warnings) - (compiler-warning "Undefined ~(~A~): ~S" kind name)) - - (let ((warn-count (length warnings))) - (when (and warnings (> count warn-count)) - (let ((more (- count warn-count))) - (compiler-warning "~D more use~P of undefined ~(~A~) ~S." - more warnings more kind name)))))) - - (dolist (kind '(:variable :function :type)) - (let ((summary (mapcar #'undefined-warning-name - (remove kind undefs :test-not #'eq - :key #'undefined-warning-kind)))) - (when summary - (compiler-warning - "Undefined ~(~A~) summary:~% ~{~<~% ~1:;~S~>~^ ~}" - kind summary)))))) - - (unless (and (not abort-p) (zerop abort-count) - (zerop *compiler-error-count*) - (zerop *compiler-warning-count*) - (zerop *compiler-note-count*)) - (compiler-mumble - "~2&Compilation unit ~:[finished~;aborted~].~ - ~[~:;~:*~& ~D fatal error~:P~]~ - ~[~:;~:*~& ~D error~:P~]~ - ~[~:;~:*~& ~D warning~:P~]~ - ~[~:;~:*~& ~D note~:P~]~2%" - abort-p - abort-count - *compiler-error-count* - *compiler-warning-count* - *compiler-note-count*))) - - -;;; Describe-Component -- Internal -;;; -;;; Print out some useful info about Component to Stream. -;;; -(defun describe-component (component &optional - (*standard-output* *standard-output*)) - (declare (type component component) (type stream stream)) - (format t "~|~%;;;; Component: ~S~2%" (component-name component)) - (print-blocks component) - - (format t "~%~|~%;;;; IR2 component: ~S~2%" (component-name component)) - - (format t "Entries:~%") - (dolist (entry (ir2-component-entries (component-info component))) - (format t "~4TL~D: ~S~:[~; [Closure]~]~%" - (label-id (entry-info-offset entry)) - (entry-info-name entry) - (entry-info-closure-p entry))) - - (terpri) - (pre-pack-tn-stats component *standard-output*) - (terpri) - (print-ir2-blocks component) - (terpri) - - (undefined-value)) - - -;;;; File reading: -;;; -;;; When reading from a file, we have to keep track of some source -;;; information. We also exploit our ability to back up for printing the error -;;; context and for recovering from errors. -;;; -;;; The interface we provide to this stuff is the stream-oid Source-Info -;;; structure. The bookkeeping is done as a side-effect of getting the next -;;; source form. - - -;;; The File-Info structure holds all the source information for a given file. -;;; -(defstruct file-info - ;; - ;; If a file, the truename of the corresponding source file. If from a Lisp - ;; form, :LISP, if from a stream, :STREAM. - (name nil :type (or pathname (member :lisp :stream))) - ;; - ;; The file's write date (if relevant.) - (write-date nil :type (or unsigned-byte null)) - ;; - ;; This file's FILE-COMMENT, or NIL if none. - (comment nil :type (or simple-string null)) - ;; - ;; The source path root number of the first form in this file (i.e. the - ;; total number of forms converted previously in this compilation.) - (source-root 0 :type unsigned-byte) - ;; - ;; Parallel vectors containing the forms read out of the file and the file - ;; positions that reading of each form started at (i.e. the end of the - ;; previous form.) - (forms (make-array 10 :fill-pointer 0 :adjustable t) (vector t)) - (positions (make-array 10 :fill-pointer 0 :adjustable t) (vector t))) - - -;;; The Source-Info structure provides a handle on all the source information -;;; for an entire compilation. -;;; -(defstruct (source-info - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (format stream "#<Source-Info>")))) - ;; - ;; The UT that compilation started at. - (start-time (get-universal-time) :type unsigned-byte) - ;; - ;; A list of the file-info structures for this compilation. - (files nil :type list) - ;; - ;; The tail of the Files for the file we are currently reading. - (current-file nil :type list) - ;; - ;; The stream that we are using to read the Current-File. Null if no stream - ;; has been opened yet. - (stream nil :type (or stream null))) - - -;;; Make-File-Source-Info -- Internal -;;; -;;; Given a list of pathnames, return a Source-Info structure. -;;; -(defun make-file-source-info (files) - (declare (list files)) - (let ((file-info - (mapcar #'(lambda (x) - (make-file-info :name x - :write-date (file-write-date x))) - files))) - - (make-source-info :files file-info - :current-file file-info))) - - -;;; MAKE-LISP-SOURCE-INFO -- Interface -;;; -;;; Return a SOURCE-INFO to describe the incremental compilation of Form. -;;; Also used by EVAL:INTERNAL-EVAL. -;;; -(defun make-lisp-source-info (form) - (make-source-info - :start-time (get-universal-time) - :files (list (make-file-info :name :lisp - :forms (vector form) - :positions '#(0))))) - - -;;; MAKE-STREAM-SOURCE-INFO -- Internal -;;; -;;; Return a SOURCE-INFO which will read from Stream. -;;; -(defun make-stream-source-info (stream) - (let ((files (list (make-file-info :name :stream)))) - (make-source-info - :files files - :current-file files - :stream stream))) - - -;;; Normal-Read-Error -- Internal -;;; -;;; Print an error message for a non-EOF error on Stream. Old-Pos is a -;;; preceding file position that hopefully comes before the beginning of the -;;; line. Of course, this only works on streams that support the file-position -;;; operation. -;;; -(defun normal-read-error (stream old-pos condition) - (declare (type stream stream) (type unsigned-byte old-pos pos)) - (let ((pos (file-position stream))) - (file-position stream old-pos) - (let ((start old-pos)) - (loop - (let ((line (read-line stream nil)) - (end (file-position stream))) - (when (>= end pos) - (compiler-error-message - "Read error at ~D:~% \"~A/\\~A\"~%~A" - pos - (string-left-trim " " - (subseq line 0 (- pos start))) - (subseq line (- pos start)) - condition) - (return)) - (setq start end))))) - (undefined-value)) - - -;;; Ignore-Error-Form -- Internal -;;; -;;; Back Stream up to the position Pos, then read a form with -;;; *Read-Suppress* on, discarding the result. If an error happens during this -;;; read, then bail out using Compiler-Error (fatal in this context). -;;; -(defun ignore-error-form (stream pos) - (declare (type stream stream) (type unsigned-byte pos)) - (file-position stream pos) - (handler-case (let ((*read-suppress* t)) - (read stream)) - (error (condition) - (declare (ignore condition)) - (compiler-error "Unable to recover from read error.")))) - - -;;; Unexpected-EOF-Error -- Internal -;;; -;;; Print an error message giving some context for an EOF error. We print -;;; the first line after Pos that contains #\" or #\(, or lacking that, the -;;; first non-empty line. -;;; -(defun unexpected-eof-error (stream pos condition) - (declare (type stream stream) (type unsigned-byte pos)) - (let ((res nil)) - (file-position stream pos) - (loop - (let ((line (read-line stream nil nil))) - (unless line (return)) - (when (or (find #\" line) (find #\( line)) - (setq res line) - (return)) - (unless (or res (zerop (length line))) - (setq res line)))) - - (compiler-error-message - "Read error in form starting at ~D:~%~@[ \"~A\"~%~]~A" - pos res condition)) - - (file-position stream (file-length stream)) - (undefined-value)) - - -;;; Careful-Read -- Internal -;;; -;;; Read a form from Stream, returning EOF at EOF. If a read error happens, -;;; then attempt to recover if possible, returing a proxy error form. -;;; -(defun careful-read (stream eof pos) - (handler-case (read stream nil eof) - (error (condition) - (let ((new-pos (file-position stream))) - (cond ((= new-pos (file-length stream)) - (unexpected-eof-error stream pos condition)) - (t - (normal-read-error stream pos condition) - (ignore-error-form stream pos)))) - '(error "Attempt to load a file having a compile-time read error.")))) - - -;;; Get-Source-Stream -- Internal -;;; -;;; If Stream is present, return it, otherwise open a stream to the current -;;; file. There must be a current file. When we open a new file, we also -;;; reset *Package* and *Default-Cookie*. This gives the effect of rebinding -;;; around each file. -;;; -(defun get-source-stream (info) - (declare (type source-info info)) - (cond ((source-info-stream info)) - (t - (setq *package* *initial-package*) - (setq *default-cookie* (copy-cookie *initial-cookie*)) - (setf (source-info-stream info) - (open (file-info-name (first (source-info-current-file info))) - :direction :input))))) - - -;;; CLOSE-SOURCE-INFO -- Internal -;;; -;;; Close the stream in Info if it is open. -;;; -(defun close-source-info (info) - (declare (type source-info info)) - (let ((stream (source-info-stream info))) - (when stream (close stream))) - (setf (source-info-stream info) nil) - (undefined-value)) - - -;;; Advance-Source-File -- Internal -;;; -;;; Advance Info to the next source file. If none, return NIL, otherwise T. -;;; -(defun advance-source-file (info) - (declare (type source-info info)) - (close-source-info info) - (let ((prev (pop (source-info-current-file info)))) - (if (source-info-current-file info) - (let ((current (first (source-info-current-file info)))) - (setf (file-info-source-root current) - (+ (file-info-source-root prev) - (length (file-info-forms prev)))) - t) - nil))) - - -;;; Read-Source-Form -- Internal -;;; -;;; Read the next form from the source designated by Info. The second value -;;; is the top-level form number of the read form. The third value is true -;;; when at EOF. -;;; -;;; We carefully read from the current source file. If it is at EOF, we -;;; advance to the next file and try again. When we get a form, we enter it -;;; into the per-file Forms and Positions vectors. -;;; -(defun read-source-form (info) - (declare (type source-info info)) - (let ((eof '(*eof*))) - (loop - (let* ((file (first (source-info-current-file info))) - (stream (get-source-stream info)) - (pos (file-position stream)) - (res (careful-read stream eof pos))) - (unless (eq res eof) - (let* ((forms (file-info-forms file)) - (current-idx (+ (fill-pointer forms) - (file-info-source-root file)))) - (vector-push-extend res forms) - (vector-push-extend pos (file-info-positions file)) - (return (values res current-idx nil)))) - - (unless (advance-source-file info) - (return (values nil nil t))))))) - - -;;; Find-Source-Root -- Interface -;;; -;;; Return the Index'th source form read from Info and the position that it -;;; was read at. -;;; -(defun find-source-root (index info) - (declare (type unsigned-byte index) (type source-info info)) - (dolist (file (source-info-files info)) - (let ((root (file-info-source-root file)) - (forms (file-info-forms file))) - (when (> (+ (length forms) root) index) - (let ((idx (- index root))) - (return (values (aref forms idx) - (aref (file-info-positions file) idx)))))))) - - -;;;; Top-level form processing: - -;;; CONVERT-AND-MAYBE-COMPILE -- Internal -;;; -;;; Called by top-level form processing when we are ready to actually -;;; compile something. If *BLOCK-COMPILE* is true, then we still convert the -;;; form, but delay compilation, pushing the result on *TOP-LEVEL-LAMBDAS* -;;; instead. -;;; -(defun convert-and-maybe-compile (form tlf-num object) - (declare (type index tlf-num) (type object object)) - (let ((tll (ir1-top-level form tlf-num nil))) - (cond (*block-compile* (push tll *top-level-lambdas*)) - (t - (compile-top-level (list tll) object) - (clear-stuff))))) - - -;;; PROCESS-PROGN -- Internal -;;; -;;; Process a PROGN-like portion of a top-level form. Forms is a list of -;;; the forms, and TLF-Num is the top-level form number of the form they came -;;; out of. -;;; -(defun process-progn (forms tlf-num object) - (declare (list forms) (type index tlf-num) (type object object)) - (dolist (form forms) - (process-form form tlf-num object))) - - -;;; PREPROCESSOR-MACROEXPAND -- Internal -;;; -;;; Macroexpand form in the current environment with an error handler. -;;; -(defun preprocessor-macroexpand (form) - (handler-case #+new-compiler (macroexpand form *fenv*) - #-new-compiler - (if (consp form) - (let* ((name (car form)) - (exp (or (cddr (assoc name *fenv*)) - (info function macro-function name)))) - (if exp - (funcall exp form *fenv*) - form)) - form) - (error (condition) - (compiler-error "(during macroexpansion)~%~A" - condition)))) - - -(proclaim '(special *compiler-error-bailout*)) - -;;; PROCESS-FORM -- Internal -;;; -;;; Process a top-level Form with the specified source Path and output to -;;; Object. -;;; -- If this is a magic top-level form, then do stuff. -;;; -- If it is a macro expand it. -;;; -- Otherwise, just compile it. -;;; -;;; ### At least for now, always dump package frobbing as interpreted cold load -;;; forms. This might want to be on a switch someday. -;;; -(defun process-form (form tlf-num object) - (declare (type index tlf-num) (type object object)) - (catch 'process-form-error-abort - (let* ((*compiler-error-bailout* - #'(lambda () - (convert-and-maybe-compile - `(error "Execution of a form compiled with errors:~% ~S" - ',form) - tlf-num object) - (throw 'process-form-error-abort nil))) - (*current-path* (or (gethash form *source-paths*) - *current-path*))) - (if (atom form) - (convert-and-maybe-compile form tlf-num object) - (case (car form) - ((make-package in-package shadow shadowing-import export - unexport use-package unuse-package import) - (eval form) - (etypecase object - (fasl-file (fasl-dump-cold-load-form form object)) - ((or null core-object)))) - ((eval-when) - (unless (>= (length form) 2) - (compiler-error "EVAL-WHEN form is too short: ~S." form)) - (do-eval-when-stuff - (cadr form) (cddr form) - #'(lambda (forms) - (process-progn forms tlf-num object)))) - ((macrolet) - (unless (>= (length form) 2) - (compiler-error "MACROLET form is too short: ~S." form)) - (do-macrolet-stuff - (cadr form) - #'(lambda () - (process-progn (cddr form) tlf-num object)))) - (progn (process-progn (cdr form) tlf-num object)) - (file-comment - (unless (and (= (length form) 2) (stringp (second form))) - (compiler-error "Bad FILE-COMMENT form: ~S." form)) - (let ((file (first (source-info-current-file *source-info*)))) - (if (file-info-comment file) - (compiler-warning "Ignoring extra file comment:~% ~S." - form) - (setf (file-info-comment file) - (coerce (second form) 'simple-string))))) - (t - (let ((exp (preprocessor-macroexpand form))) - (if (eq exp form) - (convert-and-maybe-compile form tlf-num object) - (process-form exp tlf-num object)))))))) - - (undefined-value)) - - -;;;; COMPILE-FILE and COMPILE-FROM-STREAM: - -;;; We build a list of top-level lambdas, and then periodically smash them -;;; together into a single component and compile it. -;;; -(defvar *pending-top-level-lambdas*) - -;;; The maximum number of top-level lambdas we put in a single top-level -;;; component. -;;; -(defparameter top-level-lambda-max 10) - - -;;; COMPILE-TOP-LEVEL-LAMBDAS -- Internal -;;; -;;; Add Lambdas to the pending lambdas. If this leaves more than -;;; TOP-LEVEL-LAMBDA-MAX lambdas in the list, or if Force-P is true, then smash -;;; the lambdas into a single component, compile it, and call the resulting -;;; function. -;;; -(defun compile-top-level-lambdas (lambdas force-p object) - (declare (list lambdas) (type object object)) - (setq *pending-top-level-lambdas* - (append *pending-top-level-lambdas* lambdas)) - (let ((pending *pending-top-level-lambdas*)) - (when (and pending - (or (> (length pending) top-level-lambda-max) - force-p)) - (multiple-value-bind (component tll) - (merge-top-level-lambdas pending) - (setq *pending-top-level-lambdas* ()) - (compile-component component object) - (clear-ir2-info component) - (macerate-ir1-component component) - (etypecase object - (fasl-file - (fasl-dump-top-level-lambda-call tll object)) - (core-object - (core-call-top-level-lambda tll object)) - (null))))) - (undefined-value)) - - -;;; Compile-Top-Level -- Internal -;;; -;;; Compile Lambdas (a list of the lambdas for top-level forms) into the -;;; Object file. -;;; -(defun compile-top-level (lambdas object) - (declare (list lambdas) (type object object)) - (maybe-mumble "Local call analyze") - (dolist (lambda lambdas) - (let* ((component (block-component (node-block (lambda-bind lambda)))) - (*all-components* (list component))) - (local-call-analyze component))) - (maybe-mumble ".~%") - - (maybe-mumble "Find components") - (multiple-value-bind (components top-components) - (find-initial-dfo lambdas) - (let ((*all-components* (append components top-components)) - (top-level-closure nil)) - (when *check-consistency* - (maybe-mumble "[Check]~%") - (check-ir1-consistency *all-components*)) - - (dolist (component top-components) - (pre-environment-analyze-top-level component)) - - (dolist (component components) - (compile-component component object) - (clear-ir2-info component) - (if (replace-top-level-xeps component) - (setq top-level-closure t) - (unless *check-consistency* - (macerate-ir1-component component)))) - - (when *check-consistency* - (maybe-mumble "[Check]~%") - (check-ir1-consistency *all-components*)) - - (compile-top-level-lambdas lambdas top-level-closure object) - - (when *check-consistency* - (dolist (component components) - (macerate-ir1-component component))))) - - (ir1-finalize) - (undefined-value)) - - -;;; Sub-Compile-File -- Internal -;;; -;;; Read all forms from Info and compile them, with output to Object. If -;;; *Block-Compile* is true, we combine all the forms and compile as a unit, -;;; otherwise we compile each one separately. We return :ERROR, :WARNING, -;;; :NOTE or NIL to indicate the most severe kind of compiler diagnostic -;;; emitted. -;;; -(defun sub-compile-file (info object) - (declare (type source-info info) (type object object)) - (with-ir1-namespace - (clear-stuff) - (let* ((start-errors *compiler-error-count*) - (start-warnings *compiler-warning-count*) - (start-notes *compiler-note-count*) - (*package* *package*) - (*initial-package* *package*) - (*initial-cookie* *default-cookie*) - (*default-cookie* (copy-cookie *initial-cookie*)) - (*current-cookie* (make-cookie)) - (*fenv* ()) - (*source-info* info) - (*top-level-lambdas* ()) - (*pending-top-level-lambdas* ()) - (*compiler-error-bailout* - #'(lambda () - (compiler-mumble - "~2&Fatal error, aborting compilation...~%") - (return-from sub-compile-file :error))) - (*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)) - (with-compilation-unit () - (loop - (multiple-value-bind (form tlf eof-p) - (read-source-form info) - (when eof-p (return)) - (clrhash *source-paths*) - (find-source-paths form tlf) - (process-form form tlf object))) - - (when *block-compile* - (compile-top-level (nreverse *top-level-lambdas*) object) - (clear-stuff)) - - (compile-top-level-lambdas () t object) - - (etypecase object - (fasl-file (fasl-dump-source-info info object)) - (core-object (fix-core-source-info info object)) - (null)) - - (cond ((> *compiler-error-count* start-errors) :error) - ((> *compiler-warning-count* start-warnings) :warning) - ((> *compiler-note-count* start-notes) :note) - (t nil)))))) - - -;;; Verify-Source-Files -- Internal -;;; -;;; Return a list of pathnames that are the truenames of all the named -;;; files. -;;; -(defun verify-source-files (stuff) - (unless stuff - (error "Can't compile with no source files.")) - (mapcar #'(lambda (x) - (or (probe-file x) - (truename - (merge-pathnames x (make-pathname :type "lisp"))))) - (if (listp stuff) stuff (list stuff)))) - - -#+new-compiler -;;; COMPILE-FROM-STREAM -- Public -;;; -;;; Just call SUB-COMPILE-FILE on the on a stream source info for the -;;; stream, sending output to core. -;;; -(defun compile-from-stream (stream - &key - ((:error-stream *compiler-error-output*) - *error-output*) - ((:trace-stream *compiler-trace-output*) nil) - (defined-from-pathname nil) - ((:block-compile *block-compile*) nil)) - (declare (ignore defined-from-pathname)) - "Similar to COMPILE-FILE, but compiles text from Stream into the current lisp - environment. Stream is closed when compilation is complete. These keywords - are supported: - - :Error-Stream - The stream to write compiler error output to (default *ERROR-OUTPUT*.) - :Trace-Stream - The stream that we write compiler trace output to, or NIL (the default) - to inhibit trace output. - :Block-Compile - If true, then function names will be resolved at compile time." - (let ((info (make-stream-source-info stream))) - (unwind-protect - (let ((won (sub-compile-file info (make-core-object)))) - (values (not (null won)) - (if (member won '(:error :warning)) t nil))) - (close-source-info info)))) - - -(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))))) - - -;;; START-ERROR-OUTPUT, FINISH-ERROR-OUTPUT -- Internal -;;; -;;; Print some junk at the beginning and end of compilation. -;;; -(defun start-error-output (source-info) - (declare (type source-info source-info)) - (compiler-mumble "~2&Python version ~A, VM ~A on ~A.~%" - compiler-version vm-version - (ext:format-universal-time nil (get-universal-time) - :print-weekday nil - :print-timezone nil)) - (dolist (x (source-info-files source-info)) - (compiler-mumble "Compiling: ~A ~A~%" - (namestring (file-info-name x)) - (ext:format-universal-time nil (file-info-write-date x) - :print-weekday nil - :print-timezone nil))) - (compiler-mumble "~%") - (undefined-value)) -;;; -(defun finish-error-output (source-info won) - (declare (type source-info source-info)) - (compiler-mumble "Compilation ~:[aborted after~;finished in] ~A.~&" - won - (elapsed-time-to-string - (- (get-universal-time) - (source-info-start-time source-info)))) - (undefined-value)) - - -;;; COMPILE-FILE -- Public -;;; -;;; Open some files and call SUB-COMPILE-FILE. If the compile is unwound -;;; out of, then abort the writing of the output file, so we don't overwrite it -;;; with known garbage. -;;; -(defun #-new-compiler ncompile-file #+new-compiler compile-file - (source &key - (output-file t) - (error-file t) - (trace-file nil) - (error-output t) - (load nil) - ((:block-compile *block-compile*) nil)) - "Compiles Source, producing a corresponding .FASL file. Source may be a list - of files, in which case the files are compiled as a unit, producing a single - .FASL file. The output file names are defaulted from the first (or only) - input file name. Other options available via keywords: - :Output-File - The name of the fasl to output, NIL for none, T for the default. - :Error-File - The name of the error listing file, NIL for none, T for the .ERR - default. - :Trace-File - If specified, internal data structures are dumped to this file. T for - the .TRACE default. - :Error-Output - If a stream, then error output is sent there as well as to the listing - file. NIL suppresses this additional error output. The default is T, - which means use *ERROR-OUTPUT*. - :Block-Compile - If true, then function names will be resolved at compile time." - - (let* ((fasl-file nil) - (error-file-stream nil) - (output-file-name nil) - (*compiler-error-output* nil) - (*compiler-trace-output* nil) - (compile-won nil) - (error-severity nil) - (source (verify-source-files source)) - (source-info (make-file-source-info source)) - (default (pathname (first source)))) - (start-error-output source-info) - (unwind-protect - (progn - #-new-compiler - (pushnew :new-compiler *features*) - (flet ((frob (file type) - (if (eq file t) - (make-pathname :type type :defaults default) - (pathname file)))) - - (when output-file - (setq output-file-name (frob output-file "nfasl")) - (setq fasl-file (open-fasl-file output-file-name - (namestring (first source))))) - - (when trace-file - (setq *compiler-trace-output* - (open (frob trace-file "trace") - :if-exists :supersede - :direction :output))) - - (when error-file - (setq error-file-stream - (open (frob error-file "err") - :if-exists :supersede - :direction :output)))) - - (setq *compiler-error-output* - (apply #'make-broadcast-stream - (remove nil - (list (if (eq error-output t) - *error-output* - error-output) - error-file-stream)))) - (setq error-severity - (sub-compile-file source-info fasl-file)) - (setq compile-won t)) - - #-new-compiler - (setq *features* (remove :new-compiler *features*)) - - (close-source-info source-info) - - (when fasl-file - (close-fasl-file fasl-file (not compile-won)) - (when compile-won - (compiler-mumble "~&~A written.~%" - (namestring (truename output-file-name))))) - - (finish-error-output source-info compile-won) - - (when error-file-stream - (let ((name (pathname error-file-stream))) - (close error-file-stream) - (when (and compile-won (not error-severity)) - (delete-file name)))) - - (when *compiler-trace-output* - (close *compiler-trace-output*))) - - (when load - (unless output-file - (error "Can't :LOAD with no output file.")) - (load output-file-name :verbose t)) - - (values (if output-file (truename output-file-name) nil) - (not (null error-severity)) - (if (member error-severity '(:warning :error)) t nil)))) - - -;;;; COMPILE and UNCOMPILE: - -;;; GET-LAMBDA-TO-COMPILE -- Internal -;;; -(defun get-lambda-to-compile (definition) - (if (consp definition) - definition - (multiple-value-bind (def env-p) - (function-lambda-expression definition) - (when env-p - (error "~S was defined in a non-null environment." definition)) - (unless def - (error "Can't find a definition for ~S." definition)) - def))) - - -;;; COMPILE-FIX-FUNCTION-NAME -- Internal -;;; -;;; Find the function that is being compiled by COMPILE and bash its name to -;;; NAME. We also substitute for any references to name so that recursive -;;; calls will be compiled direct. Lambda is the top-level lambda for the -;;; compilation. A REF for the real function is the only thing in the -;;; top-level lambda other than the bind and return, so it isn't too hard to -;;; find. -;;; -(defun compile-fix-function-name (lambda name) - (declare (type clambda lambda) (type (or symbol cons) name)) - (when name - (let ((fun (ref-leaf - (continuation-next - (node-cont (lambda-bind lambda)))))) - (setf (leaf-name fun) name) - (let ((old (gethash name *free-functions*))) - (when old (substitute-leaf fun old))) - name))) - - -;;; COMPILE -- Public -;;; -#+new-compiler -(defun compile (name &optional (definition (fdefinition name))) - "Compiles the function whose name is Name. If Definition is supplied, - it should be a lambda expression that is compiled and then placed in the - function cell of Name. If Name is Nil, the compiled code object is - returned." - (with-compilation-unit () - (with-ir1-namespace - (clear-stuff) - (let* ((start-errors *compiler-error-count*) - (start-warnings *compiler-warning-count*) - (start-notes *compiler-note-count*) - (*current-cookie* (make-cookie)) - (*fenv* ()) - (form `#',(get-lambda-to-compile definition)) - (*source-info* (make-lisp-source-info form)) - (*top-level-lambdas* ()) - (*compiler-error-bailout* - #'(lambda () - (compiler-mumble - "~2&Fatal error, aborting compilation...~%") - (return-from compile (values nil t nil)))) - (*compiler-error-output* *error-output*) - (*compiler-trace-output* nil) - (*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) - (object (make-core-object))) - (find-source-paths form 0) - (let ((lambda (ir1-top-level form 0 t))) - - (compile-fix-function-name lambda name) - (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 (list lambda)) - (let ((*all-components* (append components top-components))) - (dolist (component *all-components*) - (compile-component component object) - (clear-ir2-info component)))) - - (fix-core-source-info *source-info* object) - (let* ((res (core-call-top-level-lambda lambda object)) - (return (or name res))) - (when name - (setf (fdefinition name) res)) - - (cond ((or (> *compiler-error-count* start-errors) - (> *compiler-warning-count* start-warnings)) - (values return t t)) - ((> *compiler-note-count* start-notes) - (values return t nil)) - (t - (values return nil nil))))))))) - -#+new-compiler -;;; UNCOMPILE -- Public -;;; -(defun uncompile (name) - "Attempt to replace Name's definition with an interpreted version of that - definition. If no interpreted definition is to be found, then signal an - error." - (let ((def (fdefinition name))) - (if (eval:interpreted-function-p def) - (warn "~S is already interpreted." name) - (setf (fdefinition name) - (coerce (get-lambda-to-compile def) 'function)))) - name) diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp deleted file mode 100644 index 7364f666cfdae042f37142cc8d88ba6344ead258..0000000000000000000000000000000000000000 --- a/compiler/mips/alloc.lisp +++ /dev/null @@ -1,101 +0,0 @@ -;;; -*- Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/mips/alloc.lisp,v 1.6 1990/05/25 20:03:03 wlott Exp $ -;;; -;;; Allocation VOPs for the MIPS port. -;;; -;;; Written by William Lott. -;;; - -(in-package "C") - - -(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) - (: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 vm: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 vm:list-pointer-type)))) - (let ((cons-cells (if star (1- num) num))) - (pseudo-atomic (ndescr) - (inst addu res alloc-tn vm:list-pointer-type) - (inst addu alloc-tn alloc-tn - (* (vm:pad-data-block vm:cons-size) cons-cells)) - (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 (vm:pad-data-block vm:cons-size)) - (storew ptr ptr - (- vm:cons-cdr-slot vm:cons-size) - vm: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 vm:cons-cdr-slot)) - (t - (storew null-tn ptr - vm:cons-cdr-slot vm:list-pointer-type))) - (assert (null (tn-ref-across things))) - (move result res)))))))) - -(define-vop (list list-or-list*) - (:variant nil)) - -(define-vop (list* list-or-list*) - (:variant t)) - - -(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 li ndescr (lognot vm:lowtag-mask)) - (inst addu boxed boxed-arg (fixnum 1)) - (inst and boxed ndescr) - (inst srl unboxed unboxed-arg vm:word-shift) - (inst addu unboxed unboxed vm:lowtag-mask) - (inst and unboxed ndescr) - (pseudo-atomic (ndescr) - (inst addu result alloc-tn vm:other-pointer-type) - (inst addu alloc-tn boxed) - (inst addu alloc-tn unboxed) - (inst sll ndescr boxed (- vm:type-bits vm:word-shift)) - (inst or ndescr vm:code-header-type) - (storew ndescr result 0 vm:other-pointer-type) - (storew unboxed result vm:code-code-size-slot vm:other-pointer-type) - (storew null-tn result vm:code-entry-points-slot vm:other-pointer-type) - (storew null-tn result vm:code-debug-info-slot vm:other-pointer-type)))) diff --git a/compiler/mips/arith.lisp b/compiler/mips/arith.lisp deleted file mode 100644 index 6df7472b4936bee54dbac4e0184b2a284b274099..0000000000000000000000000000000000000000 --- a/compiler/mips/arith.lisp +++ /dev/null @@ -1,757 +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/mips/arith.lisp,v 1.22 1990/05/19 09:40:26 wlott Exp $ -;;; -;;; This file contains the VM definition arithmetic VOPs for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "C") - - - -;;;; 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 descriptor-reg)) - (y :target r :scs (any-reg descriptor-reg))) - (:arg-types tagged-num tagged-num) - (:results (r :scs (any-reg descriptor-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 op &optional unsigned) - `(progn - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/FIXNUM=>FIXNUM")) - fast-fixnum-binop) - (:args (x :target r - :scs (any-reg descriptor-reg)) - (y :target r - :scs (any-reg descriptor-reg immediate zero - ,(if unsigned - 'unsigned-immediate - 'negative-immediate)))) - (:translate ,translate) - (:generator ,cost - (inst ,op r x - (sc-case y - ((any-reg descriptor-reg) y) - (zero zero-tn) - ((immediate - ,(if unsigned 'unsigned-immediate 'negative-immediate)) - (fixnum (tn-value y))))))) - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/SIGNED=>SIGNED")) - fast-signed-binop) - (:args (x :target r - :scs (signed-reg)) - (y :target r - :scs (signed-reg immediate zero - ,(if unsigned - 'unsigned-immediate - 'negative-immediate)))) - (:translate ,translate) - (:generator ,(1+ cost) - (inst ,op r x - (sc-case y - (signed-reg y) - (zero zero-tn) - ((immediate - ,(if unsigned 'unsigned-immediate 'negative-immediate)) - (tn-value y)))))) - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/UNSIGNED=>UNSIGNED")) - fast-unsigned-binop) - (:args (x :target r - :scs (unsigned-reg)) - (y :target r - :scs (unsigned-reg immediate zero - ,(if unsigned - 'unsigned-immediate - 'negative-immediate)))) - (:translate ,translate) - (:generator ,(1+ cost) - (inst ,op r x - (sc-case y - (unsigned-reg y) - (zero zero-tn) - ((immediate - ,(if unsigned 'unsigned-immediate 'negative-immediate)) - (tn-value y)))))))) - -(define-binop + 2 addu) -(define-binop - 2 subu) -(define-binop logior 1 or t) -(define-binop logand 1 and t) -(define-binop logxor 1 xor t) - -;;; Special case fixnum + and - that don't check for overflow. Useful when we -;;; know the output type is a fixnum. - -(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum) - (:result-types *) - (:note nil) - (:generator 1 - (inst add r x - (sc-case y - ((any-reg descriptor-reg) y) - (zero zero-tn) - ((immediate negative-immediate) - (fixnum (tn-value y))))))) - -(define-vop (fast--/fixnum fast--/fixnum=>fixnum) - (:result-types *) - (:note nil) - (:generator 1 - (inst sub r x - (sc-case y - ((any-reg descriptor-reg) y) - (zero zero-tn) - ((immediate negative-immediate) - (fixnum (tn-value y))))))) - - -;;; Shifting - -(define-vop (fast-ash) - (:note "inline ASH") - (:args (number :scs (signed-reg unsigned-reg)) - (amount :scs (signed-reg immediate negative-immediate))) - (:arg-types (:or signed-num unsigned-num) *) - (:results (result :scs (signed-reg unsigned-reg))) - (:result-types (:or signed-num unsigned-num)) - (:translate ash) - (:policy :fast-safe) - (:temporary (:scs (non-descriptor-reg) :type random :to (:result 0)) - ndesc) - (:temporary (:scs (non-descriptor-reg) :type random :from (:argument 1)) - foo) - (:generator 3 - (sc-case amount - (signed-reg - (let ((positive (gen-label)) - (done (gen-label))) - (inst bgez amount positive) - (inst subu ndesc zero-tn amount) - (inst and foo ndesc #x1f) - (inst beq foo ndesc done) - (inst sra result number ndesc) - (inst b done) - (inst sra 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 negative-immediate) - (let ((amount (tn-value amount))) - (if (minusp amount) - (sc-case result - (unsigned-reg - (inst srl result number (- amount))) - (t - (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))) - (: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 shift)) - (:arg-types unsigned-num) - (:results (res :scs (any-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp) - (:generator 30 - (let ((loop (gen-label)) - (done (gen-label))) - (move shift arg) - (inst beq shift done) - (move res zero-tn) - (inst and temp shift 1) - - (emit-label loop) - (inst sll temp 2) - (inst add res temp) - (inst srl shift 1) - (inst bne shift loop) - (inst and temp shift 1) - - (emit-label done)))) - - -;;; Multiply and Divide. - -(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) - (:temporary (:scs (non-descriptor-reg) :type random) temp) - (:translate *) - (:generator 4 - (inst sra temp y 2) - (inst mult x temp) - (inst mflo r))) - -#| -(define-vop (fast-*/fixnum fast-fixnum-binop) - (:temporary (:scs (non-descriptor-reg) :type random) temp) - (:translate *) - (:result-types *) - (:generator 12 - (inst sra temp y 2) - (inst mult x temp) - (inst mfhi 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/signed fast-signed-binop) - (:translate truncate) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:results (q :scs (signed-reg)) - (r :scs (signed-reg))) - (:result-types * *) - (:generator 11 - (let ((zero (generate-error-code di:division-by-zero-error x y))) - (inst beq y zero-tn zero)) - (inst div x y) - (inst mflo q) - (inst mfhi r))) - -(define-vop (fast-rem/signed fast-signed-binop) - (:translate rem) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:results (r :scs (signed-reg))) - (:result-types *) - (:generator 10 - (let ((zero (generate-error-code di:division-by-zero-error x y))) - (inst beq y zero-tn zero)) - (inst div x y) - (inst mfhi 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) - (: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) - (:arg-types tagged-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) - (:arg-types tagged-num (:constant (unsigned-byte 15))) - (:info target not-p y)) - - -(defmacro define-conditional-vop (translate &rest generator) - `(progn - (define-vop (,(intern (concatenate 'simple-string - "FAST-IF-" - (string translate) - "/FIXNUM")) - fast-conditional/fixnum) - (:translate ,translate) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp) - (:generator 4 - (let ((signed t)) - ,@generator))) - #+nil - (define-vop (,(intern (concatenate 'simple-string - "FAST-IF-" - (string translate) - "-C/FIXNUM")) - fast-conditional-c/fixnum) - (:translate ,translate) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp) - (:generator 4 - (let ((signed t) - (y (fixnum y))) - ,@generator))) - (define-vop (,(intern (concatenate 'simple-string - "FAST-IF-" - (string translate) - "/SIGNED")) - fast-conditional/signed) - (:translate ,translate) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp) - (:generator 5 - (let ((signed t)) - ,@generator))) - #+nil - (define-vop (,(intern (concatenate 'simple-string - "FAST-IF-" - (string translate) - "-C/SIGNED")) - fast-conditional-c/signed) - (:translate ,translate) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp) - (:generator 5 - (let ((signed t)) - ,@generator))) - (define-vop (,(intern (concatenate 'simple-string - "FAST-IF-" - (string translate) - "/UNSIGNED")) - fast-conditional/unsigned) - (:translate ,translate) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp) - (:generator 5 - (let ((signed nil)) - ,@generator))) - #+nil - (define-vop (,(intern (concatenate 'simple-string - "FAST-IF-" - (string translate) - "-C/UNSIGNED")) - fast-conditional-c/unsigned) - (:translate ,translate) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp) - (:generator 5 - (let ((signed nil)) - ,@generator))))) - -(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))) - (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)) - -(define-conditional-vop = - (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)) - - - - - -;;;; 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))) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) - (:results (result :scs (unsigned-reg))) - (: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))) - (:results (r :scs (unsigned-reg))) - (:policy :fast-safe)) - -(define-vop (32bit-logical-not 32bit-logical) - (:translate 32bit-logical-not) - (:args (x :scs (unsigned-reg))) - (:generator 1 - (inst nor r x zero-tn))) - -(define-vop (32bit-logical-nor 32bit-logical) - (:translate 32bit-logical-nor) - (:generator 1 - (inst nor r x y))) - -(define-vop (32bit-logical-and 32bit-logical) - (:translate 32bit-logical-and) - (:generator 1 - (inst and r x y))) - -(define-vop (32bit-logical-or 32bit-logical) - (:translate 32bit-logical-or) - (:generator 1 - (inst or r x y))) - -(define-vop (32bit-logical-xor 32bit-logical) - (:translate 32bit-logical-xor) - (:generator 1 - (inst xor r x y))) - - - -;;;; 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)))) - -(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 descriptor-reg - immediate unsigned-immediate)) - (value :scs (unsigned-reg))) - (:results (result :scs (unsigned-reg)))) - -(define-vop (digit-0-or-plus) - (:translate bignum::%digit-0-or-plusp) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg))) - (:results (result :scs (descriptor-reg))) - (:generator 3 - (let ((done (gen-label))) - (inst bltz digit 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))) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) - (:results (result :scs (unsigned-reg)) - (carry :scs (unsigned-reg) :from :eval)) - (: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))) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) - (:results (result :scs (unsigned-reg)) - (borrow :scs (unsigned-reg) :from :eval)) - (:temporary (temp :scs (non-descriptor-reg))) - (: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) - (:translate bignum::%multiply) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (: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))) - (:results (r :scs (unsigned-reg))) - (: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))) - (:results (digit :scs (unsigned-reg))) - (:generator 1 - (inst sra digit fixnum 2))) - -(define-vop (bignum-floor) - (:translate bignum::%floor) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (unsigned-reg))) - (:results (quo :scs (unsigned-reg)) - (rem :scs (unsigned-reg))) - (:generator 3 - (progn a b c quo rem) - (warn "Don't know how to divide a 64 bit number by a 32 bit number."))) - - -(define-vop (signify-digit) - (:translate bignum::%fixnum-digit-with-correct-sign) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target res)) - (:results (res :scs (any-reg signed-reg))) - (: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))) - (:results (result :scs (unsigned-reg))) - (:generator 1 - (inst sra result digit count))) - -(define-vop (digit-ashl) - (:translate bignum::%ashl) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg)) - (count :scs (unsigned-reg))) - (:results (result :scs (unsigned-reg))) - (: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 7f9530913968508091691420bcaf99fb5449f10a..0000000000000000000000000000000000000000 --- a/compiler/mips/array.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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.15 1990/05/15 01:17:07 wlott Exp $ -;;; -;;; This file contains the MIPS definitions for array operations. -;;; -;;; Written by William Lott -;;; -(in-package "C") - - -;;;; Allocator for the array header. - -(define-vop (make-array-header) - (: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) - (:results (result :scs (descriptor-reg))) - (:generator 0 - (pseudo-atomic (ndescr) - (inst addu header alloc-tn vm:other-pointer-type) - (inst addu alloc-tn alloc-tn - (* vm:array-dimensions-offset vm:word-bytes)) - (inst addu alloc-tn alloc-tn rank) - (inst sll ndescr rank 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 ((setf lisp::%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 (setf lisp::%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) :type random) temp) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw temp x 0 vm:other-pointer-type) - (inst sra temp temp vm:type-bits) - (inst sll res temp 2) - (inst addu res res (fixnum (- 1 vm:array-dimensions-offset))))) - - - -;;;; 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) :type random) temp) - (:generator 5 - (let ((error (generate-error-code di: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 - -(defmacro def-data-vector-frobs (type variant &optional (element-type t) sc) - `(progn - (define-vop (,(intern (concatenate 'simple-string - "DATA-VECTOR-REF/" - (string type))) - ,(intern (concatenate 'simple-string - (string variant) - "-REF"))) - (:variant vm:vector-data-offset vm:other-pointer-type) - (:translate data-vector-ref) - (:arg-types ,type *) - ,@(when sc - `((:results (value :scs (,sc))) - (:result-types ,element-type)))) - (define-vop (,(intern (concatenate 'simple-string - "DATA-VECTOR-SET/" - (string type))) - ,(intern (concatenate 'simple-string - (string variant) - "-SET"))) - (:variant vm:vector-data-offset vm:other-pointer-type) - (:translate data-vector-set) - (:arg-types ,type * ,element-type) - ,@(when sc - `((:args (object :scs (descriptor-reg)) - (index :scs (any-reg descriptor-reg - immediate unsigned-immediate)) - (value :scs (,sc))) - (:results (result :scs (,sc)))))))) - -(def-data-vector-frobs simple-string byte-index - base-character base-character-reg) -(def-data-vector-frobs simple-vector word-index) - -(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) - - - -(define-vop (raw-bits word-index-ref) - (:note "raw-bits VOP") - (:translate %raw-bits) - (:results (value :scs (unsigned-reg))) - (:variant 0 vm:other-pointer-type)) - -(define-vop (set-raw-bits word-index-set) - (:note "setf raw-bits VOP") - (:translate (setf %raw-bits)) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg descriptor-reg immediate unsigned-immediate)) - (value :scs (unsigned-reg))) - (:results (result :scs (unsigned-reg))) - (: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/mips/call.lisp b/compiler/mips/call.lisp deleted file mode 100644 index 4f1dd82a5498e368c9f44c457c6a8540ba7d636b..0000000000000000000000000000000000000000 --- a/compiler/mips/call.lisp +++ /dev/null @@ -1,1159 +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/mips/call.lisp,v 1.14 1990/05/27 14:55:48 wlott Exp $ -;;; -;;; This file contains the VM definition of function call for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted for the MIPS by William Lott. -;;; -(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 register-arg-scn (elt register-arg-offsets n)) - (make-wired-tn 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. -;;; -(defun make-return-pc-passing-location (standard) - (if standard - (make-wired-tn register-arg-scn lra-offset) - (make-restricted-tn 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 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) - (environment-live-tn - (make-wired-tn (sc-number-or-lose 'control-stack) old-fp-save-offset) - env)) -;;; -(defun make-return-pc-save-location (env) - (environment-live-tn - (make-wired-tn (sc-number-or-lose 'control-stack) lra-save-offset) - env)) - -;;; 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 register-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. -;;; -(defun make-nfp-tn () - (component-live-tn (make-restricted-tn (sc-number-or-lose 'any-reg)))) - - -;;; 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. -;;; -(defun 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: - -;;; Used for setting up the Old-FP in local call. -;;; -(define-vop (current-fp) - (:results (val :scs (any-reg descriptor-reg))) - (:generator 1 - (move val fp-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 descriptor-reg))) - (:vop-var vop) - (:generator 1 - (let ((nfp (current-nfp-tn vop))) - (when nfp - (inst addu val nfp - (* (sb-allocated-size 'non-descriptor-stack) vm:word-bytes)))))) - - -(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)) - (inst addu csp-tn fp-tn - (* vm:word-bytes (sb-allocated-size 'control-stack))) - (let ((nfp-tn (current-nfp-tn vop))) - (when nfp-tn - (move nfp-tn nsp-tn) - (inst addu nsp-tn nsp-tn - (- (* (sb-allocated-size 'non-descriptor-stack) - vm:word-bytes))))))) - -(define-vop (allocate-frame) - (:results (res :scs (any-reg descriptor-reg)) - (nfp :scs (any-reg))) - (:info callee) - (:ignore nfp) - (:generator 2 - (move res csp-tn) - (inst addu csp-tn csp-tn - (* vm:word-bytes (sb-allocated-size 'control-stack))) - (when (ir2-environment-number-stack-p callee) - (move nfp nsp-tn) - (inst addu nsp-tn nsp-tn - (- (* (sb-allocated-size 'non-descriptor-stack) - vm:word-bytes)))))) - -;;; 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))) - (:generator 2 - (when (> nargs register-arg-count) - (move res csp-tn) - (inst addu 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 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: -#| - 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 sp ; Set up args for SP resetting - -regs-defaulted - sub temp nargs register-arg-count - - bltz temp default-value-4 ; jump to default code - addu temp temp -1 - loadw move-temp args-tn 3 ; Move value to correct location. - store-stack-tn val4-tn move-temp - - bltz temp default-value-5 - addu temp temp -1 - loadw move-temp args-tn 4 - store-stack-tn val5-tn move-temp - - ... - -defaulting-done - move sp old-fp ; Reset SP. -<end of code> - -<elsewhere> -default-value-4 - store-stack-tn val4-tn null-tn ; Nil out 4'th value. - -default-value-5 - store-stack-tn val5-tn null-tn ; Nil out 5'th value. - - ... - - br defaulting-done - nop -|# -;;; -(defun default-unknown-values (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 - (move csp-tn old-fp-tn) - (inst nop) - (inst compute-code-from-lra code-tn code-tn lra-label)) - (let ((regs-defaulted (gen-label)) - (defaulting-done (gen-label))) - ;; Branch off to the MV case. - (inst b regs-defaulted) - (inst compute-code-from-lra code-tn code-tn lra-label) - - ;; Do the single value calse. - (inst compute-code-from-lra code-tn code-tn lra-label) - (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 li nargs-tn (fixnum 1)) - (move old-fp-tn csp-tn)) - - (emit-label regs-defaulted) - - (when (> nvals register-arg-count) - (inst addu temp nargs-tn (fixnum (- 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 bltz temp default-lab) - (inst addu temp temp (fixnum -1)) - (loadw move-temp args-tn i) - (store-stack-tn tn move-temp))) - - (emit-label defaulting-done) - (move csp-tn args-tn) - - (assemble (*elsewhere*) - (dolist (def (defaults)) - (emit-label (car def)) - (store-stack-tn (cdr def) null-tn)) - (inst b defaulting-done) - (inst nop)))))) - (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))) - (inst b variable-values) - (inst compute-code-from-lra code-tn code-tn lra-label) - - (inst compute-code-from-lra code-tn code-tn lra-label) - (inst addu csp-tn csp-tn 4) - (storew (first register-arg-tns) csp-tn -1) - (inst addu start csp-tn -4) - (inst li count (fixnum 1)) - - (emit-label done) - - (assemble (*elsewhere*) - (emit-label variable-values) - (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))) - (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))) - (:temporary (:sc descriptor-reg :offset old-fp-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 (any-reg descriptor-reg)) - (nfp :scs (any-reg descriptor-reg)) - (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 (:scs (any-reg) :type fixnum) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:generator 5 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (move fp-tn fp) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move callee-nfp nfp))) - (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label) - (inst b target) - (inst nop) - (emit-return-pc label) - (note-this-location vop :unknown-return) - (default-unknown-values values nvals move-temp 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 (any-reg descriptor-reg)) - (nfp :scs (any-reg descriptor-reg)) - (args :more t)) - (:save-p t) - (:move-args :local-call) - (:info save callee target) - (:ignore args save nfp) - (: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))) - (move fp-tn fp) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move callee-nfp nfp))) - (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label) - (inst b target) - (inst nop) - (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 (any-reg descriptor-reg)) - (nfp :scs (any-reg descriptor-reg)) - (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))) - (move fp-tn fp) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move callee-nfp nfp))) - (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label) - (inst b target) - (inst nop) - (note-this-location vop :known-return) - (emit-return-pc label) - (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 (descriptor-reg)) - (return-pc :scs (descriptor-reg)) - (vals :more t)) - (:temporary (:scs (interior-reg) :type interior) lip) - (:move-args :known-return) - (:info val-locs) - (:ignore val-locs vals) - (:vop-var vop) - (:generator 6 - (move csp-tn fp-tn) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move nsp-tn cur-nfp))) - (inst addu lip return-pc (- vm:word-bytes vm:other-pointer-type)) - (inst j lip) - (move fp-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. -;;; -;;; 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))) - - ,(if named - '(name :scs (descriptor-reg) :target name-pass) - '(arg-fun :scs (descriptor-reg) :target lexenv :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) - ,@(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 old-fp-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) - - ,@(when 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) - (:temporary (:scs (any-reg) :type fixnum :from :eval) 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)) - - ,@(if named - `((move name-pass name) - (loadw lexenv name-pass - vm:symbol-function-slot vm:other-pointer-type)) - `((move lexenv arg-fun))) - - ,@(if variable - `((inst subu 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)))) - - (let ((cur-nfp (current-nfp-tn vop)) - ,@(unless (eq return :tail) - '((lra-label (gen-label))))) - ,@(unless (eq return :tail) - `((inst compute-lra-from-code return-pc-pass code-tn lra-label))) - - (loadw function lexenv vm:closure-function-slot - vm:function-pointer-type) - (inst addu 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) - (move return-pc-pass return-pc) - (when cur-nfp - (move nsp-tn cur-nfp)) - (inst j lip) - (move code-tn function)) - `((move old-fp-pass fp-tn) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - ,(if variable - '(move fp-tn new-fp) - '(if (> nargs register-arg-count) - (move fp-tn new-fp) - (move fp-tn csp-tn))) - (inst j lip) - (move code-tn function) - (emit-return-pc lra-label))) - - ,@(ecase return - (:fixed - '((note-this-location vop :unknown-return) - (default-unknown-values values nvals move-temp 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)))))) - - -(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. -;;; -(expand - `(define-vop (tail-call-variable) - (:args - (args :scs (descriptor-reg) :to (:result 0)) - (function-arg :scs (descriptor-reg) :target lexenv) - (old-fp-arg :scs (descriptor-reg) :target old-fp) - (return-pc-arg :scs (descriptor-reg) :target return-pc)) - (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 0)) - lexenv) - (:temporary (:sc any-reg :offset old-fp-offset :from (:argument 1)) - old-fp) - (:temporary (:sc any-reg :offset lra-offset :from (:argument 2)) - return-pc) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:scs (descriptor-reg)) function) - ,@(mapcar #'(lambda (offset name) - `(:temporary (:sc any-reg :offset ,offset) ,name)) - register-arg-offsets register-arg-names) - (:temporary (:scs (any-reg) :type fixnum) src dst count) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (interior-reg) :type interior) lip) - (:vop-var vop) - (:generator 75 - (let ((loop (gen-label)) - (test (gen-label))) - ;; Move these into the passing locations if they are not already there. - (move lexenv function-arg) - (move old-fp old-fp-arg) - (move return-pc return-pc-arg) - - ;; 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) - ,@(let ((index -1)) - (mapcar #'(lambda (name) - `(loadw ,name args ,(incf index))) - register-arg-names)) - - ;; Calc SRC, DST, and COUNT - (inst addu src args (* vm:word-bytes register-arg-count)) - (inst addu dst fp-tn (* vm:word-bytes register-arg-count)) - (inst b test) - (inst addu count nargs (fixnum (- register-arg-count))) - - (emit-label loop) - ;; Copy one arg. - (loadw temp src) - (inst addu src src vm:word-bytes) - (storew temp dst) - (inst addu dst dst vm:word-bytes) - - ;; Are we done? - (emit-label test) - (inst bgtz count loop) - (inst addu count count (fixnum -1)) - - ;; Clear the number stack if anything is there. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move nsp-tn cur-nfp))) - - ;; We are done. Do the jump. - (loadw function lexenv vm:closure-function-slot - vm:function-pointer-type) - (lisp-jump function lip))))) - - -;;;; 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.) -;;; -(expand - `(define-vop (return) - (:args - (old-fp :scs (any-reg)) - (return-pc :scs (descriptor-reg) :to (:eval 1)) - (values :more t)) - (:ignore values) - (:info nvals) - ,@(mapcar #'(lambda (name offset) - `(:temporary (:sc descriptor-reg :offset ,offset - :from (:eval 0) :to (:eval 1)) - ,name)) - register-arg-names register-arg-offsets) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset old-fp-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 - (move nsp-tn cur-nfp))) - (move csp-tn fp-tn) - ;; Reset the frame pointer. - (move fp-tn old-fp) - ;; Out of here. - (inst addu lip return-pc (- (* 3 word-bytes) other-pointer-type)) - (inst j 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 - (move nsp-tn cur-nfp))) - (move val-ptr fp-tn) - ;; Reset the frame pointer. - (move fp-tn old-fp) - - (inst addu csp-tn val-ptr (* nvals word-bytes)) - - ,@(let ((index 0)) - (mapcar #'(lambda (name) - `(when (< nvals ,(incf index)) - (move ,name null-tn))) - register-arg-names)) - - (lisp-return return-pc lip)))))) - -;;; 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, Start and Count in the normal locations for these values. -;;; Return-PC is passed in A3 since PC is trashed by the BALA. -;;; - - -(expand - (let ((label-names (mapcar #'(lambda (name) - (intern (concatenate 'simple-string - "DEFAULT-" - (string name) - "-AND-ON"))) - register-arg-names))) - `(define-vop (return-multiple) - (:args - (old-fp :scs (descriptor-reg) :to (:eval 1)) - (return-pc :scs (descriptor-reg) :to (:eval 1)) - (start :scs (descriptor-reg any-reg) :target src) - (nvals :scs (descriptor-reg any-reg) :target nargs)) - (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nargs) - ,@(mapcar #'(lambda (name offset) - `(:temporary (:sc descriptor-reg :offset ,offset - :from (:eval 0) :to (:eval 1)) - ,name)) - register-arg-names register-arg-offsets) - (:temporary (:sc any-reg :offset old-fp-offset :type fixnum) vals) - (:temporary (:scs (any-reg) :type fixnum) count dst) - (:temporary (:scs (any-reg) :type fixnum :from (:argument 2)) src) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (interior-reg) :type interior) lip) - (:vop-var vop) - (:generator 13 - (let ((not-single (gen-label)) - (loop (gen-label)) - ,@(mapcar #'(lambda (name) - `(,name (gen-label))) - label-names) - (done (gen-label))) - - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move nsp-tn cur-nfp))) - - ;; Single case? - (inst li count (fixnum 1)) - (inst bne count nvals not-single) - (inst nop) - - ;; Return with one value. - (loadw ,(first register-arg-names) start) - (move csp-tn fp-tn) - (move fp-tn old-fp) - ;; Note: we can't use the lisp-return macro, 'cause we want to - ;; skip two instructions. - (inst addu lip return-pc (- (* 3 word-bytes) other-pointer-type)) - (inst j lip) - (move code-tn return-pc) - - ;; Nope, not the single case. - (emit-label not-single) - - ;; Load the register args, bailing out when we are done. - (move nargs nvals) - (move count nvals) - (move src start) - ,@(mapcar #'(lambda (name label) - `(progn - (inst blez count ,label) - (inst addu count count (fixnum -1)) - (loadw ,name src) - (inst addu src src vm:word-bytes))) - register-arg-names - label-names) - - ;; Copy the remaining args to the top of the stack. - (inst addu dst fp-tn (* vm:word-bytes register-arg-count)) - - (emit-label loop) - (inst blez count done) - (inst addu count count (fixnum -1)) - (loadw temp src) - (inst addu src src vm:word-bytes) - (storew temp dst) - (inst b loop) - (inst addu dst dst vm:word-bytes) - - ;; Default some number of registers. - ,@(mapcar #'(lambda (name label) - `(progn - (emit-label ,label) - (move ,name null-tn))) - register-arg-names label-names) - - ;; Clear the stack. - (emit-label done) - (move vals fp-tn) - (inst addu csp-tn vals nargs) - (move fp-tn old-fp) - - ;; Return. - (lisp-return return-pc lip)))))) - - - - -;;;; XEP hackery: - - -;;; Fetch the constant pool from the function entry structure. -;;; -(define-vop (setup-environment) - (:info label) - (:generator 5 - ;; Fix CODE, cause the function object was passed in. - (inst compute-code-from-fn code-tn code-tn label))) - -;;; 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) - (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure - :to (:result 0)) - lexenv) - (:results (closure :scs (descriptor-reg))) - (:info label) - (:generator 6 - ;; Fix CODE, cause the function object was passed in. - (inst compute-code-from-fn code-tn code-tn label) - ;; 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 addu csp-tn csp-tn nargs-tn) - (inst beq nargs-tn done) - (inst nop)) - (t - (inst addu count nargs-tn (fixnum (- fixed))) - (inst blez count done) - (inst nop) - (inst addu 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 addu count nargs-tn (fixnum (- register-arg-count)))) - ;; Everything of interest in registers. - (inst blez count do-regs) - ;; Initialize dst to be end of stack. - (move dst csp-tn) - ;; Initialize src to be end of args. - (inst addu src fp-tn nargs-tn) - - (emit-label loop) - ;; *--dst = *--src, --count - (inst addu src src (- vm:word-bytes)) - (inst addu count count (fixnum -1)) - (loadw temp src) - (inst addu dst dst (- vm:word-bytes)) - (inst bgtz count 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 addu count nargs-tn (fixnum (- fixed))) - (do ((i fixed (1+ i))) - ((>= i register-arg-count)) - ;; Don't deposit any more than there are. - (inst beq count zero-tn done) - (inst addu count 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 (any-reg descriptor-reg)) - (count-arg :target count :scs (any-reg descriptor-reg))) - (: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) ndescr dst) - (:results (result :scs (any-reg 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 beq count zero-tn done) - (move result null-tn) - - ;; We need to do this atomically. - (pseudo-atomic (ndescr) - ;; Allocate a cons (2 words) for each item. - (inst addu result alloc-tn vm:list-pointer-type) - (move dst result) - (inst addu alloc-tn alloc-tn count) - (inst b enter) - (inst addu alloc-tn alloc-tn count) - - ;; 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 addu context context vm:word-bytes) - (storew temp dst 0 vm:list-pointer-type) - - ;; Dec count, and if != zero, go back for more. - (inst addu count count (fixnum -1)) - (inst bne count zero-tn loop) - (inst addu 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) - (:args - (supplied :scs (any-reg descriptor-reg))) - (:info fixed) - (:results - (context :scs (descriptor-reg)) - (count :scs (any-reg descriptor-reg))) - (:generator 5 - (inst addu count supplied (fixnum (- fixed))) - (inst subu 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 descriptor-reg))) - (:temporary (:scs (any-reg) :type fixnum) temp) - (:info count) - (:generator 3 - (let ((err-lab (generate-error-code di:invalid-argument-count-error - nargs))) - (cond ((zerop count) - (inst bne nargs zero-tn err-lab) - (inst nop)) - (t - (inst li temp (fixnum count)) - (inst bne nargs temp err-lab) - (inst nop)))))) - -;;; 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)) - (:generator 1000 - (error-call ,error ,@args))))) - (frob argument-count-error di:invalid-argument-count-error nargs) - (frob type-check-error di:object-not-type-error object type) - (frob odd-keyword-arguments-error di:odd-keyword-arguments-error) - (frob unknown-keyword-argument-error di:unknown-keyword-argument-error key)) diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp deleted file mode 100644 index 755d1e32720cd892664300009af555b5e3bdd489..0000000000000000000000000000000000000000 --- a/compiler/mips/cell.lisp +++ /dev/null @@ -1,326 +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/mips/cell.lisp,v 1.34 1990/05/25 20:03:52 wlott Exp $ -;;; -;;; This file contains the VM definition of various primitive memory access -;;; VOPs for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "C") - - -;;;; Data object definition macros. - - -(vm:define-for-each-primitive-object (obj) - (collect ((forms)) - (let* ((options (vm:primitive-object-options obj)) - (obj-type (getf options :type t)) - (alloc-trans (getf options :alloc-trans)) - (alloc-vop (getf options :alloc-vop alloc-trans)) - (header (vm:primitive-object-header obj)) - (lowtag (vm:primitive-object-lowtag obj)) - (size (vm:primitive-object-size obj)) - (variable-length (vm:primitive-object-variable-length obj)) - (need-unbound-marker nil)) - (collect ((args) (init-forms)) - (when (and alloc-vop variable-length) - (args 'extra-words)) - (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)) - (slot-type (getf slot-opts :type t)) - (ref-trans (getf slot-opts :ref-trans)) - (ref-vop (getf slot-opts :ref-vop ref-trans)) - (ref-known (getf slot-opts :ref-known)) - (set-trans (getf slot-opts :set-trans)) - (setf-vop (getf slot-opts :setf-vop - (when (and (listp set-trans) - (= (length set-trans) 2) - (eq (car set-trans) 'setf)) - (intern (concatenate - 'simple-string - "SET-" - (string (cadr set-trans))))))) - (set-vop (getf slot-opts :set-vop - (if setf-vop nil set-trans))) - (set-known (getf slot-opts :set-known))) - (when ref-known - (if ref-trans - (forms `(defknown (,ref-trans) (,obj-type) ,slot-type - ,ref-known)) - (error "Can't spec a :ref-known with no :ref-trans. ~S in ~S" - name (vm:primitive-object-name obj)))) - (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 set-known - (if set-trans - (forms `(defknown (,set-trans) (,obj-type ,slot-type) - ,slot-type ,set-known)) - (error "Can't spec a :set-known with no :set-trans. ~S in ~S" - name (vm:primitive-object-name obj)))) - (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)) - (set-vop `(,set-vop cell-set)) - (t `(,setf-vop cell-setf))) - (:variant ,offset ,lowtag) - ,@(when set-trans - `((:translate ,set-trans)))))) - (ecase (getf (vm: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 (vm:slot-name slot)) - (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) (vm:primitive-object-name obj))) - (when alloc-vop - (forms - `(define-vop (,alloc-vop) - (:args ,@(mapcar #'(lambda (name) - `(,name :scs (any-reg descriptor-reg))) - (args))) - (:temporary (:scs (non-descriptor-reg) :type random) - ndescr - ,@(when (or need-unbound-marker header - variable-length) - '(temp))) - (:temporary (:scs (descriptor-reg) :to (:result 0) - :target real-result) result) - (:results (real-result :scs (descriptor-reg))) - (:policy :fast-safe) - ,@(when alloc-trans - `((:translate ,alloc-trans))) - (:generator 37 - (pseudo-atomic (ndescr) - (inst addu result alloc-tn ,lowtag) - ,@(cond ((and header variable-length) - `((inst addu temp extra-words - (fixnum (1- ,size))) - (inst addu alloc-tn alloc-tn temp) - (inst sll temp temp - (- vm:type-bits vm:word-shift)) - (inst or temp temp ,header) - (storew temp result 0 ,lowtag) - (inst addu alloc-tn alloc-tn - (+ (fixnum 1) vm:lowtag-mask)) - (inst li temp (lognot vm:lowtag-mask)) - (inst and alloc-tn alloc-tn temp))) - (variable-length - (error ":REST-P T with no header in ~S?" - (vm:primitive-object-name obj))) - (header - `((inst addu alloc-tn alloc-tn - (vm:pad-data-block ,size)) - (inst li temp - ,(logior (ash (1- size) vm:type-bits) - (if (integerp header) - header - 0))) - (storew temp result 0 ,lowtag))) - (t - `((inst addu alloc-tn alloc-tn - (vm:pad-data-block ,size))))) - ,@(when need-unbound-marker - `((inst li temp vm:unbound-marker-type))) - ,@(init-forms) - (move real-result result)))))))) - (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) - (: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 obj-temp object) - (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type) - (let ((err-lab (generate-error-code di:unbound-symbol-error obj-temp))) - (inst xor temp value vm:unbound-marker-type) - (inst beq temp zero-tn err-lab) - (inst nop)))) - -;;; 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 - (move obj-temp object) - (loadw value obj-temp vm:symbol-function-slot vm:other-pointer-type) - (let ((err-lab (generate-error-code di:undefined-symbol-error obj-temp))) - (test-simple-type value temp err-lab t vm:function-pointer-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 vm:symbol-value-slot vm:other-pointer-type) - (inst xor temp value vm:unbound-marker-type) - (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target)) - (inst nop))) - - -;;; 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-simple-type value temp target not-p vm:function-pointer-type))) - -#+nil -(def-source-transform makunbound (x) - `(set ,x (%primitive make-immediate-type 0 system:%trap-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)) - - -;;; 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 addu 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 addu 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 beq where bsp-tn done) - (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) - - (emit-label loop) - (inst beq symbol zero-tn skip) - (loadw value bsp-tn (- vm:binding-symbol-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 addu bsp-tn bsp-tn (* -2 vm:word-bytes)) - (inst bne where bsp-tn loop) - (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) - - (emit-label done)))) - - - -;;;; Structure hackery: - -;;; ### This is only necessary until we get real structures up and running. - -(define-vop (structure-ref slot-ref) - (:variant vm:vector-data-offset vm:other-pointer-type)) - -(define-vop (structure-set slot-set) - (:variant vm:vector-data-offset vm:other-pointer-type)) - -(define-vop (structure-index-ref word-index-ref) - (:variant vm:vector-data-offset vm:other-pointer-type)) - -(define-vop (structure-index-set word-index-set) - (:variant vm:vector-data-offset vm:other-pointer-type)) - - - - -;;;; Extra random indexers. - -(define-vop (code-constant-set word-index-set) - (:variant vm:code-constants-offset vm:other-pointer-type)) - diff --git a/compiler/mips/char.lisp b/compiler/mips/char.lisp deleted file mode 100644 index bbae99358b424b98e70ad2d4c76ee7a0e24d614b..0000000000000000000000000000000000000000 --- a/compiler/mips/char.lisp +++ /dev/null @@ -1,130 +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/mips/char.lisp,v 1.6 1990/04/24 02:56:01 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 "C") - - - -;;;; Moves and coercions: - -;;; Move a tagged char to an untagged representation. -;;; -(define-vop (move-to-base-character) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (base-character-reg))) - (:generator 1 - (inst srl y x vm:type-bits))) -;;; -(define-move-vop move-to-base-character :move - (any-reg descriptor-reg) (base-character-reg)) - - -;;; Move an untagged char to a tagged representation. -;;; -(define-vop (move-from-base-character) - (:args (x :scs (base-character-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:generator 1 - (inst sll y x vm:type-bits) - (inst or y y vm:base-character-type))) -;;; -(define-move-vop move-from-base-character :move - (base-character-reg) (any-reg descriptor-reg)) - -;;; Move untagged base-character values. -;;; -(define-vop (base-character-move) - (:args (x :target y - :scs (base-character-reg) - :load-if (not (location= x y)))) - (:results (y :scs (base-character-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move y x))) -;;; -(define-move-vop base-character-move :move - (base-character-reg) (base-character-reg)) - - -;;; Move untagged base-character arguments/return-values. -;;; -(define-vop (move-base-character-argument) - (:args (x :target y - :scs (base-character-reg)) - (fp :scs (descriptor-reg) - :load-if (not (sc-is y base-character-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (base-character-reg - (move y x)) - (base-character-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-base-character-argument :move-argument - (any-reg descriptor-reg base-character-reg) (base-character-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-character -;;; to a descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (base-character-reg) (any-reg descriptor-reg)) - - - -;;;; Other operations: - -(define-vop (char-code) - (:args (ch :scs (base-character-reg) :target res)) - (:results (res :scs (any-reg descriptor-reg))) - (:arg-types base-character) - (:translate char-code) - (:policy :fast-safe) - (:generator 0 - (inst sll res ch 2))) - -(define-vop (code-char) - (:args (code :scs (any-reg descriptor-reg) :target res)) - (:results (res :scs (base-character-reg))) - (:result-types base-character) - (:translate code-char) - (:policy :fast-safe) - (:generator 0 - (inst srl res code 2))) - - -;;; Comparison of base-characters. -;;; -(define-vop (base-character-compare pointer-compare) - (:args (x :scs (base-character-reg)) - (y :scs (base-character-reg))) - (:arg-types base-character base-character)) - -(define-vop (fast-char=/base-character base-character-compare) - (:translate char=) - (:variant :eq)) - -(define-vop (fast-char</base-character base-character-compare) - (:translate char<) - (:variant :lt)) - -(define-vop (fast-char>/base-character base-character-compare) - (:translate char>) - (:variant :gt)) - diff --git a/compiler/mips/insts.lisp b/compiler/mips/insts.lisp deleted file mode 100644 index 0392734b1e8231000693b482ecdeeed77222f994..0000000000000000000000000000000000000000 --- a/compiler/mips/insts.lisp +++ /dev/null @@ -1,517 +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/compiler/mips/insts.lisp,v 1.16 1990/05/06 05:24:32 wlott Exp $ -;;; -;;; Description of the MIPS architecture. -;;; -;;; Written by William Lott -;;; - -(in-package "MIPS") -(use-package "ASSEM") - -(import '(c::tn-p c::tn-sc c::tn-offset c::sc-sb c::sb-name c::zero-tn - c::registers c::float-registers - c::component-header-length)) - - -;;;; Resources. - -(define-random-resources high low) -(define-register-file ireg 32) -(define-register-file fpreg 32) - - -;;;; Formats. - -(defconstant special-op #b000000) -(defconstant bcond-op #b0000001) -(defconstant cop0-op #b010000) -(defconstant cop1-op #b010001) -(defconstant cop2-op #b010010) -(defconstant cop3-op #b010011) - - -(define-format (immediate 32) - (op (byte 6 26)) - (rs (byte 5 21) :use ireg) - (rt (byte 5 16) :clobber ireg) - (immediate (byte 16 0))) - -(define-format (jump 32) - (op (byte 6 26)) - (target (byte 26 0))) - -(define-format (register 32) - (op (byte 6 26)) - (rs (byte 5 21) :use ireg) - (rt (byte 5 16) :use ireg) - (rd (byte 5 11) :clobber ireg) - (shamt (byte 5 6) :default 0) - (funct (byte 6 0))) - - - -(define-format (break 32) - (op (byte 6 26) :default special-op) - (code (byte 10 16)) - (subcode (byte 10 6) :default 0) - (funct (byte 6 0) :default #b001101)) - - - -;;;; Special argument types and fixups. - -(defun register-p (object) - (and (tn-p object) - (eq (sb-name (sc-sb (tn-sc object))) 'registers))) - -(define-argument-type register - :type (satisfies register-p) - :function tn-offset) - -(defun fp-reg-p (object) - (and (tn-p object) - (eq (sb-name (sc-sb (tn-sc object))) - 'float-registers))) - -(define-argument-type fp-reg - :type (satisfies fp-reg-p) - :function tn-offset) - - - -(defun label-offset (label) - (1- (ash (- (label-position label) *current-position*) -2))) - -(define-argument-type relative-label - :type label - :function label-offset) - - -(define-fixup-type :jump) -(define-fixup-type :lui) -(define-fixup-type :addi) - - - -;;;; Instructions. - - -(defmacro define-math-inst (name r3 imm &optional imm-type function fixup) - `(define-instruction (,name) - ,@(when imm - `((immediate (op :constant ,imm) - (rt :argument register) - (rs :same-as rt) - (immediate :argument (,(case imm-type - (:signed 'signed-byte) - (:unsigned 'unsigned-byte)) - 16) - ,@(when function - `(:function ,function)))) - (immediate (op :constant ,imm) - (rt :argument register) - (rs :argument register) - (immediate :argument (,(case imm-type - (:signed 'signed-byte) - (:unsigned 'unsigned-byte)) - 16) - ,@(when function - `(:function ,function)))))) - ,@(when (and imm fixup) - `((immediate (op :constant ,imm) - (rt :argument register) - (rs :same-as rt) - (immediate :argument addi-fixup)) - (immediate (op :constant ,imm) - (rt :argument register) - (rs :argument register) - (immediate :argument addi-fixup)))) - ,@(when r3 - `((register (op :constant special-op) - (rd :argument register) - (rs :argument register) - (rt :argument register) - (funct :constant ,r3)) - (register (op :constant special-op) - (rd :argument register) - (rs :same-as rd) - (rt :argument register) - (funct :constant ,r3)))))) - -(define-math-inst add #b100000 #b001000 :signed) -(define-math-inst addu #b100001 #b001001 :signed nil t) -(define-math-inst sub #b100010 #b001000 :signed -) -(define-math-inst subu #b100011 #b001001 :signed -) -(define-math-inst and #b100100 #b001100 :unsigned) -(define-math-inst or #b100101 #b001101 :unsigned) -(define-math-inst xor #b100110 #b001110 :unsigned) -(define-math-inst nor #b100111 #b001111 :unsigned) - -(define-math-inst slt #b101010 #b001010 :signed) -(define-math-inst sltu #b101011 #b001011 :signed) - -(define-instruction (beq) - (immediate (op :constant #b000100) - (rs :argument register) - (rt :constant 0) - (immediate :argument relative-label)) - (immediate (op :constant #b000100) - (rs :argument register) - (rt :argument register) - (immediate :argument relative-label))) - -(define-instruction (bne) - (immediate (op :constant #b000101) - (rs :argument register) - (rt :constant 0) - (immediate :argument relative-label)) - (immediate (op :constant #b000101) - (rs :argument register) - (rt :argument register) - (immediate :argument relative-label))) - -(define-instruction (blez) - (immediate (op :constant #b000110) - (rs :argument register) - (rt :constant 0) - (immediate :argument relative-label))) - -(define-instruction (bgtz) - (immediate (op :constant #b000111) - (rs :argument register) - (rt :constant 0) - (immediate :argument relative-label))) - -(define-instruction (bltz) - (immediate (op :constant bcond-op) - (rs :argument register) - (rt :constant #b00000) - (immediate :argument relative-label))) - -(define-instruction (bgez) - (immediate (op :constant bcond-op) - (rs :argument register) - (rt :constant #b00001) - (immediate :argument relative-label))) - -(define-instruction (bltzal) - (immediate (op :constant bcond-op) - (rs :argument register) - (rt :constant #b01000) - (immediate :argument relative-label))) - -(define-instruction (bgezal) - (immediate (op :constant bcond-op) - (rs :argument register) - (rt :constant #b01001) - (immediate :argument relative-label))) - -(define-instruction (break) - (break (code :argument (unsigned-byte 10))) - (break (code :argument (unsigned-byte 10)) - (subcode :argument (unsigned-byte 10)))) - -(define-instruction (div :clobber (low high)) - (register (op :constant special-op) - (rs :argument register) - (rt :argument register) - (rd :constant 0) - (funct :constant #b011010))) - -(define-instruction (divu :clobber (low high)) - (register (op :constant special-op) - (rs :argument register) - (rt :argument register) - (rd :constant 0) - (funct :constant #b011011))) - -(define-instruction (j) - (register (op :constant special-op) - (rs :argument register) - (rt :constant 0) - (rd :constant 0) - (funct :constant #b001000)) - (jump (op :constant #b000010) - (target :argument jump-fixup))) - -(define-instruction (jal) - (register (op :constant special-op) - (rs :argument register) - (rt :constant 0) - (rd :constant 31) - (funct :constant #b001001)) - (register (op :constant special-op) - (rd :argument register) - (rs :argument register) - (rt :constant 0) - (funct :constant #b001001)) - (jump (op :constant #b000011) - (target :argument jump-fixup))) - - -(defmacro define-load/store-instruction (name op) - `(define-instruction (,name) - (immediate (op :constant ,op) - (rt :argument register) - (rs :argument register) - (immediate :argument (signed-byte 16))) - (immediate (op :constant ,op) - (rt :argument register) - (rs :argument register) - (immediate :argument addi-fixup)) - (immediate (op :constant ,op) - (rt :argument register) - (rs :argument register) - (immediate :constant 0)))) - -(define-load/store-instruction lb #b100000) -(define-load/store-instruction lh #b100001) -(define-load/store-instruction lwl #b100010) -(define-load/store-instruction lw #b100011) -(define-load/store-instruction lbu #b100100) -(define-load/store-instruction lhu #b100101) -(define-load/store-instruction lwr #b100110) -(define-load/store-instruction sb #b101000) -(define-load/store-instruction sh #b101001) -(define-load/store-instruction swl #b101010) -(define-load/store-instruction sw #b101011) -(define-load/store-instruction swr #b101110) - -(define-instruction (lui) - (immediate (op :constant #b001111) - (rs :constant 0) - (rt :argument register) - (immediate :argument (or (unsigned-byte 16) (signed-byte 16)))) - (immediate (op :constant #b001111) - (rs :constant 0) - (rt :argument register) - (immediate :argument lui-fixup))) - - -(define-instruction (mfhi :use high) - (register (op :constant special-op) - (rd :argument register) - (rs :constant 0) - (rt :constant 0) - (funct :constant #b010000))) - -(define-instruction (mthi :clobber high) - (register (op :constant special-op) - (rd :argument register) - (rs :constant 0) - (rt :constant 0) - (funct :constant #b010001))) - -(define-instruction (mflo :use low) - (register (op :constant special-op) - (rd :argument register) - (rs :constant 0) - (rt :constant 0) - (funct :constant #b010010))) - -(define-instruction (mtlo :clobber low) - (register (op :constant special-op) - (rd :argument register) - (rs :constant 0) - (rt :constant 0) - (funct :constant #b010011))) - - -(define-instruction (mult :clobber (low high)) - (register (op :constant special-op) - (rs :argument register) - (rt :argument register) - (rd :constant 0) - (funct :constant #b011000))) - -(define-instruction (multu :clobber (low high)) - (register (op :constant special-op) - (rs :argument register) - (rt :argument register) - (rd :constant 0) - (funct :constant #b011001))) - -(define-instruction (sll) - (register (op :constant special-op) - (rd :argument register) - (rt :argument register) - (rs :constant 0) - (shamt :argument (unsigned-byte 5)) - (funct :constant #b000000)) - (register (op :constant special-op) - (rd :argument register) - (rt :same-as rd) - (rs :constant 0) - (shamt :argument (unsigned-byte 5)) - (funct :constant #b000000)) - (register (op :constant special-op) - (rd :argument register) - (rt :argument register) - (rs :argument register) - (funct :constant #b000100)) - (register (op :constant special-op) - (rd :argument register) - (rt :same-as rd) - (rs :argument register) - (funct :constant #b000100))) - -(define-instruction (sra) - (register (op :constant special-op) - (rd :argument register) - (rt :argument register) - (rs :constant 0) - (shamt :argument (unsigned-byte 5)) - (funct :constant #b000011)) - (register (op :constant special-op) - (rd :argument register) - (rt :same-as rd) - (rs :constant 0) - (shamt :argument (unsigned-byte 5)) - (funct :constant #b000011)) - (register (op :constant special-op) - (rd :argument register) - (rt :argument register) - (rs :argument register) - (funct :constant #b000111)) - (register (op :constant special-op) - (rd :argument register) - (rt :same-as rd) - (rs :argument register) - (funct :constant #b000111))) - -(define-instruction (srl) - (register (op :constant special-op) - (rd :argument register) - (rt :argument register) - (rs :constant 0) - (shamt :argument (unsigned-byte 5)) - (funct :constant #b000010)) - (register (op :constant special-op) - (rd :argument register) - (rt :same-as rd) - (rs :constant 0) - (shamt :argument (unsigned-byte 5)) - (funct :constant #b000010)) - (register (op :constant special-op) - (rd :argument register) - (rt :argument register) - (rs :argument register) - (funct :constant #b000110)) - (register (op :constant special-op) - (rd :argument register) - (rt :same-as rd) - (rs :argument register) - (funct :constant #b000110))) - -(define-instruction (syscall) - (register (op :constant special-op) - (rd :constant 0) - (rt :constant 0) - (rs :constant 0) - (funct :constant #b001100))) - - - -;;;; Pseudo-instructions - -(define-pseudo-instruction li 64 (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 - #+new-compiler (ldb (byte 16 16) value) - #-new-compiler (logand #xffff (ash value -16))) - (let ((low (ldb (byte 16 0) value))) - (unless (zerop low) - (inst or reg low)))) - (fixup - (inst lui reg value) - (inst addu reg value)))) - -(define-instruction (b) - (immediate (op :constant #b000100) - (rs :constant 0) - (rt :constant 0) - (immediate :argument relative-label))) - -(define-instruction (nop) - (register (op :constant 0) - (rd :constant 0) - (rt :constant 0) - (rs :constant 0) - (funct :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))))) - - - -;;;; 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 #x5e))) - -(define-instruction (lra-header-word) - (header-object (type :constant #x66))) - - -(defmacro define-compute-instruction (name calculation) - `(progn - (defun ,name (label) - ,calculation) - (define-instruction (,name) - (immediate (op :constant #b001001) - (rt :argument register) - (rs :argument register) - (immediate :argument label - :function ,name))))) - -;; code = fn - fn-tag - header - label-offset + other-pointer-tag -(define-compute-instruction compute-code-from-fn - (- vm:other-pointer-type - vm:function-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))) - diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp deleted file mode 100644 index da137c9111f232ca2893f6cc9ec7c76799f88a02..0000000000000000000000000000000000000000 --- a/compiler/mips/macros.lisp +++ /dev/null @@ -1,495 +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/mips/macros.lisp,v 1.31 1990/05/18 07:06:36 wlott Exp $ -;;; -;;; This file contains various useful macros for generating MIPS code. -;;; -;;; Written by William Lott and Christopher Hoover. -;;; - -(in-package "C") - -;;; 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 addu ,n-dst ,n-src zero-tn) - `(unless (location= ,n-dst ,n-src) - (inst addu ,n-dst ,n-src zero-tn))))) - -(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) - - -(defmacro load-symbol (reg symbol) - `(inst add ,reg null-tn (vm: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) - `(progn - (inst lw ,reg null-tn - (+ (vm:static-symbol-offset ',symbol) - (ash ,',offset vm:word-shift) - (- vm:other-pointer-type))) - (inst nop))) - (defmacro ,storer (reg symbol) - `(inst sw ,reg null-tn - (+ (vm:static-symbol-offset ',symbol) - (ash ,',offset vm:word-shift) - (- vm: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 vm:target-byte-order - (: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. - -(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))) - -(defmacro lisp-return (return-pc lip) - "Return to RETURN-PC. LIP is an interior-reg temporary." - `(progn - (inst addu ,lip ,return-pc (- vm:word-bytes vm:other-pointer-type)) - (inst j ,lip) - (move code-tn ,return-pc))) - -(defmacro emit-return-pc (label) - "Emit a return-pc header word. LABEL is the label to use for this return-pc." - `(progn - (align vm: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 fp-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 fp-tn offset)))))) - - -;;;; Three Way Comparison - -(defmacro three-way-comparison (x y condition flavor not-p target temp) - (once-only ((n-x x) - (n-y y) - (n-condition condition) - (n-flavor flavor) - (n-not-p not-p) - (n-target target) - (n-temp temp)) - `(progn - (ecase ,n-condition - (:eq - (if ,n-not-p - (inst bne ,n-x ,n-y ,n-target) - (inst beq ,n-x ,n-y ,n-target))) - (:lt - (ecase ,n-flavor - (:unsigned - (inst sltu ,n-temp ,n-x ,n-y)) - (:signed - (inst slt ,n-temp ,n-x ,n-y))) - (if ,n-not-p - (inst beq ,n-temp zero-tn ,n-target) - (inst bne ,n-temp zero-tn ,n-target))) - (:gt - (ecase ,n-flavor - (:unsigned - (inst sltu ,n-temp ,n-y ,n-x)) - (:signed - (inst slt ,n-temp ,n-y ,n-x))) - (if ,n-not-p - (inst bne ,n-temp zero-tn ,n-target) - (inst beq ,n-temp zero-tn ,n-target)))) - (inst nop)))) - - -;;;; Simple Type Checking Macros - -(defmacro simple-test-tag (register temp target not-p tag-type tag-mask) - `(progn - (unless (zerop ,tag-mask) - (inst and ,temp ,register ,tag-mask)) - (inst xor ,temp ,temp ,tag-type) - (if ,not-p - (inst bne ,temp zero-tn ,target) - (inst beq ,temp zero-tn ,target)) - (inst nop))) - -(defmacro simple-test-simple-type (register temp target not-p type-code) - "Emit conditional code that test whether Register holds an object with - the tag specificed if Tag-Type. Temp should be an unboxed register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p) - (n-type-code type-code)) - `(cond ((< ,n-type-code vm:lowtag-limit) - (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,n-type-code lowtag-mask)) - (t - ;; Nothing clever in this version. Assume other-immediate - ;; type is already in register. - ;; - (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p - ,n-type-code type-mask))))) - -(defmacro test-simple-type (register temp target not-p type-code) - "Emit conditional code that test whether Register holds an object with - the tag specificed if Tag-Type. If the Tag-Type is a type for a heap - object than the register is dereferencd and the heap object is - checked. Temp should be an unboxed register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p) - (n-type-code type-code)) - `(cond ((< ,n-type-code vm:lowtag-limit) - (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,n-type-code vm:lowtag-mask)) - ((or (= ,n-type-code vm:base-character-type) - (= ,n-type-code vm:unbound-marker-type)) - (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,n-type-code vm:type-mask)) - (t - (let* ((out-label (gen-label)) - (not-other-label (if ,n-not-p ,n-target out-label))) - (simple-test-tag ,n-register ,n-temp not-other-label t - vm:other-pointer-type vm:lowtag-mask) - (load-type ,n-temp ,n-register (- vm:other-pointer-type)) - (inst nop) - (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p - ,n-type-code 0) - (emit-label out-label)))))) - - -;;;; Hairy Type Checking Macros - -(defun canonicalize-type-codes (type-codes &optional (shift 0)) - (unless type-codes (return-from canonicalize-type-codes nil)) - (let* ((type-codes (sort (remove-duplicates type-codes) #'<)) - (canonical-type-codes nil) - (first-type-code (pop type-codes)) - (last-type-code (ash first-type-code shift)) - (range-start first-type-code) - (range-end nil)) - (dolist (type-code type-codes) - (let ((shifted-type-code (ash type-code shift))) - (cond ((= last-type-code (1- shifted-type-code)) - (setf range-end type-code)) - (t - (push (if range-end (cons range-start range-end) range-start) - canonical-type-codes) - (setf range-start type-code) - (setf range-end nil))) - (setf last-type-code shifted-type-code))) - (push (if range-end (cons range-start range-end) range-start) - canonical-type-codes) - (nreverse canonical-type-codes))) - -(defmacro hairy-test-tag (register temp target not-p tag-types tag-mask) - (let ((in-label (gensym)) - (out-label (gensym))) - (collect ((emit)) - (macrolet ((frob (value) - `(let ((diff (+ (- ,value) last-type-code))) - (unless (zerop diff) - (emit `(inst add ,temp ,temp ,diff)) - (setf last-type-code ,value))))) - (do* ((types tag-types (cdr types)) - (type (car types) (car types)) - (last-type-check-p (null (cdr types)) (null (cdr types))) - (last-type-code 0)) - ((null types)) - (cond ((consp type) - (let ((low (car type)) - (high (cdr type))) - (frob low) - (emit `(inst bltz ,temp ,out-label)) - (frob high) - (cond (last-type-check-p - (emit `(if ,not-p - (inst bgtz ,temp ,target) - (inst blez ,temp ,target)))) - (t - (emit `(inst blez ,temp ,in-label)))))) - (t - (frob type) - (cond (last-type-check-p - (emit `(if ,not-p - (inst bne ,temp zero-tn ,target) - (inst beq ,temp zero-tn ,target)))) - (t - (emit `(inst beq ,temp zero-tn ,in-label)))))))) - `(let* ((drop-through (gen-label)) - (,in-label (if ,not-p drop-through ,target)) - (,out-label (if ,not-p ,target drop-through))) - ,in-label ; squelch possible warning - ,out-label - (unless (zerop ,tag-mask) - (inst and ,temp ,register ,tag-mask)) - ,@(emit) - (inst nop) - (emit-label drop-through))))) - -(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. All low tag type codes will be checked first. Then the - pointer will be checked to see if it is an other-pointer-type type - pointer in which case it will be dereferenced and the remaining type - codes (the header word type codes) will be checked. All of the - type-code expressions are evaluated at macroexpand time. Temp should - be an unboxed register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p)) - (unless types (error "Must specify at least one type.")) - ;; - ;; Partition the type codes. - (collect ((low-tag-types) - (header-word-types)) - (dolist (type types) - (let ((type (eval type))) - (cond ((< type vm:lowtag-limit) - (low-tag-types type)) - (t - (header-word-types type))))) - - (let ((low-tag-types (canonicalize-type-codes (low-tag-types))) - (header-word-types (canonicalize-type-codes - (header-word-types) (- (1- lowtag-bits))))) - ;; - ;; Generate code - `(let* ((out-label (gen-label)) - (in-low-tag-label (if ,n-not-p out-label ,n-target)) - (not-other-label (if ,n-not-p ,n-target out-label))) - in-low-tag-label ; may not be used -- squelch warning - not-other-label - ,@(when low-tag-types - (if header-word-types - `((hairy-test-tag ,n-register ,n-temp in-low-tag-label nil - ,low-tag-types vm:lowtag-mask)) - `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,low-tag-types vm:lowtag-mask)))) - ,@(when header-word-types - `((simple-test-tag ,n-register ,n-temp not-other-label t - vm:other-pointer-type vm:lowtag-mask) - (load-type ,n-temp ,n-register (- vm:other-pointer-type)) - (inst nop) - (hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,header-word-types 0))) - (emit-label out-label)))))) - -(defmacro simple-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. The type codes must either be all low tag codes or all - header word tag 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 should be an unboxed register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p)) - (unless types (error "Must specify at least one type.")) - ;; - ;; Partition the type codes. - (collect ((low-tag-types) - (header-word-types)) - (dolist (type types) - (cond ((< type vm:lowtag-limit) - (low-tag-types type)) - (t - (header-word-types type)))) - (let ((low-tag-types (low-tag-types)) - (header-word-types (header-word-types))) - (cond ((and low-tag-types header-word-types) - (error "SIMPLE-TEST-HAIRY-TYPE cannot check both low tag ~ - types and other-pointer-type tag types.")) - (low-tag-types - `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p - ,(canonicalize-type-codes low-tag-types) - vm:lowtag-mask))) - (header-word-types - `(progn - (inst srl ,n-temp ,n-register vm:lowtag-bits) - (hairy-test-tag ,n-temp ,n-temp ,n-target ,n-not-p - ,(canonicalize-type-codes header-word-types) - vm:type-mask))) - (t - (error "Lost big. Should not be here."))))))) - - -;;;; Test-Special-Value - -;;; ### We may want this. - -#+nil -(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))))) - - -;;;; Error Code - -(eval-when (compile load eval) - (defun emit-error-break (kind code values) - `((inst break ,kind) - (inst byte ,code) - ,@(mapcar #'(lambda (tn) - `(let ((tn ,tn)) - (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) - (inst byte (tn-offset tn)))) - values) - (inst byte 0) - (align vm:word-shift)))) - -(defmacro error-call (error-code &rest values) - "Cause an error. ERROR-CODE is the error to cause." - (cons 'progn - (emit-error-break vm:error-trap error-code values))) - - -(defmacro cerror-call (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 vm:cerror-trap error-code values))) - -(defmacro generate-error-code (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 ,error-code ,@values) - start-lab))) - -(defmacro generate-cerror-code (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 ,continue ,error-code ,@values) - ,error))))) - -;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. -;;; -(defmacro pseudo-atomic ((ndescr-temp) &rest forms) - (let ((label (gensym "LABEL-"))) - `(let ((,label (gen-label))) - (inst and flags-tn flags-tn (logxor (ash 1 interrupted-flag) #Xffff)) - (inst or flags-tn flags-tn (ash 1 atomic-flag)) - ,@forms - (inst and flags-tn flags-tn (logxor (ash 1 atomic-flag) #Xffff)) - (inst and ,ndescr-temp flags-tn (ash 1 interrupted-flag)) - (inst beq ,ndescr-temp zero-tn ,label) - (inst nop) - (inst break vm:pending-interrupt-trap) - (emit-label ,label)))) diff --git a/compiler/mips/memory.lisp b/compiler/mips/memory.lisp deleted file mode 100644 index 2a8447194fe45d1f95c4fb2bb1bf179eb70c6cfc..0000000000000000000000000000000000000000 --- a/compiler/mips/memory.lisp +++ /dev/null @@ -1,149 +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/mips/memory.lisp,v 1.7 1990/04/24 02:56:11 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 "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 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))) -;;; -(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 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 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. 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)) - (index :scs (any-reg descriptor-reg immediate negative-immediate)) - ,@(when write-p - '((value :scs (any-reg descriptor-reg) :target result)))) - (:temporary (:scs (interior-reg) :type interior) lip) - ,@(unless (zerop shift) - `((:temporary (:scs (non-descriptor-reg) :type random) temp))) - (:results (,(if write-p 'result 'value) - :scs (any-reg descriptor-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 5 - (sc-case index - ((immediate negative-immediate) - (inst ,op value object - (- (+ (ash (tn-value index) (- word-shift ,shift)) - (ash offset word-shift)) - lowtag)) - ,(if write-p - '(move result value) - '(inst nop))) - (t - ,@(if (zerop shift) - `((inst addu lip object index)) - `((inst srl temp index ,shift) - (inst addu lip temp object))) - (inst ,op value lip (- (ash offset word-shift) lowtag)) - ,(if write-p - '(move result value) - '(inst nop))))))) - -(define-indexer word-index-ref nil lw 0) -(define-indexer word-index-set t sw 0) -(define-indexer halfword-index-ref nil lhu 1) -(define-indexer signed-halfword-index-ref nil lh 1) -(define-indexer halfword-index-set t sh 1) -(define-indexer byte-index-ref nil lbu 2) -(define-indexer signed-byte-index-ref nil lb 2) -(define-indexer byte-index-set t sb 2) - 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 f43ad888295e9997510ba24b0d296c7387192359..0000000000000000000000000000000000000000 --- a/compiler/mips/move.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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.15 1990/05/11 06:52:03 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 "C") - - -(define-move-function (load-immediate 1) (vop x y) - ((null unsigned-immediate immediate zero negative-immediate - random-immediate immediate-base-character immediate-sap) - (any-reg descriptor-reg base-character-reg sap-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-character-type)))))) - -(define-move-function (load-number 1) (vop x y) - ((null unsigned-immediate immediate zero negative-immediate random-immediate) - (signed-reg unsigned-reg)) - (inst li y (tn-value x))) - -(define-move-function (load-base-character 1) (vop x y) - ((immediate-base-character) (base-character-reg)) - (inst li y (char-code (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-character-stack) (base-character-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 (load-single 5) (vop x y) - ((single-stack) (single-reg)) - (cerror "Do nothing." "Not yet." x y)) - -(define-move-function (load-double 7) (vop x y) - ((double-stack) (double-reg)) - (cerror "Do nothing." "Not yet." x y)) - -(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-character-reg) (base-character-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)))) - -(define-move-function (store-single 5) (vop x y) - ((single-reg) (single-stack)) - (cerror "Do nothing." "Not yet." x y)) - -(define-move-function (store-double 7) (vop x y) - ((double-reg) (double-stack)) - (cerror "Do nothing." "Not yet." x 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 (descriptor-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) - (:generator 666 - (error-call di:object-not-type-error x type))) - - - -;;;; Moves and coercions: - -;;; Move a tagged number to an untagged representation. -;;; -(define-vop (move-to-signed/unsigned) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 4 - (sc-case x - (any-reg - (inst sra y x 2)) - (descriptor-reg - (let ((done (gen-label))) - (inst and temp x 3) - (inst beq temp done) - (sc-case y - (signed-reg - (inst sra y x 2)) - (unsigned-reg - (inst srl y x 2))) - - (loadw y x vm:bignum-digits-offset vm:other-pointer-type) - - (emit-label done)))))) - -;;; -(define-move-vop move-to-signed/unsigned :move - (any-reg descriptor-reg) (signed-reg unsigned-reg)) - - -;;; Move an untagged number to a tagged representation. -;;; -(define-vop (move-from-signed/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) - (:generator 20 - (sc-case y - (any-reg - ;; The results must be a fixnum, so we can just do the shift. - (inst sll y arg 2)) - (descriptor-reg - ;; The results might be a bignum, so we have to make sure. - (move x arg) - (sc-case arg - (signed-reg - (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) - - (pseudo-atomic (temp) - (inst addu y alloc-tn vm:other-pointer-type) - (inst addu alloc-tn - (vm:pad-data-block (1+ vm:bignum-digits-offset))) - (inst li temp (logior (ash 1 vm:type-bits) vm:bignum-type)) - (storew temp y 0 vm:other-pointer-type) - (storew x y vm:bignum-digits-offset vm:other-pointer-type)) - (inst b done) - (inst nop) - - (emit-label fixnum) - (inst sll y x 2) - (emit-label done))) - (unsigned-reg - (let ((done (gen-label)) - (one-word (gen-label))) - (inst sra temp x 29) - (inst beq temp done) - (inst sll y x 2) - - (pseudo-atomic (temp) - (inst addu y alloc-tn vm:other-pointer-type) - (inst addu alloc-tn - (vm:pad-data-block (1+ vm:bignum-digits-offset))) - (inst bgez x one-word) - (inst li temp (logior (ash 1 vm:type-bits) vm:bignum-type)) - (inst addu alloc-tn (vm:pad-data-block 1)) - (inst li temp (logior (ash 2 vm:type-bits) vm:bignum-type)) - (emit-label one-word) - (storew temp y 0 vm:other-pointer-type) - (storew x y vm:bignum-digits-offset vm:other-pointer-type)) - (emit-label done)))))))) - -;;; -(define-move-vop move-from-signed/unsigned :move - (signed-reg unsigned-reg) (any-reg descriptor-reg)) - - -;;; Move untagged numbers. -;;; -(define-vop (signed/unsigned-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) - (:generator 1 - (move y x))) -;;; -(define-move-vop signed/unsigned-move :move - (signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Move untagged number arguments/return-values. -;;; -(define-vop (move-signed/unsigned-argument) - (:args (x :target y - :scs (signed-reg unsigned-reg)) - (fp :scs (any-reg descriptor-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (: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-signed/unsigned-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 2df18402b07cf1eeb5f42889c43c1d9c0b343755..0000000000000000000000000000000000000000 --- a/compiler/mips/nlx.lisp +++ /dev/null @@ -1,294 +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/mips/nlx.lisp,v 1.8 1990/04/24 02:56:24 wlott Exp $ -;;; -;;; 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 (sc-number-or-lose 'any-reg)) - 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 5 *any-primitive-type*)) - -(define-vop (save-dynamic-state) - (:results (catch :scs (descriptor-reg)) - (special :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*) - (move special bsp-tn) - (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)) - (special :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg)) - (eval :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) symbol value) - (:vop-var vop) - (:generator 10 - (let ((done (gen-label)) - (skip (gen-label)) - (loop (gen-label))) - - (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) - - (inst beq special bsp-tn done) - (inst nop) - - (emit-label loop) - (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) - (inst beq symbol zero-tn skip) - (loadw value bsp-tn (- binding-value-slot binding-size)) - (storew value symbol vm:symbol-value-slot vm:other-pointer-type) - (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) - (emit-label skip) - (inst addu bsp-tn bsp-tn (* -2 vm:word-bytes)) - (inst bne bsp-tn special loop) - (inst nop) - - (emit-label done)))) - -(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 (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :target block) result) - (:generator 22 - (inst addu result fp-tn (* (tn-offset tn) vm:word-bytes)) - (load-symbol-value temp lisp::*current-unwind-protect-block*) - (storew temp result vm:unwind-block-current-uwp-slot) - (storew fp-tn result vm:unwind-block-current-cont-slot) - (storew code-tn result vm:unwind-block-current-code-slot) - (inst compute-lra-from-code temp code-tn entry-label) - (storew temp result vm:catch-block-entry-pc-slot) - (move 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 (descriptor-reg))) - (:info entry-label) - (:results (block :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :target block) result) - (:generator 44 - (inst addu result fp-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 fp-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))) - - -;;; 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 fp-tn (* (tn-offset tn) vm:word-bytes)) - (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) - - -(define-vop (unlink-catch-block) - (:temporary (:scs (descriptor-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 (descriptor-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 :scs (descriptor-reg)) - (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 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)))))) - (move csp-tn sp))) - - -(define-vop (nlx-entry-multiple) - (:args (top :scs (descriptor-reg) :target dst) - (start :target src) - (count :target num)) - (:results (new-start) (new-count)) - (:info label) - (:temporary (:scs (any-reg) :type fixnum :from (:argument 0)) dst) - (:temporary (:scs (any-reg) :type fixnum :from (:argument 1)) src) - (:temporary (:scs (any-reg) :type fixnum :from (:argument 2)) num) - (:temporary (:scs (descriptor-reg)) temp) - (:save-p :force-to-stack) - (:generator 30 - (emit-return-pc label) - (let ((loop (gen-label)) - (done (gen-label))) - - ;; Copy args. - (move dst top) - (move src start) - (move num count) - - ;; Establish results. - (move new-start dst) - (inst beq num zero-tn done) - (move new-count num t) - - ;; Copy stuff on stack. - (emit-label loop) - (loadw temp src) - (inst addu src src (fixnum 1)) - (storew temp dst) - (inst addu num num (fixnum -1)) - (inst bne num zero-tn loop) - (inst addu dst dst (fixnum 1)) - - (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/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/parms.lisp b/compiler/mips/parms.lisp deleted file mode 100644 index 00cec4939e47f85210b87ba44715157634286c09..0000000000000000000000000000000000000000 --- a/compiler/mips/parms.lisp +++ /dev/null @@ -1,562 +0,0 @@ -;;; -*- Package: VM; 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/mips/parms.lisp,v 1.51 1990/05/25 20:04:36 wlott Exp $ -;;; -;;; This file contains some parameterizations of various VM -;;; attributes for the MIPS. 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 "VM") - -(eval-when (compile load eval) - - -;;;; Compiler constants. - -;;; Maximum number of SCs allowed. -;;; -(defconstant sc-number-limit 32) - -;;; The inclusive upper bound on a cost. We want to write cost frobbing -;;; code so that it is portable, but works on fixnums. This constant -;;; should be defined so that adding two costs cannot result in fixnum -;;; overflow. -;;; -(defconstant most-positive-cost (1- (expt 2 20))) - - - -;;;; Machine Architecture parameters: - -(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-byte-order :little-endian - "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).") - -(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.") - -;;; ### This should be somewhere else. -(defconstant native-byte-order :big-endian - "The byte order we are running under.") - - - -;;;; Description of the target address space. - -;;; Where to put the different spaces. -;;; -(defparameter target-read-only-space-start #x20000000) -(defparameter target-static-space-start #x30000000) -(defparameter target-dynamic-space-start #x40000000) - - -;;;; Type definitions: - -(defconstant lowtag-bits 3 - "Number of bits at the low end of a pointer used for type information.") - -(defconstant lowtag-mask (1- (ash 1 lowtag-bits)) - "Mask to extract the low tag bits from a pointer.") - -(defconstant lowtag-limit (ash 1 lowtag-bits) - "Exclusive upper bound on the value of the low tag bits from a - pointer.") - -(defconstant type-bits 8 - "Number of bits used in the header word of a data block for typeing.") - -(defconstant type-mask (1- (ash 1 type-bits)) - "Mask to extract the type from a header word.") - -(defmacro pad-data-block (words) - `(logandc2 (+ (ash ,words vm:word-shift) lowtag-mask) lowtag-mask)) - - -(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)))) - -;;; The main types. These types are represented by the low three bits of the -;;; pointer or immeditate object. -;;; -(defenum (:suffix -type) - even-fixnum - function-pointer - other-immediate-0 - list-pointer - odd-fixnum - structure-pointer - other-immediate-1 - other-pointer) - -;;; The heap types. Each of these types is in the header of objects in -;;; the heap. -;;; -(defenum (:suffix -type - :start (+ (ash 1 lowtag-bits) other-immediate-0-type) - :step (ash 1 (1- lowtag-bits))) - bignum - ratio - single-float - double-float - complex - - simple-array - simple-string - simple-bit-vector - simple-vector - simple-array-unsigned-byte-2 - simple-array-unsigned-byte-4 - simple-array-unsigned-byte-8 - simple-array-unsigned-byte-16 - simple-array-unsigned-byte-32 - simple-array-single-float - simple-array-double-float - complex-string - complex-bit-vector - complex-vector - complex-array - - code-header - function-header - closure-function-header - return-pc-header - closure-header - value-cell-header - symbol-header - base-character - sap - unbound-marker - weak-pointer) - - -;;;; Other non-type constants. - -(defenum (:suffix -flag) - atomic - interrupted) - -(defenum (:suffix -trap :start 8) - halt - pending-interrupt - error - cerror) - -(defenum (:prefix vector- :suffix -subtype) - normal - structure - valid-hashing - must-rehash) - - - -;;;; Primitive data objects definition noise. - - -(defstruct (slot - (:constructor %make-slot - (name docs rest-p length options))) - (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)) - -(defun make-slot (name &rest options - &key docs rest-p (length (if rest-p 0 1)) - &allow-other-keys) - (remf options :docs) - (remf options :rest-p) - (remf options :length) - (%make-slot name docs rest-p length options)) - -(defstruct (primitive-object - ) - (name nil :type symbol) - (header nil :type (or (member t nil) fixnum)) - (lowtag nil :type (or null fixnum)) - (options nil :type list) - (slots nil :type list) - (size 0 :type fixnum) - (variable-length nil :type (member t nil))) - - -(defmacro define-primitive-object ((name &rest options - &key header lowtag - &allow-other-keys) - &rest slots) - (remf options :header) - (remf options :lowtag) - (let ((prim-obj - (eval `(make-primitive-object - :name ',name - :header ,header - :lowtag ,lowtag - :options ',options - :slots (list ,@(mapcar #'(lambda (slot) - (if (atom slot) - `(make-slot ',slot) - `(apply #'make-slot ',slot))) - slots)))))) - (collect ((forms) (exports)) - (let ((offset (if (primitive-object-header prim-obj) 1 0)) - (variable-length nil)) - (dolist (slot (primitive-object-slots prim-obj)) - (when variable-length - (error "~S is anything after a :rest-p t slot." slot)) - (let* ((rest-p (slot-rest-p slot)) - (offset-sym - (intern (concatenate 'simple-string - (string name) - "-" - (string (slot-name slot)) - (if rest-p "-OFFSET" "-SLOT"))))) - (forms `(defconstant ,offset-sym ,offset - ,@(when (slot-docs slot) (list (slot-docs slot))))) - (setf (slot-offset slot) offset) - (exports offset-sym) - (incf offset (slot-length slot)) - (when rest-p (setf variable-length t)))) - (setf (primitive-object-variable-length prim-obj) variable-length) - (unless variable-length - (let ((size (intern (concatenate 'simple-string - (string name) - "-SIZE")))) - (forms `(defconstant ,size ,offset - ,(format nil - "Number of slots used by each ~S~ - ~@[~* including the header~]." - name header))) - (exports size))) - (setf (primitive-object-size prim-obj) offset)) - `(eval-when (compile load eval) - (setf *primitive-objects* - (cons ',prim-obj - (delete ',name *primitive-objects* - :key #'primitive-object-name))) - (export ',(exports)) - ,@(forms))))) - -(defvar *primitive-objects* nil) - -(defmacro define-for-each-primitive-object ((var) &body body) - `(c::expand - `(progn - ,@(remove nil - (mapcar #'(lambda (,var) - ,@body) - *primitive-objects*))))) - - - -;;;; The primitive objects themselves. - - -(define-primitive-object (cons :lowtag list-pointer-type - :alloc-trans cons) - (car :ref-vop car :ref-trans car - :setf-vop c::set-car :set-trans c::%rplaca - :init :arg) - (cdr :ref-vop cdr :ref-trans cdr - :setf-vop c::set-cdr :set-trans c::%rplacd - :init :arg)) - -(define-primitive-object (bignum :lowtag other-pointer-type - :header bignum-type - :alloc-trans bignum::%allocate-bignum) - (digits :rest-p t :c-type "long")) - -(define-primitive-object (ratio :lowtag other-pointer-type - :header ratio-type - :alloc-vop c::make-ratio) - (numerator :ref-vop numerator :init :arg) - (denominator :ref-vop denominator :init :arg)) - -(define-primitive-object (single-float :lowtag other-pointer-type - :header single-float-type) - (value :c-type "float")) - -(define-primitive-object (double-float :lowtag other-pointer-type - :header double-float-type) - (value :c-type "double" :length 2)) - -(define-primitive-object (complex :lowtag other-pointer-type - :header complex-type - :alloc-vop c::make-complex) - (real :ref-vop realpart :init :arg) - (imag :ref-vop imagpart :init :arg)) - -(define-primitive-object (array :lowtag other-pointer-type - :header t) - (fill-pointer :type index - :ref-trans lisp::%array-fill-pointer - :ref-known (c::flushable c::foldable) - :set-trans (setf lisp::%array-fill-pointer) - :set-known (c::unsafe)) - (elements :type index - :ref-trans lisp::%array-available-elements - :ref-known (c::flushable c::foldable) - :set-trans (setf lisp::%array-available-elements) - :set-known (c::unsafe)) - (data :type array - :ref-trans lisp::%array-data-vector - :ref-known (c::flushable c::foldable) - :set-trans (setf lisp::%array-data-vector) - :set-known (c::unsafe)) - (displacement :type (or index null) - :ref-trans lisp::%array-displacement - :ref-known (c::flushable c::foldable) - :set-trans (setf lisp::%array-displacement) - :set-known (c::unsafe)) - (displaced-p :type (member t nil) - :ref-trans lisp::%array-displaced-p - :ref-known (c::flushable c::foldable) - :set-trans (setf lisp::%array-displaced-p) - :set-known (c::unsafe)) - (dimensions :rest-p t)) - -(define-primitive-object (vector :lowtag other-pointer-type :header t) - (length :ref-trans c::vector-length - :ref-known (c::flushable c::foldable)) - (data :rest-p t :c-type "unsigned long")) - -(define-primitive-object (code :lowtag other-pointer-type :header t) - code-size - (entry-points :ref-vop c::code-entry-points - :set-vop c::set-code-entry-points) - (debug-info :type t - :ref-trans di::code-debug-info - :ref-known (c::flushable)) - (constants :rest-p t)) - -(define-primitive-object (function-header :lowtag function-pointer-type - :header function-header-type) - (self :ref-vop c::function-self :set-vop c::set-function-self) - (next :ref-vop c::function-next :set-vop c::set-function-next) - (name :ref-vop c::function-name :set-vop c::set-function-name) - (arglist :ref-vop c::function-arglist :set-vop c::set-function-arglist) - (type :ref-vop c::function-type :set-vop c::set-function-type) - (code :rest-p t :c-type "unsigned char")) - -(define-primitive-object (return-pc :lowtag other-pointer-type :header t) - (return-point :c-type "unsigned char" :rest-p t)) - -(define-primitive-object (closure :lowtag function-pointer-type - :header closure-header-type - :alloc-vop c::make-closure) - (function :init :arg :ref-vop c::closure-function) - (info :rest-p t :set-vop c::closure-init :ref-vop c::closure-ref)) - -(define-primitive-object (value-cell :lowtag other-pointer-type - :header value-cell-header-type - :alloc-vop c::make-value-cell) - (value :set-vop c::value-cell-set - :ref-vop c::value-cell-ref - :init :arg)) - -(define-primitive-object (symbol :lowtag other-pointer-type - :header symbol-header-type - :alloc-trans make-symbol) - (value :set-trans set - :setf-vop set - :init :unbound) - (function :setf-vop c::set-symbol-function - :set-trans c::%sp-set-definition - :init :unbound) - (plist :ref-trans symbol-plist - :setf-vop c::set-symbol-plist - :set-trans c::%sp-set-plist - :init :null) - (name :ref-trans symbol-name - :init :arg) - (package :ref-trans symbol-package - :setf-vop c::set-package - :init :null)) - -(define-primitive-object (sap :lowtag other-pointer-type - :header sap-type) - (pointer :c-type "char *")) - - -(define-primitive-object (weak-pointer :lowtag other-pointer-type - :header weak-pointer-type - :alloc-vop c::make-weak-pointer) - (value :ref-vop c::weak-pointer-value - :setf-vop c::set-weak-pointer-value - :init :arg) - (next :c-type "struct weak_pointer *")) - - -;;; Other non-heap data blocks. - -(define-primitive-object (binding) - value - symbol) - -(define-primitive-object (unwind-block) - current-uwp - current-cont - current-code - entry-pc) - -(define-primitive-object (catch-block) - current-uwp - current-cont - current-code - entry-pc - tag - previous-catch - size) - - - -;;;; 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. -;;; -(defparameter static-symbols - '(t - - ;; Random stuff needed for initialization. - lisp::lisp-environment-list - lisp::lisp-command-line-list - lisp::*initial-symbols* - lisp::*lisp-initialization-functions* - lisp::%initial-function - lisp::*the-undefined-function* - - ;; 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* - - ;; Static functions. - two-arg-+ two-arg-- two-arg-* 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 - )) - -(defparameter exported-static-symbols - (subseq static-symbols 0 (1+ (position 'lisp::*free-interrupt-context-index* - static-symbols)))) - -(defun static-symbol-p (symbol) - (member symbol static-symbols)) - -(defun static-symbol-offset (symbol) - "Returns the byte offset of the static symbol 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)))) - -(defun offset-static-symbol (offset) - "Given a byte offset, Offset, returns the appropriate static symbol." - (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))) - - - -;;;; 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) - #+new-compiler (ash num 2) - #-new-compiler (* num 4) - (error "~D is too big for a fixnum." num))) - - - -;;;; Assembler parameters: - -;;; The number of bits per element in the assemblers code vector. -;;; -(defparameter *assembly-unit-length* 8) - - -;;;; Other parameters: - -;;; The number representing the fasl-code format emit code in. -;;; -(defparameter target-fasl-code-format 7) -(defparameter target-fasl-file-type "mips-fasl") - -;;; The version string for the implementation dependent code. -;;; -(defparameter vm-version "DECstation 3100/Mach 0.0") - - - - -); Eval-When (Compile Load Eval) diff --git a/compiler/mips/pred.lisp b/compiler/mips/pred.lisp deleted file mode 100644 index 3a4c19d6bd7e7a96f002b3c052ff8205e1495100..0000000000000000000000000000000000000000 --- a/compiler/mips/pred.lisp +++ /dev/null @@ -1,59 +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/mips/pred.lisp,v 1.4 1990/04/24 02:56:27 wlott Exp $ -;;; -;;; This file contains the VM definition of predicate VOPs for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(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 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 bfa9d96da6b1c5afb78de45001b4b1536bcf7bb6..0000000000000000000000000000000000000000 --- a/compiler/mips/print.lisp +++ /dev/null @@ -1,46 +0,0 @@ -;;; -*- Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/mips/print.lisp,v 1.3 1990/05/19 09:44:37 wlott Exp $ -;;; -;;; This file contains temporary printing utilities and similar noise. -;;; -;;; Written by William Lott. - -(in-package "C") - - -(define-vop (print) - (:args (object :scs (descriptor-reg))) - (:results (result :scs (descriptor-reg))) - (:save-p t) - (:temporary (:sc any-reg :offset 2) v0) - (:temporary (:sc any-reg :offset lra-offset) lra) - (:temporary (:sc any-reg :offset code-offset) code) - (:temporary (:scs (any-reg) :type fixnum) 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 nfp-save cur-nfp)) - (inst addu nsp-tn nsp-tn -16) - (storew object nsp-tn 0) - (inst li v0 (make-fixup "debug_print" :foreign)) - (inst li temp (make-fixup "call_into_c" :foreign)) - (inst j temp) - (inst compute-lra-from-code lra code lra-label) - (align vm:lowtag-bits) - (emit-label lra-label) - (inst lra-header-word) - (inst addu nsp-tn nsp-tn 16) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - (move result v0)))) 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 233a0ca4038cb504239ebe01b271619634f4d772..0000000000000000000000000000000000000000 --- a/compiler/mips/sap.lisp +++ /dev/null @@ -1,326 +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/mips/sap.lisp,v 1.11 1990/05/14 07:15:58 wlott Exp $ -;;; -;;; This file contains the MIPS VM definition of SAP operations. -;;; -;;; Written by William Lott. -;;; -(in-package "C") - - -;;;; 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))) - (: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 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) - (:results (y :scs (descriptor-reg))) - (:generator 1 - (move sap x) - (pseudo-atomic (ndescr) - (inst addu y alloc-tn vm:other-pointer-type) - (inst addu alloc-tn alloc-tn (vm:pad-data-block vm:sap-size)) - (inst li ndescr (logior (ash vm:sap-size vm:type-bits) vm:sap-type)) - (storew ndescr y 0 vm:other-pointer-type) - (storew sap y vm:sap-pointer-slot vm: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 (descriptor-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)) - (:results (int :scs (unsigned-reg))) - (:arg-types system-area-pointer) - (:translate sap-int) - (:policy :fast-safe) - (:generator 1 - (move int sap))) - -(define-vop (int-sap) - (:args (int :scs (unsigned-reg) :target sap)) - (:results (sap :scs (sap-reg))) - (: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))) - (: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))) - (:generator 1 - (inst subu res ptr1 ptr2))) - - - -;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET - -(define-vop (sap-ref) - (:policy :fast-safe) - (:variant-vars size signed) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (descriptor-reg any-reg negative-immediate zero - immediate unsigned-immediate))) - (:arg-types system-area-pointer positive-fixnum) - (:results (result :scs (signed-reg unsigned-reg))) - (:temporary (:scs (sap-reg) :from (:argument 0)) sap) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (multiple-value-bind - (base offset) - (sc-case offset - ((zero) - (values object 0)) - ((negative-immediate immediate) - (values object - (ash (tn-value offset) - (ecase size (:byte 0) (:short 1) (:long 2))))) - ((any-reg descriptor-reg) - (ecase size - (:byte - (inst sra temp offset 2) - (inst addu sap object temp)) - (:short - (inst sra temp offset 1) - (inst addu sap object temp)) - (:long - (inst addu sap object offset))) - (values sap 0))) - (ecase size - (:byte - (if signed - (inst lb result base offset) - (inst lbu result base offset))) - (:short - (if signed - (inst lh result base offset) - (inst lhu result base offset))) - (:long - (inst lw result base offset)))) - (inst nop))) - - -(define-vop (sap-set) - (:policy :fast-safe) - (:variant-vars size) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (descriptor-reg any-reg negative-immediate - zero immediate)) - (value :scs (signed-reg unsigned-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum *) - (:results (result :scs (signed-reg unsigned-reg))) - (:temporary (:scs (sap-reg) :from (:argument 0)) - sap) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (multiple-value-bind - (base offset) - (sc-case offset - ((zero) - (values object 0)) - ((negative-immediate immediate) - (values object - (ash (tn-value offset) - (ecase size (:byte 0) (:short 1) (:long 2))))) - ((any-reg descriptor-reg) - (ecase size - (:byte - (inst sra temp offset 2) - (inst addu sap object temp)) - (:short - (inst sra temp offset 1) - (inst addu sap object temp)) - (:long - (inst addu sap object offset))) - (values sap 0))) - (ecase size - (:byte - (inst sb value base offset)) - (:short - (inst sh value base offset)) - (:long - (inst sw value base offset)))) - (move result value))) - - - -(define-vop (sap-system-ref sap-ref) - (:translate sap-ref-sap) - (:results (result :scs (sap-reg))) - (:variant :long nil)) - -(define-vop (sap-system-set sap-set) - (:translate %set-sap-ref-sap) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (descriptor-reg any-reg negative-immediate - zero immediate)) - (value :scs (sap-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum system-area-pointer) - (:results (result :scs (sap-reg))) - (:variant :long)) - - - -(define-vop (32bit-system-ref sap-ref) - (:translate sap-ref-32) - (:variant :long nil)) - -(define-vop (signed-32bit-system-ref sap-ref) - (:translate signed-sap-ref-32) - (:variant :long t)) - -(define-vop (32bit-system-set sap-set) - (:translate %set-sap-ref-32) - (:variant :long)) - - -(define-vop (16bit-system-ref sap-ref) - (:translate sap-ref-16) - (:variant :short nil)) - -(define-vop (signed-16bit-system-ref sap-ref) - (:translate signed-sap-ref-16) - (:variant :short t)) - -(define-vop (16bit-system-set sap-set) - (:translate %set-sap-ref-16) - (:variant :short)) - - -(define-vop (8bit-system-ref sap-ref) - (:translate sap-ref-8) - (:variant :byte nil)) - -(define-vop (signed-8bit-system-ref sap-ref) - (:translate signed-sap-ref-8) - (:variant :byte t)) - -(define-vop (8bit-system-set sap-set) - (:translate %set-sap-ref-8) - (:variant :byte)) - - - -;;; Noise to convert normal lisp data objects into SAPs. - -(define-vop (vector-sap) - (:args (vector :scs (descriptor-reg))) - (:results (sap :scs (sap-reg))) - (:generator 2 - (inst addu sap vector - (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)))) - - - -;;;; ### Noise to allow old forms to continue to work until they are gone. - -(macrolet ((frob (prim func) - `(def-primitive-translator ,prim (&rest args) - (warn "Someone used %primitive ~S -- should be ~S." - ',prim ',func) - `(,',func ,@args)))) - (frob 32bit-system-ref sap-ref-32) - (frob unsigned-32bit-system-ref sap-ref-32) - (frob 16bit-system-ref sap-ref-16) - (frob 8bit-system-ref sap-ref-8)) - -(macrolet ((frob (prim func) - `(def-primitive-translator ,prim (&rest args) - (warn "Someone used %primitive ~S -- should be ~S." - ',prim (list 'setf ',func)) - `(setf ,',func ,@args)))) - (frob 32bit-system-set sap-ref-32) - (frob signed-32bit-system-set sap-ref-32) - (frob 16bit-system-set sap-ref-16) - (frob 8bit-system-set sap-ref-8)) diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp deleted file mode 100644 index 61cc18bfce47dfd7b8f873bfc9357fd208efaff2..0000000000000000000000000000000000000000 --- a/compiler/mips/static-fn.lisp +++ /dev/null @@ -1,150 +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/mips/static-fn.lisp,v 1.9 1990/05/18 00:56:39 wlott Exp $ -;;; -;;; This file contains the VOPs and macro magic necessary to call static -;;; functions. -;;; -;;; Written by William Lott. -;;; -(in-package "C") - - - -(define-vop (static-function-template) - (:save-p t) - (:policy :safe) - (:variant-vars symbol) - (:vop-var vop) - (:temporary (:scs (any-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 (:sc descriptor-reg :offset lexenv-offset) lexenv) - (:temporary (:scs (descriptor-reg)) function) - (:temporary (:scs (interior-reg) :type interior) lip) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset old-fp-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 lexenv cname vm:symbol-function-slot vm:other-pointer-type) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move old-fp fp-tn) - (move fp-tn csp-tn) - (inst compute-lra-from-code lra code-tn lra-label) - (loadw function lexenv vm:closure-function-slot - vm:function-pointer-type) - (lisp-jump function lip) - (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 - ,(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 e379cdafff1515526cc32e68de29076df88b08ea..0000000000000000000000000000000000000000 --- a/compiler/mips/subprim.lisp +++ /dev/null @@ -1,109 +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/mips/subprim.lisp,v 1.12 1990/05/24 13:30:24 wlott Exp $ -;;; -;;; Linkage information for standard static functions, and random vops. -;;; -;;; Written by William Lott. -;;; -(in-package "C") - - - -;;;; 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) - (:generator 50 - (let ((done (gen-label)) - (loop (gen-label)) - (not-list (generate-cerror-code di:object-not-list-error object))) - (move ptr object) - (move count zero-tn) - - (emit-label loop) - - (inst beq ptr null-tn done) - (inst nop) - - (simple-test-simple-type ptr temp not-list t vm:list-pointer-type) - - (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) - (inst addu count count (fixnum 1)) - (simple-test-simple-type ptr temp loop nil vm:list-pointer-type) - - (cerror-call done di:object-not-list-error ptr) - - (emit-label done) - (move result count)))) - - -(define-static-function length (object) :translate length) - - - - -;;;; Foreign function call interfaces. - -(define-vop (foreign-symbol-address) - (:info foreign-symbol) - (:results (res :scs (sap-reg))) - (:generator 2 - (inst li res (make-fixup foreign-symbol :foreign)))) - -(define-vop (call-out) - (:args (args :more t)) - (:ignore args) - (:save-p t) - (:info function) - (:results (result :scs (sap-reg signed-reg unsigned-reg))) - (:temporary (:sc any-reg :offset 2) v0) - (:temporary (:sc any-reg :offset lra-offset) lra) - (:temporary (:sc any-reg :offset code-offset) code) - (:temporary (:scs (any-reg) :type fixnum) 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 nfp-save cur-nfp)) - (inst li v0 (make-fixup function :foreign)) - (inst li temp (make-fixup "call_into_c" :foreign)) - (inst j temp) - (inst compute-lra-from-code lra code lra-label) - (align vm:lowtag-bits) - (emit-label lra-label) - (inst lra-header-word) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - (move result v0)))) - - -(define-vop (alloc-number-stack-space) - (:info amount) - (:results (result :scs (sap-reg))) - (:generator 0 - (inst addu nsp-tn nsp-tn (- amount)) - (move result nsp-tn))) - -(define-vop (dealloc-number-stack-space) - (:info amount) - (:policy :fast-safe) - (:generator 0 - (inst addu nsp-tn nsp-tn amount))) diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp deleted file mode 100644 index d4b11a9101bb07c391369e81cb4f2c92fdb118bc..0000000000000000000000000000000000000000 --- a/compiler/mips/system.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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.18 1990/05/27 16:50:48 ch Exp $ -;;; -;;; MIPS VM definitions of various system hacking operations. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Mips conversion by William Lott and Christopher Hoover. -;;; -(in-package "C") - - -;;;; Random pointer comparison VOPs - -(define-vop (pointer-compare) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg descriptor-reg))) - (:temporary (:type random :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)) - - - -;;;; Random assertions VOPS. - -(define-vop (check-op) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:variant-vars condition not-p error) - (:policy :fast-safe) - (:generator 3 - (let ((target (generate-error-code error x y))) - (three-way-comparison x y condition :signed not-p target temp)))) - -(define-vop (check<= check-op) - (:variant :gt t di:not-<=-error) - (:translate check<=)) - -(define-vop (check= check-op) - (:variant :eq nil di:not-=-error) - (:translate check=)) - - - -;;;; Type frobbing VOPs - -(define-vop (get-type) - (:args (object :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) - (:results (result :scs (any-reg descriptor-reg))) - (:generator 10 - (let ((other-ptr (gen-label)) - (shift (gen-label))) - (simple-test-simple-type object ndescr other-ptr - nil vm:other-pointer-type) - (inst and ndescr object (logand (logeqv vm:other-immediate-0-type - vm:other-immediate-1-type) - vm:lowtag-mask)) - (inst xor ndescr ndescr (logand vm:other-immediate-0-type - vm:other-immediate-1-type)) - (inst bne ndescr zero-tn shift) - (inst and ndescr object vm:lowtag-mask) - - (inst b shift) - (inst and ndescr object vm:type-mask) - - (emit-label other-ptr) - (load-type ndescr object (- vm:other-pointer-type)) - (inst nop) - - (emit-label shift) - (inst sll result ndescr 2)))) - - -(define-vop (get-header-data) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:generator 6 - (loadw res x 0 vm:other-pointer-type) - (inst srl res res vm:type-bits))) - -(define-vop (set-header-data) - (:args (x :scs (descriptor-reg) :target res) - (data :scs (any-reg immediate))) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :type random) 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)))) - (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 unsigned-immediate) - :target temp)) - (:results (res :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:generator 2 - (sc-case type - ((immediate unsigned-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))) - (:translate dynamic-space-free-pointer) - (:policy :fast-safe) - (:generator 1 - (move int alloc-tn))) - - -;;;; Code object frobbing. - -(define-vop (code-instructions) - (:args (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (sap :scs (sap-reg))) - (:generator 10 - (loadw ndescr code 0 vm:other-pointer-type) - (inst srl ndescr vm:type-bits) - (inst sll ndescr vm:word-shift) - (inst subu ndescr vm:code-header-type) - (inst addu sap code ndescr))) - -(define-vop (compute-function) - (:args (code :scs (descriptor-reg)) - (offset :scs (any-reg))) - (: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 addu ndescr offset) - (inst addu ndescr (- vm:function-pointer-type vm:other-pointer-type)) - (inst addu func code ndescr))) - - -;;;; Other random VOPs. - - -(define-vop (halt) - (:generator 1 - (inst break vm:halt-trap))) - - -;;; 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. -;;; -#+nil -(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/mips/type-vops.lisp b/compiler/mips/type-vops.lisp deleted file mode 100644 index 886cfcdd408b2e4963fa0d2209ae74721246a092..0000000000000000000000000000000000000000 --- a/compiler/mips/type-vops.lisp +++ /dev/null @@ -1,476 +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/mips/type-vops.lisp,v 1.13 1990/05/16 18:48:53 wlott Exp $ -;;; -;;; This file contains the VM definition of type testing and checking VOPs -;;; for the RT. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted for the MIPS R2000 by Christopher Hoover. -;;; -(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) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:generator 4 - (let ((err-lab (generate-error-code error-code value))) - (test-simple-type value temp err-lab t type-code) - (move 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)) - (define-vop (,check-name check-simple-type) - (:variant ,type-code ,error-code)) - (primitive-type-vop ,check-name (:check) ,ptype)))) - - ;; ### Want to tweek costs so that checks that do dereferences are - ;; more expensive. - ;; - (frob functionp check-function function - vm:function-pointer-type di:object-not-function-error) - - (frob listp check-list list - vm:list-pointer-type di:object-not-list-error) - - #+nil ;; ### Only after we have real structures. - (frob structurep check-structure structure - vm:structure-pointer-type di:object-not-structure) - - (frob bignump check-bigunm bignum - vm:bignum-type di:object-not-bignum-error) - - (frob ratiop check-ratio ratio - vm:ratio-type di:object-not-ratio-error) - - (frob complexp check-complex complex - vm:complex-type di:object-not-complex-error) - - (frob single-float-p check-single-float single-float - vm:single-float-type di:object-not-single-float-error) - - (frob double-float-p check-double-float double-float - vm:double-float-type di:object-not-double-float-error) - - (frob simple-string-p check-simple-string simple-string - vm:simple-string-type di:object-not-simple-string-error) - - (frob simple-bit-vector-p check-simple-bit-vector simple-bit-vector - vm:simple-bit-vector-type di:object-not-simple-bit-vector-error) - - (frob simple-vector-p check-simple-vector simple-vector - vm:simple-vector-type di:object-not-simple-vector-error) - - (frob simple-array-unsigned-byte-2-p check-simple-array-unsigned-byte-2 - simple-array-unsigned-byte-2 vm:simple-array-unsigned-byte-2-type - di:object-not-simple-array-unsigned-byte-2-error) - - (frob simple-array-unsigned-byte-4-p check-simple-array-unsigned-byte-4 - simple-array-unsigned-byte-4 vm:simple-array-unsigned-byte-4-type - di:object-not-simple-array-unsigned-byte-4-error) - - (frob simple-array-unsigned-byte-8-p check-simple-array-unsigned-byte-8 - simple-array-unsigned-byte-8 vm:simple-array-unsigned-byte-8-type - di:object-not-simple-array-unsigned-byte-8-error) - - (frob simple-array-unsigned-byte-16-p check-simple-array-unsigned-byte-16 - simple-array-unsigned-byte-16 vm:simple-array-unsigned-byte-16-type - di:object-not-simple-array-unsigned-byte-16-error) - - (frob simple-array-unsigned-byte-32-p check-simple-array-unsigned-byte-32 - simple-array-unsigned-byte-32 vm:simple-array-unsigned-byte-32-type - di:object-not-simple-array-unsigned-byte-32-error) - - (frob simple-array-single-float-p check-simple-array-single-float - simple-array-single-float vm:simple-array-single-float-type - di:object-not-simple-array-single-float-error) - - (frob simple-array-double-float-p check-simple-array-double-float - simple-array-double-float vm:simple-array-double-float-type - di:object-not-simple-array-double-float-error) - - (frob base-char-p check-base-character base-character - vm:base-character-type di:object-not-base-character-error) - - (frob system-area-pointer-p check-system-area-pointer system-area-pointer - vm:sap-type di:object-not-sap-error)) - - -;;; Slightly tenser versions for FIXNUM's -;;; -(define-vop (check-fixnum check-simple-type) - (:ignore type-code error-code) - (:generator 3 - (let ((err-lab (generate-error-code di:object-not-fixnum-error value))) - (inst and temp value #x3) - (inst bne temp zero-tn err-lab) - (move result value t)))) - -(define-vop (fixnump simple-type-predicate) - (:ignore type-code) - (:translate ext:fixnump) - (:generator 3 - (inst and temp value #x3) - (if not-p - (inst bne temp zero-tn target) - (inst beq temp zero-tn target)) - (inst nop))) - - -;;;; 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 (:type random :scs (non-descriptor-reg)) temp)) - -(define-vop (check-hairy-type) - (:args - (obj :scs (any-reg descriptor-reg) - :target res)) - (:results - (res :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp)) - -(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 ,error-code - obj))) - (test-hairy-type obj temp err-lab t ,@types)) - (move res obj))))))))) - - (frob array-header-p nil nil - vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type - vm:complex-vector-type vm:complex-array-type) - - (frob nil check-function-or-symbol di:object-not-function-or-symbol-error - vm:function-pointer-type vm:symbol-header-type) - - (frob stringp check-string di:object-not-string-error - vm:simple-string-type vm:complex-string-type) - - (frob bit-vector-p check-bit-vector di:object-not-bit-vector-error - vm:simple-bit-vector-type vm:complex-bit-vector-type) - - (frob vectorp check-vector di: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) - - (frob simple-array-p check-simple-array di: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) - - (frob arrayp check-array di: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) - - (frob numberp check-number di: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) - - (frob rationalp check-rational di:object-not-rational-error - vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) - - (frob floatp check-float di:object-not-float-error - vm:single-float-type vm:double-float-type) - - (frob realp check-real di: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) - - ;; ### May want to make this more tense. - (frob integerp check-integer di:object-not-integer-error - vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-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 hairy-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 and temp obj #x3) - (inst beq temp zero-tn yep) - (test-simple-type obj temp nope t vm:bignum-type) - (loadw temp obj 0 vm:other-pointer-type) - (inst srl temp temp (1+ vm:type-bits)) - (if not-p - (inst bne temp zero-tn target) - (inst beq temp zero-tn target)) - (inst nop) - (emit-label not-target))))) - -(define-vop (check-signed-byte-32 check-hairy-type) - (:generator 45 - (let ((nope (generate-error-code di:object-not-signed-byte-32-error obj)) - (yep (gen-label))) - (inst and temp obj #x3) - (inst beq temp zero-tn yep) - (test-simple-type obj temp nope t vm:bignum-type) - (loadw temp obj 0 vm:other-pointer-type) - (inst srl temp temp (1+ vm:type-bits)) - (inst bne temp zero-tn nope) - (inst nop) - (emit-label yep) - (move res obj)))) - - -;;; 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 hairy-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 and temp obj #x3) - (inst beq temp zero-tn fixnum) - ;; If not, is it a bignum? - (test-simple-type obj temp nope t vm:bignum-type) - ;; Get the number of digits. - (loadw temp obj 0 vm:other-pointer-type) - (inst srl temp temp vm:type-bits) - ;; Is it one? - (inst addu temp -1) - (inst beq temp single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst addu temp -1) - (inst bne temp nope) - ;; Get the second digit. - (loadw temp obj (1+ vm:bignum-digits-offset) vm:other-pointer-type) - ;; All zeros, its an (unsigned-byte 32). - (inst beq temp yep) - (inst nop) - ;; Otherwise, it isn't. - (inst b nope) - (inst nop) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp obj vm:bignum-digits-offset vm:other-pointer-type) - ;; positive implies (unsigned-byte 32). - (inst bgez temp yep) - (inst nop) - ;; Otherwise, nope. - (inst b nope) - (inst nop) - - (emit-label fixnum) - ;; positive fixnums are (unsigned-byte 32). - (if not-p - (inst bltz obj target) - (inst bgez obj target)) - (inst nop) - - (emit-label not-target))))) - -(define-vop (check-unsigned-byte-32 check-hairy-type) - (:generator 45 - (let ((nope (generate-error-code di:object-not-unsigned-byte-32-error obj)) - (yep (gen-label)) - (fixnum (gen-label)) - (single-word (gen-label))) - ;; Is it a fixnum? - (inst and temp obj #x3) - (inst beq temp zero-tn fixnum) - ;; If not, is it a bignum? - (test-simple-type obj temp nope t vm:bignum-type) - ;; Get the number of digits. - (loadw temp obj 0 vm:other-pointer-type) - (inst srl temp temp vm:type-bits) - ;; Is it one? - (inst addu temp -1) - (inst beq temp single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst addu temp -1) - (inst bne temp nope) - ;; Get the second digit. - (loadw temp obj (1+ vm:bignum-digits-offset) vm:other-pointer-type) - ;; All zeros, its an (unsigned-byte 32). - (inst beq temp yep) - (inst nop) - ;; Otherwise, it isn't. - (inst b nope) - (inst nop) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp obj vm:bignum-digits-offset vm:other-pointer-type) - ;; positive implies (unsigned-byte 32). - (inst bgez temp yep) - (inst nop) - ;; Otherwise, nope. - (inst b nope) - (inst nop) - - (emit-label fixnum) - ;; positive fixnums are (unsigned-byte 32). - (inst bltz obj nope) - (inst nop) - - (emit-label yep) - (move res obj)))) - - - - -;;;; 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 8 - ,@body)) - (define-vop (,check-name check-list-symbol) - (:generator 8 - (let ((target (generate-error-code ,error-code obj)) - (not-p t)) - ,@body - (move res obj))))))) - - (frob symbolp check-symbol di:object-not-symbol-error - (let* ((drop-thru (gen-label)) - (is-symbol-label (if not-p drop-thru target))) - (inst beq obj null-tn is-symbol-label) - (inst nop) - (test-simple-type obj temp target not-p vm:symbol-header-type) - (emit-label drop-thru))) - - (frob consp check-cons di:object-not-cons-error - (let* ((drop-thru (gen-label)) - (is-not-cons-label (if not-p target drop-thru))) - (inst beq obj null-tn is-not-cons-label) - (inst nop) - (test-simple-type obj temp target not-p vm:list-pointer-type) - (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 (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) - (:generator 0 - (let ((not-function-label (gen-label)) - (not-coercable-label (gen-label)) - (done-label (gen-label))) - (test-simple-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-simple-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-simple-type result nd-temp done-label nil - vm:function-pointer-type) - (error-call di:undefined-symbol-error saved-object) - - (emit-label not-coercable-label) - (error-call di:object-not-coercable-to-function-error object))))) diff --git a/compiler/mips/values.lisp b/compiler/mips/values.lisp deleted file mode 100644 index 46e99fef2598ebe5c7bbae6b3b413a615866517c..0000000000000000000000000000000000000000 --- a/compiler/mips/values.lisp +++ /dev/null @@ -1,94 +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/mips/values.lisp,v 1.7 1990/04/24 02:56:51 wlott Exp $ -;;; -;;; This file contains the implementation of unknown-values VOPs. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted for MIPS by William Lott. -;;; - -(in-package "C") - -(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 (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 - (move start-temp csp-tn) - (inst addu 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-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 descriptor-reg)) - (count :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) - (:generator 0 - (let ((loop (gen-label)) - (done (gen-label))) - - (move list arg) - (move start csp-tn) - - (emit-label loop) - (inst beq list null-tn done) - (loadw temp list vm:cons-car-slot vm:list-pointer-type) - (loadw list list vm:cons-cdr-slot vm:list-pointer-type) - (inst addu csp-tn csp-tn vm:word-bytes) - (storew temp csp-tn -1) - (test-simple-type list ndescr loop nil vm:list-pointer-type) - (error-call di:bogus-argument-to-values-list-error list) - - (emit-label done) - (inst subu count csp-tn start)))) - diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp deleted file mode 100644 index 10f57d018be223f03eae93e4935174b8c58622ca..0000000000000000000000000000000000000000 --- a/compiler/mips/vm.lisp +++ /dev/null @@ -1,637 +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/mips/vm.lisp,v 1.28 1990/05/23 06:10:04 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 "C") - - -;;;; 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) - - - ;; Immediate numeric constants. - ;; - ;; zero = (integer 0 0) - ;; - ;; negative-immediate = (integer #x-1FFF #-x0001) - ;; The funny lower bound guarantees that the negation of an immediate - ;; is still an immediate. - ;; - ;; immediate = (integer 0 #x1FFE) - ;; The funny upper bound guarantees that (1+ immediate) will fit in - ;; 16 bits. - ;; - ;; unsigned-immediate = (integer #x1FFF #x3FFE) - ;; The funny upper bound guarantees that (1+ immediate) will fit in - ;; 16 bits. - ;; - (zero immediate-constant) - (negative-immediate immediate-constant) - (immediate immediate-constant) - (unsigned-immediate immediate-constant) - - ;; Immediate SCs for things other than numbers. - (null immediate-constant) - (immediate-base-character immediate-constant) - (immediate-sap immediate-constant) - - ;; Anything else that can be computed faster than loaded that doesn't fit in - ;; any of the above immediate SCs. - (random-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-character-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 (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 28 31) - :constant-scs (negative-immediate zero immediate unsigned-immediate - immediate-base-character random-immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Pointer descriptor objects. Must be seen by GC. - (descriptor-reg registers - :locations (8 9 10 11 12 13 14 15 16 17 18 19 28 31) - :constant-scs (constant negative-immediate zero immediate unsigned-immediate - immediate-base-character random-immediate null) - :save-p t - :alternate-scs (control-stack)) - - ;; Non-Descriptor characters - (base-character-reg registers - :locations (2 3 4 5 6 7) - :constant-scs (immediate-base-character) - :save-p t - :alternate-scs (base-character-stack)) - - ;; Non-Descriptor SAP's (arbitrary pointers into address space) - (sap-reg registers - :locations (2 3 4 5 6 7) - :constant-scs (immediate-sap) - :save-p t - :alternate-scs (sap-stack)) - - ;; Non-Descriptor (signed or unsigned) numbers. - (signed-reg registers - :locations (2 3 4 5 6 7) - :constant-scs (negative-immediate zero immediate unsigned-immediate - random-immediate) - :save-p t - :alternate-scs (signed-stack)) - (unsigned-reg registers - :locations (2 3 4 5 6 7) - :constant-scs (zero immediate unsigned-immediate random-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 (2 3 4 5 6 7)) - - ;; Pointers to the interior of objects. Used only as an temporary. - (interior-reg registers - :locations (1)) - - - ;; **** 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) - :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) - :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)) - - - - -;;;; Primitive Type Definitions - -;;; *Anything* -;;; -(def-primitive-type t (descriptor-reg)) -(defvar *any-primitive-type* (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-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-character (base-character-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 single-float (single-reg descriptor-reg)) -(def-primitive-type double-float (double-reg descriptor-reg)) - -;;; 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 inclueded, 'cause it is pointless to -;;; restrict VOPs to them. - -;;; Other primitive other-pointer types. -;;; -(def-primitive-type system-area-pointer (sap-reg 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. -;;; -(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*)))) - -;;; -(defvar *simple-array-primitive-types* - '((base-character . 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.") - -;;; -;;; 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. -;;; -(defun 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 - (let ((exact (and (null lo) (null hi)))) - (case (numeric-type-format type) - ((short-float single-float) - (values (primitive-type-or-lose 'single-float) exact)) - ((double-float long-float) - (values (primitive-type-or-lose 'double-float) exact)) - (t - (any))))) - (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) - (values (primitive-type-or-lose (named-type-name type)) t)) - ((character base-character string-char) - (exactly base-character)) - (standard-char - (part-of base-character)) - (cons - (part-of list)) - (t - (any)))) - (ctype - (any))))) - - -;;;; Magical Registers - -(eval-when (compile eval load) - (defconstant zero-offset 0) - (defconstant lip-offset 1) - (defconstant nl0-offset 2) - (defconstant nl1-offset 3) - (defconstant nl2-offset 4) - (defconstant nl3-offset 5) - (defconstant nl4-offset 6) - (defconstant nargs-offset 7) - (defconstant a0-offset 8) - (defconstant a1-offset 9) - (defconstant a2-offset 10) - (defconstant a3-offset 11) - (defconstant a4-offset 12) - (defconstant a5-offset 13) - (defconstant cname-offset 14) - (defconstant lexenv-offset 15) - (defconstant args-offset 16) - (defconstant old-fp-offset 17) - (defconstant lra-offset 18) - (defconstant l0-offset 19) - (defconstant null-offset 20) - (defconstant bsp-offset 21) - (defconstant fp-offset 22) - (defconstant csp-offset 23) - (defconstant flags-offset 24) - (defconstant alloc-offset 25) - (defconstant l1-offset 28) - (defconstant nsp-offset 29) - (defconstant code-offset 30) - (defconstant l2-offset 31)) - -;;; -;;; Wired Zero -(defparameter zero-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset zero-offset)) - -;;; -;;; Lisp-interior-pointer register. -(defparameter lip-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset lip-offset)) - -;;; -;;; ``Wired'' NIL -(defparameter null-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset null-offset)) - -;;; -;;; Binding stack pointer -(defparameter bsp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset bsp-offset)) - -;;; -;;; Frame Pointer -(defparameter fp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset fp-offset)) - -;;; -;;; Control stack pointer -(defparameter csp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset csp-offset)) - -;;; -;;; FLAGS magic register -(defparameter flags-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset flags-offset)) - -;;; -;;; Allocation pointer -(defparameter alloc-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset alloc-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)) - -;;; -;;; Global Pointer (for C call-out) -(defparameter gp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset 29)) - - - -;;;; 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. -;;; -(defun immediate-constant-sc (value) - (typecase value - ((integer 0 0) - (sc-number-or-lose 'zero)) - (null - (sc-number-or-lose 'null)) - ((integer #x-1FFF #x-0001) - (sc-number-or-lose 'negative-immediate)) - ((integer 0 #x1FFE) - (sc-number-or-lose 'immediate)) - ((integer #x1FFF #x3FFE) - (sc-number-or-lose 'unsigned-immediate)) - (symbol - (if (vm:static-symbol-p value) - (sc-number-or-lose 'random-immediate) - nil)) - (#-new-compiler (signed-byte 30) - #+new-compiler fixnum - (sc-number-or-lose 'random-immediate)) - #+new-compiler - (system-area-pointer - (sc-number-or-lose 'immediate-sap)) - (character - (if (string-char-p value) - (sc-number-or-lose 'immediate-base-character) - 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 control-stack-arg-scn (sc-number-or-lose 'control-stack)) - -(eval-when (compile load eval) - -;;; Offsets of special stack frame locations -(defconstant old-fp-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 args-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset args-offset)) - -(defparameter old-fp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset old-fp-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. -;;; -(defconstant register-arg-count 6) - -;;; The offsets within the register-arg SC that we pass values in, first -;;; value first. -;;; -(defconstant register-arg-offsets '(8 9 10 11 12 13)) - -;;; 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)) - - - -;;; 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)))) - (offset (tn-offset tn))) - (ecase sb - (registers (mips:register-name (tn-offset tn))) - (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/node.lisp b/compiler/node.lisp deleted file mode 100644 index d4dbd3a6cf61b7c3d2a08da4962672e95a43ae5f..0000000000000000000000000000000000000000 --- a/compiler/node.lisp +++ /dev/null @@ -1,1170 +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). -;;; ********************************************************************** -;;; -;;; Structures for the first intermediate representation in the compiler, -;;; IR1. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; Defvars for these variables appear later. -(proclaim '(special *current-cookie* *default-cookie* *current-path* - *current-cleanup* *current-lambda* *current-component* - *fenv* *venv* *benv* *tenv*)) - - -;;; The front-end data structure (IR1) is composed of nodes and continuations. -;;; The general idea is that continuations contain top-down information and -;;; nodes contain bottom-up, derived information. A continuation represents a -;;; place in the code, while a node represents code that does something. -;;; -;;; This representation is more of a flow-graph than an augmented syntax tree. -;;; The evaluation order is explicitly represented in the linkage by -;;; continuations, rather than being implicit in the nodes which receive the -;;; the results of evaluation. This allows us to decouple the flow of results -;;; from the flow of control. A continuation represents both, but the -;;; continuation can represent the case of a discarded result by having no -;;; DEST. - -(defstruct (continuation - (:print-function %print-continuation) - (:constructor really-make-continuation (&optional dest))) - ;; - ;; An indication of the way that this continuation is currently used: - ;; - ;; :Unused - ;; A continuation for which all control-related slots have the default - ;; values. A continuation is unused during IR1 conversion until it is - ;; assigned a block, and may be also be temporarily unused during - ;; later manipulations of IR1. In a consistent state there should - ;; never be any mention of :Unused continuations. Next can have a - ;; non-null value if the next node has already been determined. - ;; - ;; :Deleted - ;; A continuation that has been deleted from IR1. Any pointers into - ;; IR1 are cleared. There are two conditions under which a deleted - ;; continuation may appear in code: - ;; -- The Cont of the Last node in a block may be a deleted - ;; continuation when the original receiver of the continuation's - ;; value was deleted. Note that Dest in a deleted continuation is - ;; null, so it is easy to know not to attempt delivering any - ;; values to the continuation. - ;; -- Unreachable code that hasn't been deleted yet may receive - ;; deleted continuations. All such code will be in blocks that - ;; have DELETE-P set. All unreachable code is deleted by control - ;; optimization, so the backend doesn't have to worry about this. - ;; - ;; :Block-Start - ;; The continuation that is the Start of Block. This is the only kind - ;; of continuation that can have more than one use. The Block's - ;; Start-Uses is a list of all the uses. - ;; - ;; :Deleted-Block-Start - ;; Like :Block-Start, but Block has been deleted. A block starting - ;; continuation is made into a deleted block start when the block is - ;; deleted, but the continuation still may have value semantics. - ;; Since there isn't any code left, next is null. - ;; - ;; :Inside-Block - ;; A continuation that is the Cont of some node in Block. - ;; - (kind :unused :type (member :unused :deleted :inside-block :block-start - :deleted-block-start)) - ;; - ;; The node which receives this value, if any. In a deleted continuation, - ;; this is null even though the node that receives this continuation may not - ;; yet be deleted. - (dest nil :type (or node null)) - ;; - ;; If this is a Node, then it is the node which is to be evaluated next. - ;; This is always null in :Deleted and :Unused continuations, and will be - ;; null in a :Inside-Block continuation when this is the CONT of the LAST. - (next nil :type (or node null)) - ;; - ;; An assertion on the type of this continuation's value. - (asserted-type *wild-type* :type ctype) - ;; - ;; Cached type of this contiuation's value. If NIL, then this must be - ;; recomputed: see Continuation-Derived-Type. - (%derived-type nil :type (or ctype null)) - ;; - ;; Node where this continuation is used, if unique. This is always null in - ;; :Deleted and :Unused continuations, and is never null in :Inside-Block - ;; continuations. In a :Block-Start contiuation, the Block's Start-Uses - ;; indicate whether NIL means no uses or more than one use. - (use nil :type (or node null)) - ;; - ;; Basic block this continuation is in. This is null only in :Deleted and - ;; :Unused continuations. Note that blocks that are unreachable but still in - ;; the DFO may receive deleted continuations, so it isn't o.k. to assume that - ;; any random continuation that you pick up out of its Dest node has a Block. - (block nil :type (or cblock null)) - ;; - ;; Set to true when something about this continuation's value has changed. - ;; See Reoptimize-Continuation. This provides a way for IR1 optimize to - ;; determine which operands to a node have changed. If the optimizer for - ;; this node type doesn't care, it can elect not to clear this flag. - (reoptimize t :type boolean) - ;; - ;; An indication of what we have proven about how this contination's type - ;; assertion is satisfied: - ;; - ;; NIL - ;; No type check is necessary (proven type is a subtype of the assertion.) - ;; - ;; T - ;; A type check is needed. - ;; - ;; :DELETED - ;; Don't do a type check, but believe (intersect) the assertion. A T - ;; check can be changed to :DELETED if we somehow prove the check is - ;; unnecessary, or if we eliminate it through a policy decision. - ;; - ;; :NO-CHECK - ;; Type check generation sets the slot to this if a check is called for, - ;; but it believes it has proven that the check won't be done for - ;; policy reasons or because a safe implementation will be used. In the - ;; latter case, LTN must ensure that a safe implementation *is* be used. - ;; - ;; :ERROR - ;; There is a compile-time type error in some use of this continuation. A - ;; type check should still be generated, but be careful. - ;; - ;; This is computed lazily by CONTINUATION-DERIVED-TYPE, so use - ;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor. - ;; - (%type-check t :type (member t nil :deleted :no-check :error)) - ;; - ;; Something or other that the back end annotates this continuation with. - (info nil)) - -(defun %print-continuation (s stream d) - (declare (ignore d)) - (format stream "#<Continuation c~D>" (cont-num s))) - - -(defstruct node - ;; - ;; The bottom-up derived type for this node. This does not take into - ;; consideration output type assertions on this node (actually on its CONT). - (derived-type *wild-type* :type ctype) - ;; - ;; True if this node needs to be optimized. This is set to true whenever - ;; something changes about the value of a continuation whose DEST is this - ;; node. - (reoptimize t :type boolean) - ;; - ;; The continuation which receives the value of this node. This also - ;; indicates what we do controlwise after evaluating this node. This may be - ;; null during IR1 conversion. - (cont nil :type (or continuation null)) - ;; - ;; The continuation that this node is the next of. This is null during - ;; IR1 conversion when we haven't linked the node in yet or in nodes that - ;; have been deleted from the IR1 by UNLINK-NODE. - (prev nil :type (or continuation null)) - ;; - ;; The Cookie holds various rarely-changed information about how a node - ;; should be compiled. Currently it only holds the values of the Optimize - ;; settings. Values for things which have not been specified locally are - ;; null. The real value is then found in the Default-Cookie. The - ;; Default-Cookie must also be kept in the node since it changes when - ;; we run into a Proclaim duing IR1 conversion. - (cookie *current-cookie* :type cookie) - (default-cookie *default-cookie* :type cookie) - ;; - ;; Source code for this node. This is used to provide context in messages to - ;; the user, since it may be hard to reconstruct the source from the internal - ;; representation. - (source nil :type t) - ;; - ;; A representation of the location in the original source of the form - ;; responsible for generating this node. The first element in this list is - ;; the "form number", which is the ordinal number of this form in a - ;; depth-first, left-to-right walk of the truly top-level form in which this - ;; appears. - ;; - ;; Following is a list of integers describing the path taken through the - ;; source to get to this point: - ;; (k l m ...) => (nth k (nth l (nth m ...))) - ;; - ;; This path is through the original top-level form compiled, and in general - ;; has nothing to do with the Source slot. This path is our best guess for - ;; where the code came from, and may be not be very helpful in the case of - ;; code resulting from macroexpansion. The last element in the list is the - ;; top-level form number, which is the ordinal number (in this call to the - ;; compiler) of the truly top-level form containing the orignal source - (source-path *current-path* :type list) - ;; - ;; If this node is in a tail-recursive position, then this is set to the - ;; corresponding Tail-Set. This is first computed at the end of IR1 (after - ;; cleanup code has been emitted). If the back-end breaks tail-recursion for - ;; some reason, then it can null out this slot. - (tail-p nil :type (or tail-set null))) - - - -;;; The CBlock structure represents a basic block. We include SSet-Element so -;;; that we can have sets of blocks. Initially the SSet-Element-Number is -;;; null, but we number in reverse DFO before we do any set operations. -;;; -(defstruct (cblock (:print-function %print-block) - (:include sset-element) - (:constructor really-make-block (start)) - (:constructor make-block-key) - (:conc-name block-) - (:predicate block-p) - (:copier copy-block)) - ;; - ;; A list of all the blocks that are predecessors/successors of this block. - ;; In well-formed IR1, most blocks will have one or two successors. The only - ;; exceptions are component head blocks and block with DELETE-P set. - (pred nil :type list) - (succ nil :type list) - ;; - ;; The continuation which heads this block (either a :Block-Start or - ;; :Deleted-Block-Start.) Null when we haven't made the start continuation - ;; yet. - (start nil :type (or continuation null)) - ;; - ;; A list of all the nodes that have Start as their Cont. - (start-uses nil :type list) - ;; - ;; The last node in this block. This is null when we are in the process of - ;; building a block. - (last nil :type (or node null)) - ;; - ;; The Lambda that this code is syntactically within, for environment - ;; analysis. This may be null during IR1 conversion. This is also null in - ;; the dummy head and tail blocks for a component. - (lambda *current-lambda* :type (or clambda null)) - ;; - ;; The cleanups in effect at the beginning and after the end of this block. - ;; If there is no cleanup in effect within the enclosing lambda, then the - ;; value is the enclosing lambda. The Lambda-Cleanup must be examined to - ;; determine whether later let-substitution has added an enclosing dynamic - ;; binding in the same environment. Cleanup generation uses this information - ;; to determine if code needs to be emitted to undo dynamic bindings. - ;; Null in the dummy component head and tail. - (start-cleanup *current-cleanup* :type (or cleanup clambda null)) - (end-cleanup *current-cleanup* :type (or cleanup clambda null)) - ;; - ;; The forward and backward links in the depth-first ordering of the blocks. - ;; These slots are null at beginning/end. - (next nil :type (or null cblock)) - (prev nil :type (or null cblock)) - ;; - ;; Flags that are used to indicate that various IR1 optimization phases - ;; should be done on code in this block: - ;; -- REOPTIMIZE is set when something interesting happens the uses of a - ;; continuation whose Dest is in this block. This indicates that the - ;; value-driven (forward) IR1 optimizations should be done on this block. - ;; -- FLUSH-P is set when code in this block becomes potentially flushable, - ;; usually due to a continuation's DEST becoming null. - ;; -- TYPE-CHECK is true when the type check phase should be run on this - ;; block. IR1 optimize can introduce new blocks after type check has - ;; already run. We need to check these blocks, but there is no point in - ;; checking blocks we have already checked. - ;; -- DELETE-P is true when this block is used to indicate that this block - ;; has been determined to be unreachable and should be deleted. IR1 - ;; phases should not attempt to examine or modify blocks with DELETE-P - ;; set, since they may: - ;; - be in the process of being deleted, or - ;; - have no successors, or - ;; - receive :DELETED continuations. - ;; -- TYPE-ASSERTED, TEST-MODIFIED - ;; These flags are used to indicate that something in this block might be - ;; of interest to constraint propagation. TYPE-ASSERTED is set when a - ;; continuation type assertion is strengthened. TEST-MODIFIED is set - ;; whenever the test for the ending IF has changed (may be true when there - ;; is no IF.) - ;; - (reoptimize t :type boolean) - (flush-p t :type boolean) - (type-check t :type boolean) - (delete-p nil :type boolean) - (type-asserted t :type boolean) - (test-modified t :type boolean) - ;; - ;; Some sets used by constraint propagation. - (kill nil) - (gen nil) - (in nil) - (out nil) - ;; - ;; The component this block is in. Null temporarily during IR1 conversion - ;; and in deleted blocks. - (component *current-component* :type (or component null)) - ;; - ;; A flag used by various graph-walking code to determine whether this block - ;; has been processed already or what. We make this initially NIL so that - ;; Find-Initial-DFO doesn't have to scan the entire initial component just to - ;; clear the flags. - (flag nil) - ;; - ;; Some kind of info used by the back end. - (info nil)) - -(defun %print-block (s stream d) - (declare (ignore d)) - (format stream "#<Block ~X, Start = c~D>" (system:%primitive make-fixnum s) - (cont-num (block-start s)))) - - -;;; The Component structure provides a handle on a connected piece of the flow -;;; graph. Most of the passes in the compiler operate on components rather -;;; than on the entire flow graph. -;;; -(defstruct (component (:print-function %print-component)) - ;; - ;; The kind of component: - ;; - ;; NIL - ;; An ordinary component, containing arbitrary code. - ;; - ;; :Top-Level - ;; A component containing only load-time code. - ;; - ;; :Initial - ;; The result of initial IR1 conversion, on which component analysis has - ;; not been done. - ;; - (kind nil :type (member nil :top-level :initial)) - ;; - ;; The blocks that are the dummy head and tail of the DFO. Entry/exit points - ;; have these blocks as their predecessors/successors. Null temporarily. - ;; The start and return from each non-deleted function is linked to the - ;; component head and tail. Until environment analysis links NLX entry stubs - ;; to the component head, every successor of the head is a function start - ;; (i.e. begins with a Bind node.) - (head nil :type (or null cblock)) - (tail nil :type (or null cblock)) - ;; - ;; A list of the CLambda structures for all functions in this component. - ;; Optional-Dispatches are represented only by their XEP and other associated - ;; lambdas. This doesn't contain any deleted or let lambdas. - (lambdas () :type list) - ;; - ;; A list of Functional structures for functions that are newly converted, - ;; and haven't been local-call analyzed yet. Unanalyzed functions aren't in - ;; the Lambdas list. Functions are moved into the Lambdas as they are - ;; analysed. - (new-functions () :type list) - ;; - ;; If true, then there is stuff in this component that could benefit from - ;; further IR1 optimization. - (reoptimize t :type boolean) - ;; - ;; If true, then the control flow in this component was messed up by IR1 - ;; optimizations. The DFO should be recomputed. - (reanalyze nil :type boolean) - ;; - ;; String that is some sort of name for the code in this component. - (name "<unknown>" :type simple-string) - ;; - ;; Some kind of info used by the back end. - (info nil)) - - -(defprinter component - name - (reanalyze :test reanalyze)) - - -;;; The Cleanup structure represents some dynamic binding action. Blocks are -;;; annotated with the current cleanup so that dynamic bindings can be removed -;;; when control is transferred out of the binding environment. We arrange for -;;; changes in dynamic bindings to happen at block boundaries, so that cleanup -;;; code may easily be inserted. The "mess-up" action is explictly represented -;;; by a funny function call or Entry node. -;;; -;;; We guarantee that cleanups only need to be done at block boundries by -;;; requiring that the exit continuations initially head their blocks, and then -;;; by not merging blocks when there is a cleanup change. -;;; -(defstruct (cleanup (:print-function %print-cleanup)) - ;; - ;; The kind of thing that has to be cleaned up. :Entry marks the dynamic - ;; extent of a lexical exit (TAGBODY or BLOCK). - (kind nil :type (member :special-bind :catch :unwind-protect :entry)) - ;; - ;; The first messed-up continuation. This is Use'd by the node that is the - ;; mess-up. Null only temporarily. This could be deleted if the mess-up was - ;; deleted. Note that the cleanup "belongs" to the block holding the - ;; mess-up, rather than the start continuation's block. - (start nil :type (or continuation null)) - ;; - ;; The syntactically enclosing cleanup. If there is no enclosing cleanup in - ;; our lambda, then this is the lambda. A :Catch or :Unwind-Protect cleanup - ;; is always enclosed by the :Entry cleanup for the escape block. - (enclosing *current-cleanup* :type (or cleanup clambda)) - ;; - ;; A list of all the NLX-Info structures whose NLX-Info-Cleanup is this - ;; cleanup. This is filled in by environment analysis. - (nlx-info nil :type list)) - -(defprinter cleanup - kind - (start :prin1 (continuation-use start)) - (nlx-info :test nlx-info)) - - -;;; The Environment structure represents the result of Environment analysis. -;;; -(defstruct (environment (:print-function %print-environment)) - ;; - ;; The function that allocates this environment. - (function nil :type clambda) - ;; - ;; A list of all the Lambdas that allocate variables in this environment. - (lambdas nil :type list) - ;; - ;; A list of all the lambda-vars and NLX-Infos needed from enclosing - ;; environments by code in this environment. - (closure nil :type list) - ;; - ;; A list of NLX-Info structures describing all the non-local exits into this - ;; environment. - (nlx-info nil :type list) - ;; - ;; Some kind of info used by the back end. - (info nil)) - -(defprinter environment - function - (closure :test closure) - (nlx-info :test nlx-info)) - - -;;; The Tail-Set structure is used to accmumlate information about -;;; tail-recursive local calls. The "tail set" is effectively the transitive -;;; closure of the "is called tail-recursively by" relation. -;;; -;;; All functions in the same tail set share the same Tail-Set structure. -;;; Initially each function has its own Tail-Set, but converting a TR local -;;; call joins the tail sets of the called function and the calling function. -;;; When computing the tail set, we consider a call to be TR when it delivers -;;; its value to a return node; there may be an implicit MV-Prog1, and the -;;; use of the result continuation might even turn out to be a non-local exit. -;;; -;;; This is the most useful interpretation for type inference. Anyway, local -;;; call analysis happens too early to determine which calls are truly TR. -;;; -(defstruct (tail-set - (:print-function %print-tail-set)) - ;; - ;; A list of all the lambdas in this tail set. - (functions nil :type list) - ;; - ;; Our current best guess of the type returned by these functions. This is - ;; the union across all the functions of the return node's Result-Type. - ;; excluding local calls. - (type *wild-type* :type ctype) - ;; - ;; Some info used by the back end. - (info nil)) - -(defprinter tail-set - functions - type - (info :test info)) - - -;;; The NLX-Info structure is used to collect various information about -;;; non-local exits. This is effectively an annotation on the Continuation, -;;; although it is accessed by searching in the Environment-Nlx-Info. -;;; -(defstruct (nlx-info (:print-function %print-nlx-info)) - ;; - ;; The cleanup associated with this exit. In a catch or unwind-protect, this - ;; is the :Catch or :Unwind-Protect cleanup, and not the cleanup for the - ;; escape block. The Cleanup-Kind of this thus provides a good indication of - ;; what kind of exit is being done. - (cleanup nil :type cleanup) - ;; - ;; The continuation exited to (the CONT of the EXIT nodes.) If this exit is - ;; from an escape function (CATCH or UNWIND-PROTECT), then environment - ;; analysis deletes the escape function and instead has the %NLX-ENTRY use - ;; this continuation. - ;; - ;; This slot is primarily an indication of where this exit delivers its - ;; values to (if any), but it is also used as a sort of name to allow us to - ;; find the NLX-Info that corresponds to a given exit. For this purpose, the - ;; Entry must also be used to disambiguate, since exits to different places - ;; may deliver their result to the same continuation. - (continuation nil :type continuation) - ;; - ;; The entry stub inserted by environment analysis. This is a block - ;; containing a call to the %NLX-Entry funny function that has the original - ;; exit destination as its successor. Null only temporarily. - (target nil :type (or cblock null)) - ;; - ;; Some kind of info used by the back end. - info) - -(defprinter nlx-info - continuation - target - info) - - -;;; Leaves: -;;; -;;; Variables, constants and functions are all represented by Leaf -;;; structures. A reference to a Leaf is indicated by a Ref node. This allows -;;; us to easily substitute one for the other without actually hacking the flow -;;; graph. - -(defstruct leaf - ;; - ;; Some name for this leaf. The exact significance of the name depends on - ;; what kind of leaf it is. In a Lambda-Var or Global-Var, this is the - ;; symbol name of the variable. In a functional that is from a DEFUN, this - ;; is the defined name. In other functionals, this is a descriptive string. - (name nil :type t) - ;; - ;; The type which values of this leaf must have. - (type *universal-type* :type ctype) - ;; - ;; Where the Type information came from: - ;; :declared, from a declaration. - ;; :assumed, from uses of the object. - ;; :defined, from examination of the definition. - (where-from :assumed :type (member :declared :assumed :defined)) - ;; - ;; List of the Ref nodes for this leaf. - (refs () :type list) - ;; - ;; True if there was ever a Ref or Set node for this leaf. This may be true - ;; when Refs and Sets are null, since code can be deleted. - (ever-used nil :type boolean) - ;; - ;; Some kind of info used by the back end. - (info nil)) - - -;;; The Constant structure is used to represent known constant values. If Name -;;; is not null, then it is the name of the named constant which this leaf -;;; corresponds to, otherwise this is an anonymous constant. -;;; -(defstruct (constant (:include leaf) - (:print-function %print-constant)) - ;; - ;; The value of the constant. - (value nil :type t)) - -(defprinter constant - (name :test name) - value) - - -;;; The Basic-Var structure represents information common to all variables -;;; which don't correspond to known local functions. -;;; -(defstruct (basic-var (:include leaf)) - ;; - ;; Lists of the set nodes for this variable. - (sets () :type list)) - - -;;; The Global-Var structure represents a value hung off of the symbol Name. -;;; We use a :Constant Var when we know that the thing is a constant, but don't -;;; know what the value is at compile time. -;;; -(defstruct (global-var (:include basic-var) - (:print-function %print-global-var)) - ;; - ;; Kind of variable described. - (kind nil :type (member :special :global-function :constant :global))) - -(defprinter global-var - name - (type :test (not (eq type *universal-type*))) - (where-from :test (not (eq where-from :assumed))) - kind) - - -;;; The Slot-Accessor structure represents defstruct slot accessors. It is a -;;; subtype of Global-Var to make it look more like a normal function. -;;; -(defstruct (slot-accessor (:include global-var - (where-from :defined) - (kind :global-function)) - (:print-function %print-slot-accessor)) - ;; - ;; The description of the structure that this is an accessor for. - (for nil :type defstruct-description) - ;; - ;; The slot description of the slot. - (slot nil :type defstruct-slot-description)) - -(defprinter slot-accessor - name - for - slot) - - - -;;;; Function stuff: - - -;;; We default the Where-From and Type slots to :Defined and Function. We -;;; don't normally manipulate function types for defined functions, but if -;;; someone wants to know, an approximation is there. -;;; -(defstruct (functional (:include leaf - (:where-from :defined) - (:type (specifier-type 'function))) - (:print-function %print-functional)) - ;; - ;; - ;; - ;; - ;; Some information about how this function is used. These values are - ;; meaningful: - ;; - ;; Nil - ;; An ordinary function, callable using local call. - ;; - ;; :Let - ;; A lambda that is used in only one local call, and has in effect - ;; been substituted directly inline. The return node is deleted, and - ;; the result is computed with the actual result continuation for the - ;; call. - ;; - ;; :MV-Let - ;; Similar to :Let, but the call is an MV-Call. - ;; - ;; :Optional - ;; A lambda that is an entry-point for an optional-dispatch. Similar - ;; to NIL, but requires greater caution, since local call analysis may - ;; create new references to this function. Also, the function cannot - ;; be deleted even if it has *no* references. The Optional-Dispatch - ;; is in the LAMDBA-OPTIONAL-DISPATCH. - ;; - ;; :External - ;; An external entry point lambda. The function it is an entry for is - ;; in the Entry-Function. - ;; - ;; :Top-Level - ;; A top-level lambda, holding a compiled top-level form. Compiled - ;; very much like NIL, but provides an indication of top-level - ;; context. A top-level lambda should have *no* references. Its - ;; Entry-Function is a self-pointer. - ;; - ;; :Top-Level-XEP - ;; After a component is compiled, we clobber any top-level code - ;; references to its non-closure XEPs with dummy FUNCTIONAL structures - ;; having this kind. This prevents the retained top-level code from - ;; holding onto the IR for the code it references. - ;; - ;; :Escape - ;; :Cleanup - ;; Special functions used internally by Catch and Unwind-Protect. - ;; These are pretty much like a normal function (NIL), but are treated - ;; specially by local call analysis and stuff. Neither kind should - ;; ever be given an XEP even though they appear as args to funny - ;; functions. An :Escape function is never actually called, and thus - ;; doesn't need to have code generated for it. - ;; - ;; :Deleted - ;; This function has been found to be uncallable, and has been - ;; marked for deletion. - ;; - (kind nil :type (member nil :optional :deleted :external :top-level :escape - :cleanup :let :mv-let :top-level-xep)) - ;; - ;; In a normal function, this is the external entry point (XEP) lambda for - ;; this function, if any. Each function that is used other than in a local - ;; call has an XEP, and all of the non-local-call references are replaced - ;; with references to the XEP. - ;; - ;; In an XEP lambda (indicated by the :External kind), this is the function - ;; that the XEP is an entry-point for. The body contains local calls to all - ;; the actual entry points in the function. In a :Top-Level lambda (which is - ;; its own XEP) this is a self-pointer. - ;; - ;; With all other kinds, this is null. - (entry-function nil :type (or functional null)) - ;; - ;; If we have a lambda that can be used as in inline expansion for this - ;; function, then this is it. If there is no source-level lambda - ;; corresponding to this function then this is Null. - (inline-expansion nil :type list) - ;; - ;; The original function or macro lambda list, or :UNSPECIFIED if this is a - ;; compiler created function. - (arg-documentation nil :type (or list (member :unspecified))) - ;; - ;; The environment values that we use if we reconvert the Inline-Expansion. - (fenv *fenv*) - (venv *venv*) - (benv *benv*) - (tenv *tenv*)) - -(defprinter functional - name) - - -;;; The Lambda only deals with required lexical arguments. Special, optional, -;;; keyword and rest arguments are handled by transforming into simpler stuff. -;;; -(defstruct (clambda (:include functional) - (:print-function %print-lambda) - (:conc-name lambda-) - (:predicate lambda-p) - (:constructor make-lambda) - (:copier copy-lambda)) - ;; - ;; List of lambda-var descriptors for args. - (vars nil :type list) - ;; - ;; If this function was ever a :OPTIONAL function (an entry-point for an - ;; optional-dispatch), then this is that optional-dispatch. The optional - ;; dispatch will be :DELETED if this function is no longer :OPTIONAL. - (optional-dispatch nil :type (or optional-dispatch null)) - ;; - ;; The Bind node for this Lambda. This node marks the beginning of the - ;; lambda, and serves to explicitly represent the lambda binding semantics - ;; within the flow graph representation. - (bind nil :type bind) - ;; - ;; The Return node for this Lambda, or NIL if it has been deleted. This - ;; marks the end of the lambda, receiving the result of the body. In a let, - ;; the return node is deleted, and the body delivers the value to the actual - ;; continuation. The return may also be deleted if it is unreachable. - (return nil :type (or creturn null)) - ;; - ;; If this is a let, then the Lambda whose Lets list we are in, otherwise - ;; this is a self-pointer. - (home nil :type (or clambda null)) - ;; - ;; A list of all the all the lambdas that have been let-substituted in this - ;; lambda. This is only non-null in lambdas that aren't lets. - (lets () :type list) - ;; - ;; A list of all the Entry nodes in this function and its lets. Null an a - ;; let. - (entries () :type list) - ;; - ;; If true, then this is the innermost cleanup that dynamically encloses the - ;; call to this function. If false, then there is no such cleanup. This is - ;; never true if the lambda isn't a let, since in other cases the function - ;; will have its own environment, and the non-local exit mechanism will deal - ;; with cleanups. - (cleanup nil :type (or cleanup null)) - ;; - ;; A list of all the functions directly called from this function (or one of - ;; its lets) using a non-let local call. - (calls () :type list) - ;; - ;; The Tail-Set that this lambda is in. Null when Return is null. - (tail-set nil :type (or tail-set null)) - ;; - ;; The structure which represents the environment that this Function's - ;; variables are allocated in. This is filled in by environment analysis. - ;; In a let, this is EQ to our home's environment. - (environment nil :type (or environment null))) - - -(defprinter lambda - name - (type :test (not (eq type *universal-type*))) - (where-from :test (not (eq where-from :assumed))) - (vars :prin1 (mapcar #'leaf-name vars))) - - -;;; The Optional-Dispatch leaf is used to represent hairy lambdas. If is a -;;; Functional, like Lambda. Each legal number of arguments has a function -;;; which is called when that number of arguments is passed. The function is -;;; called with all the arguments actually passed. If additional arguments are -;;; legal, then the LEXPR style More-Entry handles them. The value returned by -;;; the function is the value which results from calling the Optional-Dispatch. -;;; -;;; The theory is that each entry-point function calls the next entry -;;; point tail-recursively, passing all the arguments passed in and the default -;;; for the argument the entry point is for. The last entry point calls the -;;; real body of the function. In the presence of supplied-p args and other -;;; hair, things are more complicated. In general, there is a distinct -;;; internal function that takes the supplied-p args as parameters. The -;;; preceding entry point calls this function with NIL filled in for the -;;; supplied-p args, while the current entry point calls it with T in the -;;; supplied-p positions. -;;; -;;; Note that it is easy to turn a call with a known number of arguments into a -;;; direct call to the appropriate entry-point function, so functions that are -;;; compiled together can avoid doing the dispatch. -;;; -(defstruct (optional-dispatch (:include functional) - (:print-function %print-optional-dispatch)) - ;; - ;; The original parsed argument list, for anyone who cares. - (arglist nil :type list) - ;; - ;; True if &allow-other-keys was supplied. - (allowp nil :type boolean) - ;; - ;; True if &key was specified. (Doesn't necessarily mean that there are any - ;; keyword arguments...) - (keyp nil :type boolean) - ;; - ;; The number of required arguments. This is the smallest legal number of - ;; arguments. - (min-args 0 :type unsigned-byte) - ;; - ;; The total number of required and optional arguments. Args at positions >= - ;; to this are rest, key or illegal args. - (max-args 0 :type unsigned-byte) - ;; - ;; List of the Lambdas which are the entry points for non-rest, non-key - ;; calls. The entry for Min-Args is first, Min-Args+1 second, ... Max-Args - ;; last. The last entry-point always calls the main entry; in simple cases - ;; it may be the main entry. - (entry-points nil :type list) - ;; - ;; An entry point which takes Max-Args fixed arguments followed by an - ;; argument context pointer and an argument count. This entry point deals - ;; with listifying rest args and parsing keywords. This is null when extra - ;; arguments aren't legal. - (more-entry nil :type (or clambda null)) - ;; - ;; The main entry-point into the function, which takes all arguments - ;; including keywords as fixed arguments. The format of the arguments must - ;; be determined by examining the arglist. This may be used by callers that - ;; supply at least Max-Args arguments and know what they are doing. - (main-entry nil :type (or clambda null))) - - -(defprinter optional-dispatch - name - (type :test (not (eq type *universal-type*))) - (where-from :test (not (eq where-from :assumed))) - arglist - min-args - max-args - (entry-points :test entry-points) - (more-entry :test more-entry) - main-entry) - - -;;; The Arg-Info structure allows us to tack various information onto -;;; Lambda-Vars during IR1 conversion. If we use one of these things, then the -;;; var will have to be massaged a bit before it is simple and lexical. -;;; -(defstruct (arg-info (:print-function %print-arg-info)) - ;; - ;; True if this arg is to be specially bound. - (specialp nil :type boolean) - ;; - ;; The kind of argument being described. Required args only have arg - ;; info structures if they are special. - (kind nil :type (member :required :optional :keyword :rest)) - ;; - ;; If true, the Var for supplied-p variable of a keyword or optional arg. - ;; This is true for keywords with non-constant defaults even when there is no - ;; user-specified supplied-p var. - (supplied-p nil :type (or lambda-var null)) - ;; - ;; The default for a keyword or optional, represented as the original - ;; Lisp code. This is set to NIL in keyword arguments that are defaulted - ;; using the supplied-p arg. - (default nil :type t) - ;; - ;; The actual keyword for a keyword argument. - (keyword nil :type (or keyword null))) - -(defprinter arg-info - (specialp :test specialp) - kind - (supplied-p :test supplied-p) - (default :test default) - (keyword :test keyword)) - - -;;; The Lambda-Var structure represents a lexical lambda variable. This -;;; structure is also used during IR1 conversion to describe lambda arguments -;;; which may ultimately turn out not to be simple and lexical. -;;; -;;; Lambda-Vars with no Refs are considered to be deleted; environment analysis -;;; isn't done on these variables, so the back end must check for and ignore -;;; unreferenced variables. Note that a deleted lambda-var may have sets; in -;;; this case the back end is still responsible for propagating the Set-Value -;;; to the set's Cont. -;;; -(defstruct (lambda-var (:include basic-var) - (:print-function %print-lambda-var)) - ;; - ;; True if this variable has been declared Ignore. - (ignorep nil :type boolean) - ;; - ;; The Lambda that this var belongs to. This may be null when we are - ;; building a lambda during IR1 conversion. - (home nil :type (or null clambda)) - ;; - ;; This is set by environment analysis if it chooses an indirect (value cell) - ;; representation for this variable because it is both set and closed over. - (indirect nil :type boolean) - ;; - ;; The following two slots are only meaningful during IR1 conversion of hairy - ;; lambda vars: - ;; - ;; The Arg-Info structure which holds information obtained from &keyword - ;; parsing. - (arg-info nil :type (or arg-info null)) - ;; - ;; If true, the Global-Var structure for the special variable which is to be - ;; bound to the value of this argument. - (specvar nil :type (or global-var null)) - ;; - ;; Set of the CONSTRAINTs on this variable. Used by constraint - ;; propagation. This is left null by the lambda pre-pass if it determine - ;; that this is a set closure variable, and is thus not a good subject for - ;; flow analysis. - (constraints nil :type (or sset null))) - -(defprinter lambda-var - name - (type :test (not (eq type *universal-type*))) - (where-from :test (not (eq where-from :assumed))) - (ignorep :test ignorep) - (arg-info :test arg-info) - (specvar :test specvar)) - - -;;;; Basic node types: - -;;; A Ref represents a reference to a leaf. Ref-Reoptimize is initially (and -;;; forever) NIL, since Refs don't receive any values and don't have any IR1 -;;; optimizer. -;;; -(defstruct (ref - (:include node (:reoptimize nil)) - (:constructor really-make-ref (derived-type source leaf inlinep)) - (:print-function %print-ref)) - ;; - ;; The leaf referenced. - (leaf nil :type leaf) - ;; - ;; For a function variable, indicates the legality of coding inline. Nil, - ;; means that there is no relevent declaration so we can do whatever we want. - (inlinep nil :type inlinep)) - -(defprinter ref - leaf - (inlinep :test inlinep)) - - -;;; Naturally, the IF node always appears at the end of a block. Node-Cont is -;;; a dummy continuation, and is there only to keep people happy. -;;; -(defstruct (cif (:include node) - (:print-function %print-if) - (:conc-name if-) - (:predicate if-p) - (:constructor make-if) - (:copier copy-if)) - ;; - ;; Continuation for the predicate. - (test nil :type continuation) - ;; - ;; The blocks that we execute next in true and false case, respectively (may - ;; be the same.) - (consequent nil :type cblock) - (alternative nil :type cblock)) - -(defprinter if - (test :prin1 (continuation-use test)) - consequent - alternative) - - -(defstruct (cset (:include node - (:derived-type *universal-type*)) - (:print-function %print-set) - (:conc-name set-) - (:predicate set-p) - (:constructor make-set) - (:copier copy-set)) - ;; - ;; Descriptor for the variable set. - (var nil :type basic-var) - ;; - ;; Continuation for the value form. - (value nil :type continuation)) - -(defprinter set - var - (value :prin1 (continuation-use value))) - - -;;; The Basic-Combination structure is used to represent both normal and -;;; multiple value combinations. In a local function call, this node appears -;;; at the end of its block and the body of the called function appears as the -;;; successor. The NODE-CONT remains the continuation which receives the -;;; value of the call. -;;; -(defstruct (basic-combination (:include node)) - ;; - ;; Continuation for the function. - (fun nil :type continuation) - ;; - ;; List of continuations for the args. In a local call, an argument - ;; continuation may be replaced with NIL to indicate that the corresponding - ;; variable is unreferenced, and thus no argument value need be passed. - (args nil :type list) - ;; - ;; The kind of function call being made. :Full is a standard call, with the - ;; function being determined at run time. :Local is used when we are calling - ;; a function known at compile time. The IR1 for the called function is - ;; spliced into the flow graph for the caller. Calls to known global - ;; functions are represented by storing the Function-Info for the function in - ;; this slot. - (kind :full :type (or (member :full :local) function-info)) - ;; - ;; Some kind of information attached to this node by the back end. - (info nil)) - - -;;; The Combination node represents all normal function calls, including -;;; FUNCALL. This is distinct from Basic-Combination so that an MV-Combination -;;; isn't Combination-P. -;;; -(defstruct (combination (:include basic-combination) - (:constructor really-make-combination (source fun)) - (:print-function %print-combination))) - -(defprinter combination - (fun :prin1 (continuation-use fun)) - (args :prin1 (mapcar #'(lambda (x) - (if x - (continuation-use x) - "<deleted>")) - args))) - - -;;; An MV-Combination is to Multiple-Value-Call as a Combination is to Funcall. -;;; This is used to implement all the multiple-value receiving forms. -;;; -(defstruct (mv-combination (:include basic-combination) - (:constructor make-mv-combination (source fun)) - (:print-function %print-mv-combination))) - -(defprinter mv-combination - (fun :prin1 (continuation-use fun)) - (args :prin1 (mapcar #'continuation-use args))) - - -;;; The Bind node marks the beginning of a lambda body and represents the -;;; creation and initialization of the variables. -;;; -(defstruct (bind (:include node) - (:print-function %print-bind)) - ;; - ;; The lambda we are binding variables for. Null when we are creating the - ;; Lambda during IR1 translation. - (lambda nil :type (or clambda null))) - -(defprinter bind - lambda) - - -;;; The Return node marks the end of a lambda body. It collects the return -;;; values and represents the control transfer on return. This is also where -;;; we stick information used for Tail-Set type inference. -;;; -(defstruct (creturn (:include node) - (:print-function %print-return) - (:conc-name return-) - (:predicate return-p) - (:constructor make-return) - (:copier copy-return)) - ;; - ;; The lambda we are returing from. Null temporarily during ir1tran. - (lambda nil :type (or clambda null)) - ;; - ;; The continuation which yields the value of the lambda. - (result nil :type continuation) - ;; - ;; The union of the node-derived-type of all uses of the result other than by - ;; a local call, intersected with the result's asserted-type. If there are - ;; no non-call uses, this is *empty-type*. - (result-type *wild-type* :type ctype)) - - -(defprinter return - lambda - result-type) - - -;;;; Non-local exit support: -;;; -;;; In IR1, we insert special nodes to mark potentially non-local lexical -;;; exits. - - -;;; The Entry node serves to mark the start of the dynamic extent of a lexical -;;; exit. It is the mess-up node for the corresponding :Entry cleanup. -;;; -(defstruct (entry (:include node) - (:print-function %print-entry)) - ;; - ;; All of the continuations for potential non-local exits to this point. - (exits nil :type list)) - -(defprinter entry - exits) - - -;;; The Exit node marks the place at which exit code would be emitted, if -;;; necessary. This is interposed between the uses of the exit continuation -;;; and the exit continuation's DEST. Instead of using the returned value -;;; being delivered directly to the exit continuation, it is delivered to our -;;; Value continuation. The original exit continuation is the exit node's -;;; CONT. -;;; -(defstruct (exit (:include node) - (:print-function %print-exit)) - ;; - ;; The Entry node that this is an exit for. If null, this is a degenerate - ;; exit. A degenerate exit is used to "fill" an empty block (which isn't - ;; allowed in IR1.) In a degenerate exit, Value is always also null. - (entry nil :type (or entry null)) - ;; - ;; The continuation yeilding the value we are to exit with. If NIL, then no - ;; value is desired (as in GO). - (value nil :type (or continuation null))) - -(defprinter exit - (entry :test entry) - (value :test value)) - - -;;;; Miscellaneous IR1 structures: - -(defstruct (undefined-warning - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Delayed-Warning ~S>" - (undefined-warning-name s))))) - ;; - ;; The name of the unknown thing. - (name nil :type (or symbol list)) - ;; - ;; The kind of reference to Name. - (kind nil :type (member :function :type :variable)) - ;; - ;; The number of times this thing was used. - (count 0 :type unsigned-byte) - ;; - ;; A list of COMPILER-ERROR-CONTEXT structures describing places where this - ;; thing was used. Note that we only record the first - ;; *UNDEFINED-WARNING-LIMIT* calls. - (warnings () :type list)) 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/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/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/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 3e8da5138f23c196b64e98f6b3988ee663c38206..0000000000000000000000000000000000000000 --- a/compiler/old-rt/parms.lisp +++ /dev/null @@ -1,81 +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 inclusive upper bound on a cost. We want to write cost frobbing -;;; code so that it is portable, but works on fixnums. This constant should be -;;; defined so that adding two costs cannot result in fixnum overflow. -;;; -(defconstant most-positive-cost (1- (expt 2 20))) - - -;;;; 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/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 ee4434839691825e69a93ad2b2befba508faa74e..0000000000000000000000000000000000000000 --- a/compiler/old-rt/vm.lisp +++ /dev/null @@ -1,383 +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)) - - -;;; 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 80187911d5564251e3860f4bcb984ae0ee35804a..0000000000000000000000000000000000000000 --- a/compiler/pack.lisp +++ /dev/null @@ -1,1020 +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 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) - - -;;;; 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 -;;; environment's blocks (always-live /= 0), then there is a conflict. -;;; -- :Environment is similar to :Component, except that we iterate only over -;;; the blocks in the environment. -;;; -- 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 unsigned-byte 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))))) - ((eq kind :environment) - (let ((loc-live (svref (finite-sb-always-live sb) offset))) - (do-environment-ir2-blocks (env-block (tn-environment tn) nil) - (when (/= (sbit loc-live (ir2-block-number env-block)) 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 unsigned-byte 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. -;;; -- :Environment is similar to :Component, except that we iterate over only -;;; the blocks in the environment. -;;; -- 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 unsigned-byte 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)))) - ((eq kind :environment) - (do-environment-ir2-blocks (env-block (tn-environment tn)) - (let ((num (ir2-block-number env-block))) - (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))) - (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 (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 *sb-list*) - (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 (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) (- needed-size size))) - (new-size (+ size inc)) - (conflicts (finite-sb-conflicts sb)) - (block-size (if (zerop (length conflicts)) - (ir2-block-count *compile-component*) - (length (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 *sb-list*) - (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)) - - -;;; Failed-To-Pack-Load-TN-Error -- Internal -;;; -;;; If load TN packing fails, try to give a helpful error message. We find -;;; which operand is losing, and flame if there is no way the restriction could -;;; ever be satisfied. -;;; -(defun failed-to-pack-load-tn-error (op) - (declare (type tn-ref op)) - (multiple-value-bind (arg-p n more-p costs load-scs incon) - (get-operand-info op) - (declare (ignore costs)) - (assert (not more-p)) - (let ((load-sc (svref *sc-numbers* - (svref load-scs - (sc-number - (tn-sc (tn-ref-tn op))))))) - (assert load-sc) - (error "Unable to pack a Load-TN in SC ~S for the ~:R ~ - ~:[result~;argument~] to~@ - the ~S VOP.~@ - Perhaps all SC elements already in use by VOP?~:[~;~@ - Current cost info inconsistent with that in effect at compile ~ - time. Recompile.~%Compilation order may be incorrect.~]" - (sc-name load-sc) - n arg-p - (vop-info-name (vop-info (tn-ref-vop op))) - incon)))) - - -;;;; Register saving: - -;;; Orignal-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)) - (tn-save-tn tn) - tn)) - - -;;; 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 after) - (declare (type node node) (type ir2-block block) - (type tn src dest) (type (or vop null) after)) - (emit-load-template node block - (template-or-lose 'move-operand) - src dest - (list (or (svref (sc-load-functions (tn-sc dest)) - (sc-number (tn-sc src))) - (no-load-function-error src dest))) - after) - (undefined-value)) - - -;;; Save-Complex-Writer-TN -- Internal -;;; -;;; For TNs that have other than one writer, we save the TN before each -;;; call. -;;; -(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))) - (emit-operand-load node block tn save vop) - (emit-operand-load node block save tn next))) - - -;;; Save-Single-Writer-TN -- Internal -;;; -;;; For TNs that have a single writer, we save the TN at the writer, and -;;; only restore after the call. -;;; -(defun save-single-writer-tn (tn vop) - (let* ((old-save (tn-save-tn tn)) - (save (or old-save (pack-save-tn tn)))) - - (unless old-save - (let ((writer (tn-ref-vop (tn-writes tn)))) - (emit-operand-load (vop-node writer) (vop-block writer) - tn save (vop-next writer))) - (setf (tn-kind save) :save-once)) - - (emit-operand-load (vop-node vop) (vop-block vop) save tn (vop-next 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. -;;; - - -;;; 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))) - (let ((writes (tn-writes tn)) - (save (tn-save-tn tn))) - (if (or (and save (eq (tn-kind save) :save-once)) - (and writes (null (tn-ref-next writes)))) - (save-single-writer-tn tn vop) - (save-complex-writer-tn tn vop))))))) - - (undefined-value)) - - -;;;; 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))) - (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))) - 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)) - (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) - (declare (type tn tn) (type sc sc) (inline member)) - (let* ((sb (sc-sb sc)) - (element-size (sc-element-size sc)) - (size (finite-sb-current-size sb)) - (start-offset (finite-sb-last-offset sb))) - (let ((current-start start-offset) - (wrap-p nil)) - (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) - (member current-start (sc-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 (1+ offset)) - (return)))) - (incf current-start)))))) - - -;;;; 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*) - - -;;; 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 *sb-list*) - (when (eq (sb-kind sb) :finite) - (fill (finite-sb-live-tns sb) nil))) - - (do-live-tns (tn (ir2-block-live-in block) block) - (let ((sb (sc-sb (tn-sc tn)))) - (when (eq (sb-kind sb) :finite) - (setf (svref (finite-sb-live-tns sb) (tn-offset tn)) 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)) - (sb (sc-sb (tn-sc tn)))) - (when (eq (sb-kind sb) :finite) - (setf (svref (finite-sb-live-tns sb) (tn-offset tn)) - nil))))) - (do ((ref (vop-refs current) (tn-ref-next-ref ref))) - ((null ref)) - (let* ((tn (tn-ref-tn ref)) - (sb (sc-sb (tn-sc tn)))) - (when (eq (sb-kind sb) :finite) - (let ((tns (finite-sb-live-tns sb)) - (offset (tn-offset tn))) - (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-Conflicts-In-SB -- Internal -;;; -;;; Kind of like Offset-Conflicts-In-SB, except that it uses the Live-TNs -;;; (must already be computed) and the VOP refs to determine whether a Load-TN -;;; for OP could be packed in the specified location. There is a conflict if -;;; either: -;;; 1] Live-TNs is non-null for that location. This means that there is a -;;; live non-load TN in that location after the VOP. -;;; 2] The reference is a result, and the same location is either: -;;; -- Used by some other result. -;;; -- Used in any way after the reference (exclusive). -;;; 3] 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 2 (and 3) 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. -;;; -;;; In 2 and 3 above, the second bullet corresponds conflicts with -;;; temporaries or between arguments and results. -;;; -;;; In 2 and 3 above, 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. -;;; -(defun load-tn-conflicts-in-sb (op sb offset) - (assert (eq (sb-kind sb) :finite)) - (or (svref (finite-sb-live-tns sb) offset) - (let ((vop (tn-ref-vop op))) - (macrolet ((same (ref) - `(let ((tn (tn-ref-tn ,ref)) - (ltn (tn-ref-load-tn ,ref))) - (or (and (eq (sc-sb (tn-sc tn)) sb) - (eql (tn-offset tn) offset)) - (and ltn - (eq (sc-sb (tn-sc ltn)) sb) - (eql (tn-offset ltn) offset))))) - (is-op (ops) - `(do ((ops ,ops (tn-ref-across ops))) - ((null ops) nil) - (when (and (same ops) - (not (eq ops op))) - (return t)))) - (is-ref (refs end) - `(do ((refs ,refs (tn-ref-next-ref refs))) - ((eq refs ,end) nil) - (when (same refs) (return t))))) - - (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))))))) - - -;;; 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. -;;; -(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)) - (sb (sc-sb (tn-sc tn)))) - (if (and (eq (sc-sb sc) sb) - (member loc (sc-locations sc)) - (not (load-tn-conflicts-in-sb op sb loc))) - loc - nil))))) - - -;;; Select-Load-Tn-Location -- Internal -;;; -;;; Select a legal location for a load TN for Op in SC. We just iterate -;;; over the SCs 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)) - (unless (= (sc-element-size sc) 1) - (error "Can't have a load-TN with SC element size /= 1.")) - (let ((sb (sc-sb sc))) - (dolist (loc (sc-locations sc) nil) - (unless (load-tn-conflicts-in-sb op sb loc) - (return loc))))) - - -(defevent spill-conditional-arg-tn - "Spilled a TN that was an arg to a :CONDITIONAL VOP.") - -;;; SPILL-CONDITIONAL-ARG-TN -- Internal -;;; -;;; Fix things up when we spill a TN for loading of an argument to a -;;; conditional VOP. We have to insert a block on the branch target path that -;;; restores the spilled value. In addition to inserting a block in the IR1 -;;; flow graph, we must also insert an IR2 block into the emit order and frob -;;; the assembly level control flow by emitting or modifying branches. -;;; -;;; We change the conditional's target label to be the new block's label. -;;; We insert the new block in the emit order immediately after the conditional -;;; block. In order to do this, we must insert a branch at the end of the -;;; conditional block if it currently drops through. -;;; -(defun spill-conditional-arg-tn (victim vop) - (declare (type tn tn) (type vop vop)) - (let* ((info-args (vop-codegen-info vop)) - (lab (first info-args)) - (node (vop-node vop)) - (2block (vop-block vop)) - (block (ir2-block-block 2block)) - (succ (find lab (block-succ block) :key #'block-label)) - (new (insert-cleanup-code block succ node - "<conditional spill hack>")) - (new-2block (make-ir2-block new))) - (event spill-conditional-arg-tn node) - (setf (block-info new) new-2block) - (setf (first info-args) (block-label new)) - (emit-operand-load node new-2block (tn-save-tn victim) victim nil) - (vop branch node new-2block lab) - - (let ((next-lab (block-label (ir2-block-block (ir2-block-next 2block))))) - (add-to-emit-order new-2block 2block) - (unless (eq (vop-info-name (ir2-block-last-vop 2block)) 'branch) - (vop branch node 2block next-lab))) - (undefined-value))) - - -(defevent spill-tn "Spilled a TN to satisfy operand SC restriction.") - -;;; Spill-And-Pack-Load-TN -- Internal -;;; -;;; Handle the case of Pack-Load-TN where there isn't any location free -;;; that we can pack into. What we do is spill some live TN to memory, and -;;; then pack the load TN in the freed location. -;;; -;;; When we find any location in SC that isn't in use within the VOP, we spill -;;; the TN in that location. There must be some TN live in every location, -;;; since normal load TN packing failed. -;;; -;;; We never spill component TNs, since there are used magically within VOPs. -;;; -;;; ### Somewhat dubious to spill environment TNs, but we would get in -;;; ### trouble if we never did. -;;; -;;; Spilling is done using the same mechanism as register saving. -;;; -(defun spill-and-pack-load-tn (sc op) - (declare (type sc sc) (type tn-ref op)) - (let ((vop (tn-ref-vop op)) - (sb (sc-sb sc))) - (event spill-tn (vop-node vop)) - - (dolist (loc (sc-locations sc) - (failed-to-pack-load-tn-error op)) - (when (do ((ref (vop-refs vop) (tn-ref-next-ref ref))) - ((null ref) t) - (let ((op (tn-ref-tn ref))) - (when (and (eq (sc-sb (tn-sc op)) sb) - (eql (tn-offset op) loc)) - (return nil))) - (let ((ltn (tn-ref-load-tn ref))) - (when (and ltn - (eq (sc-sb (tn-sc ltn)) sb) - (eql (tn-offset ltn) loc)) - (return nil)))) - (let ((victim (svref (finite-sb-live-tns sb) loc))) - (assert victim) - (unless (eq (tn-kind victim) :component) - (save-complex-writer-tn victim vop) - (when (eq (template-result-types (vop-info vop)) :conditional) - (spill-conditional-arg-tn victim vop)) - - (let ((res (make-tn 0 :load nil sc))) - (setf (tn-offset res) loc) - (return res)))))))) - - -;;; Pack-Load-TN -- Internal -;;; -;;; Try to pack a load TN in the sc indicated by SCs. If this fails, then -;;; we let Spill-And-Pack-Load-TN do its thing. We return the packed load TN. -;;; -(defun pack-load-tn (scs op) - (declare (type sc-vector scs) (type tn-ref op)) - (let ((vop (tn-ref-vop op))) - (compute-live-tns (vop-block vop) vop)) - - (let* ((sc (svref *sc-numbers* - (svref scs (sc-number (tn-sc (tn-ref-tn op)))))) - (loc (or (find-load-tn-target op sc) - (select-load-tn-location op sc)))) - (if loc - (let ((res (make-tn 0 :load nil sc))) - (setf (tn-offset res) loc) - res) - (spill-and-pack-load-tn sc op)))) - - -;;; 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. -;;; -(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 ((ref-scn (sc-number (tn-sc (tn-ref-tn op))))) - (unless (eql (svref (car scs) ref-scn) ref-scn) - (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) - (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, in order of decreasing -;;; desirability (according to the costs.) If Restricted, then we can only -;;; pack in TN-SC, not in any Alternate-SCs. -;;; -(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)))) - (do ((sc fsc (pop alternates))) - ((null sc) - (failed-to-pack-error tn restricted)) - (let ((loc (or (find-ok-target-offset original sc) - (select-location original sc) - (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)) - - -(defun pack-targeting-tns (tn) - ) - -;;; 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. -;;; -(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)))) - (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 (conflicts-in-sc tn sc offset) - (error "~S wired to a location that it conflicts with." tn)) - (add-location-conflicts tn sc offset))) - - -;;; Pack -- Interface -;;; -(defun pack (component) - (let ((*in-pack* t)) - (init-sb-vectors component) - - (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))))) - - (let ((2comp (component-info component))) - (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn))) - ((null tn)) - (pack-wired-tn tn)) - - (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn))) - ((null tn)) - (when (eq (tn-kind tn) :component) - (pack-tn tn t))) - - (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn))) - ((null tn)) - (unless (tn-offset tn) - (pack-tn tn t))) - - (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn))) - ((null tn)) - (unless (and (eq (tn-kind tn) :normal) - (not (tn-global-conflicts tn))) - (pack-tn tn nil) - (pack-targeting-tns tn)))) - - (let ((*live-block* nil) - (*live-vop* nil)) - (do-ir2-blocks (block component) - (let ((ltns (ir2-block-local-tns block))) - (dotimes (i (ir2-block-local-tn-count block)) - (let ((tn (svref ltns i))) - (unless (or (null tn) - (eq tn :more) - (tn-global-conflicts tn) - (tn-offset tn)) - (pack-tn tn nil) - (pack-targeting-tns tn))))) - - (emit-saves block) - (pack-load-tns block))) - - (undefined-value))) diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp deleted file mode 100644 index eaae34c68e5230d1b2666dcb3b6d8309b24afd01..0000000000000000000000000000000000000000 --- a/compiler/proclaim.lisp +++ /dev/null @@ -1,288 +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 load-time support for declaration processing. It is -;;; split off from the compiler so that the compiler doesn'thave to be in the -;;; cold load. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; The Cookie holds information about the compilation environment for a node. -;;; See the Node definition for a description of how it is used. -;;; -(defstruct cookie - (speed nil :type (or (rational 0 3) null)) - (space nil :type (or (rational 0 3) null)) - (safety nil :type (or (rational 0 3) null)) - (cspeed nil :type (or (rational 0 3) null)) - (brevity nil :type (or (rational 0 3) null)) - (debug nil :type (or (rational 0 3) null))) - - -;;; The *default-cookie* represents the current global compiler policy -;;; information. Whenever the policy is changed, we copy the structure so that -;;; old uses will still get the old values. -;;; -(proclaim '(type cookie *default-cookie*)) -(defvar *default-cookie* (make-cookie :safety 1 :speed 1 :space 1 :cspeed 1 - :brevity 1 :debug 1)) - - -;;; Check-Function-Name -- Interface -;;; -;;; Check that Name is a valid function name, returning the name if OK, and -;;; doing an error if not. In addition to checking for basic well-formedness, -;;; we also check that symbol names are not NIL or the name of a special form. -;;; -(defun check-function-name (name) - (typecase name - (list - (unless (and (consp name) (consp (cdr name)) - (null (cddr name)) (eq (car name) 'setf) - (symbolp (cadr name))) - (compiler-error "Illegal function name: ~S." name)) - name) - (symbol - (when (eq (info function kind name) :special-form) - (compiler-error "Special form is an illegal function name: ~S." name)) - name) - (t - (compiler-error "Illegal function name: ~S." name)))) - - -;;; Define-Function-Name -- Interface -;;; -;;; Check the legality of a function name that is being introduced. If it -;;; names a macro, then give a warning and blast the macro information. -;;; -(proclaim '(function define-function-name (t) void)) -(defun define-function-name (name) - (check-function-name name) - (ecase (info function kind name) - (:function) - (:special-from - (compiler-error "~S names a special form, so cannot be a function." name)) - (:macro - (compiler-warning "~S previously defined as a macro." name) - (setf (info function kind name) :function) - (setf (info function where-from name) :assumed) - (clear-info function macro-function name)) - ((nil) - (setf (info function kind name) :function))) - name) - - -;;; Process-Optimize-Declaration -- Interface -;;; -;;; Return a new cookie containing the policy information represented by the -;;; optimize declaration Spec. Any parameters not specified are defaulted from -;;; Cookie. -;;; -(proclaim '(function process-optimize-declaration (list cookie) cookie)) -(defun process-optimize-declaration (spec cookie) - (let ((res (copy-cookie cookie))) - (dolist (quality (cdr spec)) - (let ((quality (if (atom quality) (list quality 3) quality))) - (if (and (consp (cdr quality)) (null (cddr quality)) - (rationalp (second quality)) (<= 0 (second quality) 3)) - (let ((value (second quality))) - (case (first quality) - (speed (setf (cookie-speed res) value)) - (space (setf (cookie-space res) value)) - (safety (setf (cookie-safety res) value)) - (compilation-speed (setf (cookie-cspeed res) value)) - (brevity (setf (cookie-brevity res) value)) - (debug-info (setf (cookie-debug res) value)) - (t - (compiler-warning "Unknown optimization quality ~S in ~S." - (car quality) spec)))) - (compiler-warning - "Malformed optimization quality specifier ~S in ~S." - quality spec)))) - res)) - - -;;; %Proclaim -- Interface -;;; -;;; This function is the guts of proclaim, since it does the global -;;; environment updating. -;;; -;;; ### At least for now, blow off type declarations when the compiler hasn't -;;; been loaded yet. This allows us to delay putting the type system into the -;;; cold load. -;;; -(defun %proclaim (form) - (unless (consp form) - (error "Malformed PROCLAIM spec: ~S." form)) - - (let ((kind (first form)) - (args (rest form))) - (case kind - (special - (dolist (name args) - (unless (symbolp name) - (error "Variable name is not a symbol: ~S." name)) - (clear-info variable constant-value name) - (setf (info variable kind name) :special))) - (type - (when (fboundp 'specifier-type) - (let ((type (specifier-type (first args)))) - (dolist (name (rest args)) - (unless (symbolp name) - (error "Variable name is not a symbol: ~S." name)) - (setf (info variable type name) type) - (setf (info variable where-from name) :declared))))) - (ftype - (when (fboundp 'specifier-type) - (let ((type (specifier-type (first args)))) - (unless (csubtypep type (specifier-type 'function)) - (error "Declared functional type is not a function type: ~S." - (first args))) - (dolist (name (rest args)) - (define-function-name name) - (setf (info function type name) type) - (setf (info function where-from name) :declared))))) - (function - (when (fboundp 'specifier-type) - (%proclaim `(ftype (function . ,(rest args)) ,(first args))))) - (optimize - (setq *default-cookie* - (process-optimize-declaration form *default-cookie*))) - ((inline notinline maybe-inline) - (dolist (name args) - (define-function-name name) - (setf (info function inlinep name) - (case kind - (inline :inline) - (notinline :notinline) - (maybe-inline :maybe-inline))))) - (declaration - (dolist (decl args) - (unless (symbolp decl) - (error "Declaration to be RECOGNIZED is not a symbol: ~S." decl)) - (setf (info declaration recognized decl) t))) - (t - (if (member kind type-specifier-symbols) - (%proclaim `(type . ,form)) - (error "Unrecognized proclamation: ~S." form))))) - (undefined-value)) -;;; -(setf (symbol-function 'proclaim) #'%proclaim) - - -;;; %%Compiler-Defstruct -- Interface -;;; -;;; This function updates the global compiler information to represent the -;;; definition of the the structure described by Info. -;;; -(defun %%compiler-defstruct (info) - (declare (type defstruct-description info)) - - (let ((name (dd-name info))) - (dolist (inc (dd-includes info)) - (let ((info (info type structure-info inc))) - (unless info - (error "Structure type ~S is included by ~S but not defined." - inc name)) - (pushnew name (dd-included-by info)))) - - (let ((old (info type structure-info name))) - (when old - (setf (dd-included-by info) (dd-included-by old)))) - - (setf (info type kind name) :structure) - (setf (info type structure-info name) info) - (when (info type expander name) - (setf (info type expander name) nil)) - (%note-type-defined name)) - - ;;; ### Should declare arg/result types. - (let ((copier (dd-copier info))) - (when copier - (define-function-name copier) - (setf (info function where-from copier) :defined))) - - ;;; ### Should make a known type predicate. - (let ((predicate (dd-predicate info))) - (when predicate - (define-function-name predicate) - (setf (info function where-from predicate) :defined))) - - (dolist (slot (dd-slots info)) - (let ((fun (dsd-accessor slot))) - (define-function-name fun) - (setf (info function accessor-for fun) info) - ;; - ;; ### Bootstrap hack... - ;; This blows away any inverse that has been loaded into the bootstrap - ;; environment. Probably this should be more general (expanders, etc.), - ;; and also perhaps done on other functions. - (when (info setf inverse fun) - (setf (info setf inverse fun) nil)) - - (unless (dsd-read-only slot) - (setf (info function accessor-for `(setf ,fun)) info)))) - (undefined-value)) - -(setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct) - - -;;; %NOTE-TYPE-DEFINED -- Interface -;;; -;;; Note that the type Name has been (re)defined, updating the undefined -;;; warnings and VALUES-SPECIFIER-TYPE cache. -;;; -(defun %note-type-defined (name) - (declare (symbol name)) - (when (boundp '*undefined-warnings*) - (note-name-defined name :type)) - (when (boundp '*values-specifier-type-cache-vector*) - (values-specifier-type-cache-clear)) - (undefined-value)) - - -;;;; Dummy definitions of COMPILER-ERROR, etc. -;;; -;;; Until the compiler is properly loaded, we make the compiler error -;;; functions synonyms for the obvious standard error function. -;;; - -(defun compiler-error (string &rest args) - (apply #'error string args)) - -(defun compiler-warning (string &rest args) - (apply #'warn string args)) - -(defun compiler-note (string &rest args) - (apply #'warn string args)) - -(defun compiler-error-message (string &rest args) - (apply #'warn string args)) - - -;;; Alien=>Lisp-Transform -- Internal -;;; -;;; This is the transform for alien-operators and other alien-valued -;;; things which may be evaluated normally to yield an alien-value structure. -;;; -(defun alien=>lisp-transform (form) - (multiple-value-bind (binds stuff res) - (analyze-alien-expression nil form) - `(let* ,(reverse binds) - ,(ignore-unreferenced-vars binds) - ,@(nreverse stuff) - ,(if (ct-a-val-alien res) - (ct-a-val-alien res) - `(lisp::make-alien-value - ,(ct-a-val-sap res) - ,(ct-a-val-offset res) - ,(ct-a-val-size res) - ',(ct-a-val-type res)))))) diff --git a/compiler/profile.lisp b/compiler/profile.lisp deleted file mode 100644 index 2aa4d3cb56c3cb5845acc175c19dd4eda76004f0..0000000000000000000000000000000000000000 --- a/compiler/profile.lisp +++ /dev/null @@ -1,49 +0,0 @@ -;;; -*- Package: C -*- -(in-package 'c) - -(use-package "PROFILE") - -(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 - select-representations - lifetime-pre-pass - lifetime-flow-analysis - reset-current-conflict - lifetime-post-pass - delete-unreferenced-tns - - pack-wired-tn - pack-tn - pack-targeting-tns - pack-load-tns - emit-saves - - generate-code - fasl-dump-component - clear-ir2-info - macerate-ir1-component - merge-top-level-lambdas - ir1-finalize - 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 48b4fbaa7e40b44a1e134b8a79d75adee0c0636a..0000000000000000000000000000000000000000 --- a/compiler/pseudo-vops.lisp +++ /dev/null @@ -1,37 +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 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) - (:generator 0 - (emit-label start-lab))) - - -;;; 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 - (unassemble - (funcall (symbol-function name) vop x y)))) - diff --git a/compiler/represent.lisp b/compiler/represent.lisp deleted file mode 100644 index 77f7b3bcade52fbdc9d8f356189651da449df977..0000000000000000000000000000000000000000 --- a/compiler/represent.lisp +++ /dev/null @@ -1,471 +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 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 (position-in #'tn-ref-across ref refs) 1) - t - more-cost - nil - nil)) - (when (eq refs ref) - (let ((parse (vop-parse-or-lose (vop-info-name info)))) - (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 (eql (svref restr i) i) - (res (svref *sc-numbers* 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 *sc-numbers* 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 - (mapcar #'sc-name (listify-restrictions load-scs)) - 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 *sc-numbers* i))) - (when sc - (let ((moves (sc-load-functions sc))) - (dolist (const (sc-constant-scs sc)) - (unless (svref moves (sc-number const)) - (error "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)) - (error "No move function defined to load SC ~S from alternate ~ - SC ~S." - (sc-name sc) (sc-name alt))) - (unless (svref (sc-load-functions alt) i) - (error "No move function defined to save SC ~S to alternate ~ - SC ~S." - (sc-name sc) (sc-name alt))))))))) -;;; -(check-move-function-consistency) - - -;;; 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. We ignore references -;;; by the MOVE VOP, since counting them 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. -;;; -(defun select-tn-representation (tn scs costs) - (declare (type tn tn) (type sc-vector costs)) - (dolist (scn scs) - (setf (svref costs scn) 0)) - - (macrolet ((scan-refs (refs ops-slot costs-slot more-costs-slot) - `(do ((ref ,refs (tn-ref-next ref))) - ((null ref)) - (let* ((vop (tn-ref-vop ref)) - (info (vop-info vop))) - (unless (eq (vop-info-name info) 'move) - (do ((cost (,costs-slot info) (cdr cost)) - (op (,ops-slot vop) (tn-ref-across op))) - ((null cost) - (add-costs (,more-costs-slot info))) - (when (eq op ref) - (add-costs (car cost)) - (return))))))) - (add-costs (cost) - `(let ((cost ,cost)) - (dolist (scn scs) - (let ((res (svref cost scn))) - (unless res - (bad-costs-error ref)) - (incf (svref costs scn) res)))))) - - (scan-refs (tn-reads tn) vop-args vop-info-arg-costs - vop-info-more-arg-costs) - (scan-refs (tn-writes tn) vop-results vop-info-result-costs - vop-info-more-result-costs)) - - (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 *sc-numbers* min-scn))) - - -;;; 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 (lambda-home - (block-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)) - - -;;; 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 the operand restriction, 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. -;;; -;;; 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 scs before) - (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before)) - (let* ((op-tn (tn-ref-tn op)) - (op-sc (tn-sc op-tn)) - (op-scn (sc-number op-sc)) - (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-costs-error op)) - (when (eql (svref scs i) i) - (let ((res (if write-p - (svref (sc-move-vops op-sc) i) - (svref (sc-move-vops (svref *sc-numbers* i)) - op-scn)))) - (when res - (let ((temp (make-representation-tn i))) - (change-tn-ref-tn op temp) - (cond - ((not write-p) - (emit-move-template node block res op-tn temp before)) - ((null (tn-reads op-tn))) - (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. -;;; -(proclaim '(inline coerce-some-operands)) -(defun coerce-some-operands (ops load-scs before) - (declare (type (or tn-ref null) ops) (list load-scs) - (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 (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) (vop-info-arg-load-scs info) vop) - (coerce-some-operands (vop-results vop) (vop-info-result-load-scs info) - (vop-next vop)))) - - -;;; 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. -;;; -(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 (svref (sc-move-arg-vops pass-sc) - (sc-number (tn-sc val-tn))))) - (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-representation-tn - (first (primitive-type-scs - *any-primitive-type*)))) - (emit-context-template - node block - (template-or-lose 'compute-old-nfp) - 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))) - (coerce-some-operands (vop-args new) (vop-info-arg-load-scs res) - (if prev - (vop-next prev) - (ir2-block-start-vop block))))))) - (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. -;;; -(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* ((x (tn-ref-tn (vop-args vop))) - (y (tn-ref-tn (vop-results vop))) - (res (svref (sc-move-vops (tn-sc y)) - (sc-number (tn-sc x))))) - (cond (res - (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. 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)) - (unless (tn-sc tn) - (let* ((scs (primitive-type-scs (tn-primitive-type tn))) - (sc (if (rest scs) - (select-tn-representation tn scs costs) - (svref *sc-numbers* (first scs))))) - (assert sc) - (setf (tn-sc tn) sc)))) - - (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/seqtran.lisp b/compiler/seqtran.lisp deleted file mode 100644 index 9bc1f687b3d0050a0efc9407be601308349f8ba0..0000000000000000000000000000000000000000 --- a/compiler/seqtran.lisp +++ /dev/null @@ -1,539 +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 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) (vector *)) - '(aref s i)) - -(deftransform elt ((s i) (list *)) - '(nth i s)) - -(deftransform %setelt ((s i v) (vector * *)) - '(%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)) - (if-p (if-p (continuation-dest (node-cont node))))) - (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)) - ',(if if-p t els) - ,(frob (cdr els))) - 'nil))) - (frob val)))) - - -#|Inline expansion is available... - -;;; For Adjoin, just turn into a member and let the member transform -;;; worry about it. -;;; -(deftransform adjoin ((item list &key (key #'identity) test test-not)) - `(if (member (funcall key item) list - ,@(when test '(:test test)) - ,@(when test-not '(:test-not test-not)) - :key key) - list - (cons item list))) -|# - - -#| -member map concatenate position find -|# - - -;;;; Simple string transforms: - - -(deftransform subseq ((string start &optional (end nil)) - (simple-string t &optional t)) - '(let* ((length (- (or end (length string)) - start)) - (result (make-string length))) - (%primitive byte-blt string start result 0 length) - result)) - - -(deftransform copy-seq ((seq) (simple-string)) - '(let* ((length (length seq)) - (res (make-string length))) - (%primitive byte-blt seq 0 res 0 length) - res)) - - -(deftransform replace ((string1 string2 &key (start1 0) (start2 0) - end1 end2) - (simple-string simple-string &rest t)) - '(progn - (%primitive byte-blt string2 start2 string1 start1 - (+ start1 - (min (- (or end1 (length string1)) - start1) - (- (or end2 (length string2)) - start2)))) - string1)) - - -(deftransform concatenate ((rtype &rest sequences) - (t &rest simple-string) - simple-string) - (collect ((lets) - (forms) - (all-lengths) - (args)) - (dolist (seq sequences) - (declare (ignore seq)) - (let ((n-seq (gensym)) - (n-length (gensym))) - (args n-seq) - (lets `(,n-length (length ,n-seq))) - (all-lengths n-length) - (forms `(setq start end end (+ start ,n-length))) - (forms `(%primitive byte-blt ,n-seq 0 res start end)))) - `(lambda (rtype ,@(args)) - (declare (ignore rtype)) - (let* (,@(lets) - (res (make-string (+ ,@(all-lengths)))) - (start 0) - (end 0)) - (declare (type index start end)) - ,@(forms) - res)))) - - -;;; Names of predicates that compute the same value as CHAR= when applied to -;;; characters. -;;; -(defconstant char=-functions '(eql equal char=)) - - -(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 'string-char) - (,@(if (constant-value-or-lose from-end) - '(lisp::%sp-reverse-find-character) - '(%primitive 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. -;;; -(macrolet ((frob (pred pred*) - `(deftransform ,pred ((string1 string2 &key (start1 0) end1 - (start2 0) end2)) - '(,pred* string1 string2 start1 end1 start2 end2)))) - - (frob string< string<*) - (frob string> string>*) - (frob string<= string<=*) - (frob string>= string>=*) - (frob string= string=*) - (frob string/= string/=*)) - - -;;; STRING<>=-BODY -- 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. -;;; -(defun string<>=-body (lessp equalp) - `(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)))) - - -(macrolet ((frob (name lessp equalp) - `(deftransform ,name ((string1 string2 start1 end1 start2 end2) - (simple-string simple-string t t t t)) - (string<>=-body ,lessp ,equalp)))) - (frob string<* t nil) - (frob string<=* t t) - (frob string>* nil nil) - (frob string>=* nil t)) - - -(macrolet ((frob (name result-fun) - `(deftransform ,name - ((string1 string2 start1 end1 start2 end2) - (simple-string simple-string t t t t)) - '(,result-fun - (lisp::%sp-string-compare - string1 start1 (or end1 (length string1)) - string2 start2 (or end2 (length string2))))))) - (frob string=* not) - (frob string/=* identity)) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp deleted file mode 100644 index 1bc909a7924e386c83764a25d8d6c039f4c2caab..0000000000000000000000000000000000000000 --- a/compiler/srctran.lisp +++ /dev/null @@ -1,1159 +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/srctran.lisp,v 1.9 1990/05/23 16:39:30 ram 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)) - - -;;;; 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) - (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. - -(def-source-transform truncate (x &optional y) - (if y - (values nil t) - `(truncate ,x 1))) - -(def-source-transform logeqv-two-arg (x y) `(lognot (logxor ,x ,y))) -(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 (ldb ,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) - (%primitive numerator ,n-num) - ,n-num))) -;;; -(def-source-transform denominator (num) - (once-only ((n-num `(the rational ,num))) - `(if (ratiop ,n-num) - (%primitive denominator ,n-num) - 1))) -;;; -(def-source-transform realpart (num) - (once-only ((n-num num)) - `(if (complexp ,n-num) - (%primitive realpart ,n-num) - ,n-num))) -;;; -(def-source-transform imagpart (num) - (once-only ((n-num num)) - `(cond ((complexp ,n-num) - (%primitive 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 (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 (ash n-low 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*)) - - -;;; Negative-Integer-P -- Internal -;;; -;;; Return true if Type is a integer type that includes negative numbers. -;;; -(defun negative-integer-p (type) - (declare (type numeric-type type)) - (let ((low (numeric-type-low type))) - (or (not low) (minusp low)))) - -(defoptimizer (logand derive-type) ((x y)) - (derive-integer-type - x y - #'(lambda (x y) - (let* ((x-high (numeric-type-high x)) - (y-high (numeric-type-high y)) - (both-neg (and (negative-integer-p x) - (negative-integer-p y))) - (min (cond ((not x-high) y-high) - ((not y-high) x-high) - (t - (min x-high y-high))))) - (if min - (let ((mag (ldb (byte (integer-length min) 0) -1))) - (values (if both-neg (lognot mag) 0) mag)) - (values (if both-neg nil 0) nil)))))) - - -(defoptimizer (logior derive-type) ((x y)) - (derive-integer-type - x y - #'(lambda (x y) - (let* ((x-high (numeric-type-high x)) - (y-high (numeric-type-high y)) - (one-neg (or (negative-integer-p x) - (negative-integer-p y))) - (max (cond ((not x-high) nil) - ((not y-high) nil) - (t - (max x-high y-high))))) - (if max - (let ((mag (ldb (byte (integer-length max) 0) -1))) - (values (if one-neg (lognot mag) 0) mag)) - (values (if one-neg nil 0) nil)))))) - -;;; All we attempt to do is determine the maximum integer length that the -;;; result can take on, as that is all that is interesting. - -(defoptimizer (logxor derive-type) ((x y)) - (derive-integer-type - x y - #'(lambda (x y) - (let* ((x-high (numeric-type-high x)) - (x-pos (plusp (or x-high 1))) - (y-high (numeric-type-high y)) - (y-pos (plusp (or y-high 1))) - (x-low (numeric-type-low x)) - (x-neg (minusp (or x-low -1))) - (y-low (numeric-type-low y)) - (y-neg (minusp (or y-low -1))) - (signed (or (and x-pos y-neg) (and x-neg y-pos)))) - (if (and x-high y-high x-low y-low) - (let ((max (max (integer-length x-high) - (integer-length x-low) - (integer-length y-high) - (integer-length y-low)))) - (values (if signed (ash -1 max) 0) - (1- (ash 1 max)))) - (values (if signed nil 0) nil)))))) - -(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)))) - - -;;;; Array derive-type optimizers: - -(defoptimizer (aref derive-type) ((array &rest indices)) - (let ((type (continuation-type array))) - (when (array-type-p type) - (array-type-element-type type)))) - -(defoptimizer (%aset derive-type) ((array &rest stuff)) - (let ((type (continuation-type array))) - (when (array-type-p type) - (let ((val (car (last stuff))) - (eltype (array-type-element-type type))) - (assert-continuation-type val eltype) - (continuation-type val))))) - - -;;; 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))))) - -(defoptimizer (make-array derive-type) ((dims &key initial-element - element-type initial-contents - adjustable fill-pointer - displaced-index-offset - displaced-to)) - (specifier-type - `(,(if (and (unsupplied-or-nil adjustable) - (unsupplied-or-nil displaced-to) - (unsupplied-or-nil fill-pointer)) - 'simple-array - 'array) - ,(cond ((not element-type) 't) - ((constant-continuation-p element-type) - (continuation-value element-type)) - (t - '*)) - ,(cond ((constant-continuation-p dims) - (let ((val (continuation-value dims))) - (if (listp val) val (list val)))) - ((csubtypep (continuation-type dims) - (specifier-type 'integer)) - '(*)) - (t - '*))))) - - -;;;; Miscellaneous derive-type methods: - - -(defoptimizer (code-char derive-type) ((code)) - (specifier-type 'string-char)) - - -(defoptimizer (values derive-type) ((&rest 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))) - - -;;; Check-Fixnum-Byte -- Internal -;;; -;;; If the continuations Size and Pos are constant, and represent a field -;;; that fits into a fixnum, then return the size and position as values, -;;; otherwise Give-Up. -;;; -(defun check-fixnum-byte (size pos) - (unless (and (constant-continuation-p size) - (constant-continuation-p pos)) - (give-up)) - (let ((size (continuation-value size)) - (pos (continuation-value pos))) - (when (> (+ size pos) (integer-length most-positive-fixnum)) - (give-up)) - (values size pos))) - -(defun max-value (cont) - (if (constant-continuation-p cont) - (continuation-value cont) - (let ((type (continuation-type cont))) - (or (and (numeric-type-p type) - (numeric-type-high type)) - (give-up - "Size is not constant and its upper bound is not known."))))) - -(deftransform %ldb ((size pos int) (fixnum fixnum integer)) - (let ((size-len (max-value size))) - (unless (<= size-len (integer-length most-positive-fixnum)) - (give-up "result might be up to ~D bits, can't open code %ldb." size-len)) - (if (zerop size-len) - 0 - `(logand (ash int (- pos)) - (ash ,(1- (ash 1 (integer-length most-positive-fixnum))) - (- size ,(integer-length most-positive-fixnum))))))) - -(deftransform %dpb ((new size pos int) (t t t fixnum)) - (multiple-value-bind (size pos) - (check-fixnum-byte size pos) - `(logior (ash (logand new ,(ldb (byte size 0) -1)) - pos) - (logand int ,(lognot (ash (ldb (byte size 0) -1) pos)))))) - -(deftransform %mask-field ((size pos int) (t t fixnum)) - (multiple-value-bind (size pos) - (check-fixnum-byte size pos) - `(logand int ,(ash (ldb (byte size 0) -1) pos)))) - -(deftransform %deposit-field ((new size pos int) (t t t fixnum)) - (multiple-value-bind (size pos) - (check-fixnum-byte size pos) - (let ((mask (ash (ldb (byte size 0) -1) pos))) - `(logior (logand new ,mask) - (logand int ,(lognot mask)))))) - - -;;;; Funny function stubs: -;;; -;;; These functions are the result of compiler transformations. We never -;;; actually compile a call to these functions, but we need to have a -;;; definition to allow constant folding. -;;; - -(defun %negate (x) (%primitive negate x)) -(defun %ldb (s p i) (%primitive ldb s p i)) -(defun %dpb (n s p i) (%primitive dpb n s p i)) -(defun %mask-field (s p i) (%primitive mask-field s p i)) -(defun %deposit-field (n s p i) (%primitive deposit-field n s p i)) - - -;;; Miscellanous numeric transforms: - -;;; Handle the case of a constant boole-code. -;;; -(deftransform boole ((op x y)) - (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))))) - - -;;; If arg is a constant power of two, turn * into a shift. -;;; -(deftransform * ((x y) (integer integer)) - (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 arg is a constant power of two, turn floor into a shift and mask. -;;; -(deftransform floor ((x y) (integer integer)) - (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 y) - `(values (ash (- x) ,shift) - (- (logand (- x) ,mask))) - `(values (ash x ,shift) - (logand x ,mask)))))) - -;;; Do the same for mod. -;;; -(deftransform mod ((x y) (integer integer)) - (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)) - (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)) - (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))))) - - -;;;; Character operations: - -(deftransform char-equal ((a b) (string-char string-char)) - '(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) (string-char)) - '(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) (string-char)) - '(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. -;;; -(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))))) - - -;;; 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) - ((types-intersect (continuation-type x) (continuation-type y)) - (give-up)) - (t - 'nil))) - -(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 both args are the "same" numeric type, then convert to =. This -;;; allows all of ='s expertise to come into play. "Same" means either both -;;; rational or both floats of the same format. Complexp must also be -;;; specified and identical. -;;; -- If either arg is definitely not a number, then we can compare with EQ. -;;; -- If either arg is definitely a fixnum, then we can compare with EQ. -;;; -(deftransform eql ((x y)) - (let ((x-type (continuation-type x)) - (y-type (continuation-type y)) - (char-type (specifier-type 'character)) - (fixnum-type (specifier-type 'fixnum)) - (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)) - ((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))))) - '(= x y)) - ((or (not (types-intersect x-type number-type)) - (not (types-intersect y-type number-type))) - '(eq x y)) - ((or (csubtypep x-type fixnum-type) - (csubtypep y-type fixnum-type)) - '(eq x y)) - (t - (give-up "Not enough type information to open-code."))))) - - -;;; 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). -;;; -(defun ir1-transform-< (x y) - (if (same-leaf-ref-p x y) - 'nil - (let* ((x (numeric-type-or-lose x)) - (x-lo (numeric-type-low x)) - (x-hi (numeric-type-high x)) - (y (numeric-type-or-lose y)) - (y-lo (numeric-type-low y)) - (y-hi (numeric-type-high y))) - (cond ((and x-hi y-lo (< x-hi y-lo)) - 't) - ((and y-hi x-lo (>= x-lo y-hi)) - 'nil) - (t - (give-up)))))) - - -(deftransform < ((x y) (integer integer)) - (ir1-transform-< x y)) - -(deftransform > ((x y) (integer integer)) - (ir1-transform-< y x)) - - -;;;; 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. -;;; -(proclaim '(function source-transform-transitive - (symbol list (or symbol null)) - void)) -(defun source-transform-transitive (fun args identity &optional leaf-fun) - (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) - (source-transform-transitive 'logeqv args -1 'logeqv-two-arg)) - - -;;; Source-Transform-Intransitive -- Internal -;;; -;;; Do source transformations for intransitive n-arg functions such as /. -;;; With one arg, we form the inverse using the indentity, 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 identity) - (case (length args) - ((0 2) (values nil t)) - (1 `(,function ,identity ,(first args))) - (t - (associate-arguments function (first args) (rest args))))) - -(def-source-transform - (&rest args) (source-transform-intransitive '- args 0)) -(def-source-transform / (&rest args) (source-transform-intransitive '/ args 1)) - -(deftransform - ((x y)) - (unless (and (constant-continuation-p x) (zerop (continuation-value x))) - (give-up)) - '(%negate y)) - - -;;;; Array accessors: -;;; -;;; We convert all array accessors into aref and %aset. -;;; - -(def-source-transform svref (a i) `(aref (the simple-vector ,a) ,i)) -(def-source-transform %svset (a i v) `(%aset (the simple-vector ,a) ,i ,v)) - -(def-source-transform schar (a i) `(aref (the simple-string ,a) ,i)) -(def-source-transform %scharset (a i v) `(%aset (the simple-string ,a) ,i ,v)) -(def-source-transform char (a i) `(aref (the string ,a) ,i)) -(def-source-transform %charset (a i v) `(%aset (the string ,a) ,i ,v)) - -(def-source-transform sbit (a &rest i) `(aref (the (simple-array bit) ,a) ,@i)) -(def-source-transform %sbitset (a &rest i) `(%aset (the (simple-array bit) ,a) ,@i)) -(def-source-transform bit (a &rest i) `(aref (the (array bit) ,a) ,@i)) -(def-source-transform %bitset (a &rest i) `(%aset (the (array bit) ,a) ,@i)) - - -(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)))) - - -(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))) - (type (specifier-type spec))) - (cond ((csubtypep type (specifier-type 'simple-string)) - (when initial-element - (give-up "Can't hack initial elements in strings.")) - `(truly-the ,spec (%primitive alloc-string length))) - ((csubtypep type (specifier-type 'simple-bit-vector)) - (unless (or (not initial-element) - (and (constant-continuation-p initial-element) - (eql (continuation-value initial-element) 0))) - (give-up "Can't hack non-zero initial-elements in bit-vectors.")) - `(truly-the ,spec (%primitive alloc-bit-vector length))) - ((csubtypep type (specifier-type 'simple-vector)) - `(truly-the ,spec - (%primitive alloc-g-vector length initial-element))) - (t - (give-up "Can't open-code creation of ~S." - (type-specifier type)))))) - - -;;; ### Should pass though any :INITIAL-ELEMENT to MAKE-ARRAY, but this would -;;; be a pessimization until the compiler can transform MAKE-ARRAY of strings -;;; with initial elements. Until then, it is faster to call MAKE-STRING than -;;; MAKE-ARRAY. -;;; -(def-source-transform make-string (length) - `(make-array ,length :element-type 'string-char)) - - -(deftransform array-dimension ((array dim) - ((simple-array * (*)) (integer 0 0))) - '(length array)) - - -;;;; 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)) - (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)) - (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" - (continuation-value 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. - (forms - (case (schar control (1+ command-index)) - ((#\b #\B) `(let ((*print-base* 2)) - (princ ,(pop args) ,@stream-form))) - ((#\o #\O) `(let ((*print-base* 8)) - (princ ,(pop args) ,@stream-form))) - ((#\d #\D) `(let ((*print-base* 10)) - (princ ,(pop args) ,@stream-form))) - ((#\x #\X) `(let ((*print-base* 16)) - (princ ,(pop args) ,@stream-form))) - ((#\a #\A) `(princ ,(pop args) ,@stream-form)) - ((#\s #\S) `(prin1 ,(pop args) ,@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 d59eb71fda0d5c07cd23dd324e80954ab025140d..0000000000000000000000000000000000000000 --- a/compiler/sset.lisp +++ /dev/null @@ -1,295 +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). -;;; ********************************************************************** -;;; -;;; 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 unsigned-byte 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)) - (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 82191af02f21dae958579539b35787615afed47d..0000000000000000000000000000000000000000 --- a/compiler/stack.lisp +++ /dev/null @@ -1,244 +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). -;;; ********************************************************************** -;;; -;;; 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 have less stuff on their End-Stack than we have on our Start-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. -;;; -;;; 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 - (lambda-environment - (block-lambda block))) - :key #'nlx-info-target)) - (let ((pred-stack (ir2-block-end-stack (block-info pred)))) - (unless (tailp new-stack pred-stack) - (assert (or (null pred-stack) (tailp 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 (or (tailp block2-stack block1-stack) - (null block2-stack))) ; !@#%* tailp bug. - - (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-lambda succ) - (not (eq (car (ir2-block-start-stack (block-info succ))) - top))) - (discard-unused-values block succ)))))) - - (undefined-value)) diff --git a/compiler/tn.lisp b/compiler/tn.lisp deleted file mode 100644 index a7b1b0401eab59a0dba4462277fd7b122a262c2d..0000000000000000000000000000000000000000 --- a/compiler/tn.lisp +++ /dev/null @@ -1,484 +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 utilities used for creating and manipulating TNs, and -;;; some other more assorted IR2 utilities. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; 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. -;;; -(defun delete-unreferenced-tns (component) - (macrolet ((frob (name) - `(let ((prev nil)) - (do ((tn ,name (tn-next tn))) - ((null tn)) - (cond ((or (not (eq (tn-kind tn) :normal)) - (tn-reads tn) - (tn-writes tn)) - (setq prev tn)) - (t - (if prev - (setf (tn-next prev) (tn-next tn)) - (setf ,name (tn-next tn))) - (setf (tn-offset tn) nil))))))) - (let ((2comp (component-info component))) - (frob (ir2-component-normal-tns 2comp)) - (frob (ir2-component-restricted-tns 2comp)) - (frob (ir2-component-wired-tns 2comp)))) - (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-Restricted-TN -- Interface -;;; -;;; Create a packed TN restricted to the SC with number SCN. -;;; -(defun make-restricted-tn (scn) - (declare (type sc-number scn)) - (let* ((component (component-info *compile-component*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal nil (svref *sc-numbers* scn)))) - (push-in tn-next res (ir2-component-restricted-tns component)) - res)) - - -;;; MAKE-REPRESENTATION-TN -- Interface -;;; -;;; Create a normal packed TN with representation indicated by SCN. -;;; -(defun make-representation-tn (scn) - (declare (type sc-number scn)) - (let* ((component (component-info *compile-component*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal nil (svref *sc-numbers* 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. -;;; -(defun make-wired-tn (scn offset) - (declare (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 nil (svref *sc-numbers* scn)))) - (setf (tn-offset res) offset) - (push-in tn-next res (ir2-component-wired-tns component)) - res)) - - -;;; Environment-Live-TN -- Interface -;;; -;;; Make TN be live throughout environment. TN must be referenced only in -;;; Env. Return TN. -;;; -(defun environment-live-tn (tn env) - (declare (type tn tn) (type environment env)) - (assert (eq (tn-kind tn) :normal)) - (setf (tn-kind tn) :environment) - (push tn (ir2-environment-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) - - -;;; 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 *sc-numbers* (or immed (sc-number-or-lose 'constant)))) - (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-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 *any-primitive-type* - (svref *sc-numbers* (sc-number-or-lose 'constant)))) - (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)))) - - (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))) - (assert (/= (sc-number (tn-sc tn)) (sc-number-or-lose '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)) - - -;;; TN-Environment -- Interface -;;; -;;; Return some Environment that TN is referenced in. TN must have at least -;;; one reference (either read or write.) Note that some TNs are referenced in -;;; multiple environments. -;;; -(defun tn-environment (tn) - (declare (type tn tn)) - (let ((ref (or (tn-reads tn) (tn-writes tn)))) - (assert ref) - (lambda-environment - (block-lambda - (ir2-block-block (vop-block (tn-ref-vop ref))))))) diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp deleted file mode 100644 index 5a08db8ca7d98d8f6ad8bc608539e315e94e3e28..0000000000000000000000000000000000000000 --- a/compiler/typetran.lisp +++ /dev/null @@ -1,402 +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 implements the portable IR1 semantics of -;;; type tests. The main thing we do is convert complex type tests into -;;; simpler code that can be compiled inline. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Type predicate translation: -;;; -;;; We maintain a bidirectional association between type predicates and the -;;; tested type. The presence of a predicate in this association implies that -;;; it is desirable to implement tests of this type using the predicate. This -;;; is true both of very simple types. These are either predicates that the -;;; back end is likely to have special knowledge about, or predicates so -;;; complex that the only reasonable implentation is via function call. -;;; -;;; Some standard types (such as SEQUENCE) are best tested by letting the -;;; TYPEP source transform do its thing with the expansion. These types (and -;;; corresponding predicates) are not maintained in this association. In this -;;; case, there need not be any predicate function unless it is required by -;;; Common Lisp. - -;;; These two variables maintain the translation between types and predicates. -;;; *Predicate-Types* is a hashtable that translates from type predicate names -;;; to CType objects. *Type-Predicates* is an alist (<type> . <predicate>) -;;; that translates from types to predicates. We can't use a hashtable, since -;;; there is no such thing as a Type= hashtable. Establishing this translation -;;; -(defvar *predicate-types* (make-hash-table :test #'eq)) -(proclaim '(hash-table *predicate-types*)) -(defvar *type-predicates* ()) -(proclaim '(list *type-predicates*)) - - -;;; Define-Type-Predicate -- Interface -;;; -(defmacro define-type-predicate (name type) - "Define-Type-Predicate Name Type - Establish an association between the type predicate Name and the - corresponding Type. This causes the type predicate to be recognized for - purposes of optimization." - `(progn - (setf (gethash ',name *predicate-types*) (specifier-type ',type)) - (setq *type-predicates* - (cons (cons (specifier-type ',type) ',name) - (remove ',name *type-predicates* :key #'cdr))) - (%deftransform ',name '(function (t) *) #'fold-type-predicate) - ',name)) - - - -;;;; IR1 transforms: - -;;; Typep IR1 transform -- Internal -;;; -;;; If we discover the type argument is constant during IR1 optimization, -;;; then give the source transform another chance. The source transform can't -;;; pass, since we give it an explicit constant. At worst, it will convert to -;;; %Typep, which will prevent spurious attempts at transformation (and -;;; possible repeated warnings.) -;;; -(deftransform typep ((object type)) - (unless (constant-continuation-p type) - (give-up "Can't open-code test of non-constant type.")) - `(typep object ',(continuation-value type))) - - -;;; IR1-Transform-Type-Predicate -- Internal -;;; -;;; If the continuation Object definitely is or isn't of the specified type, -;;; then return T or NIL as appropriate. Otherwise quietly Give-Up. -;;; -(defun ir1-transform-type-predicate (object type) - (declare (type continuation object) (type ctype type)) - (let ((otype (continuation-type object))) - (cond ((not (types-intersect otype type)) 'nil) - ((csubtypep otype type) 't) - (t (give-up))))) - - -;;; %Typep IR1 transform -- Internal -;;; -;;; Flush %Typep tests whose result is known at compile time. -;;; -(deftransform %typep ((object type)) - (ir1-transform-type-predicate - object - (specifier-type (continuation-value type)))) - - -;;; Fold-Type-Predicate IR1 transform -- Internal -;;; -;;; This is the IR1 transform for simple type predicates. It checks whether -;;; the single argument is known to (not) be of the appropriate type, expanding -;;; to T or NIL as apprporiate. -;;; -(deftransform fold-type-predicate ((object) * * :node node :defun-only t) - (let ((ctype (gethash (leaf-name - (ref-leaf - (continuation-use - (basic-combination-fun node)))) - *predicate-types*))) - (assert ctype) - (ir1-transform-type-predicate object ctype))) - - -;;;; Standard type predicates: - -(define-type-predicate arrayp array) -; No atom. Use (not cons) deftype. -(define-type-predicate bit-vector-p bit-vector) -(define-type-predicate characterp character) -(define-type-predicate commonp common) -(define-type-predicate compiled-function-p compiled-function) -(define-type-predicate complexp complex) -(define-type-predicate consp cons) -(define-type-predicate floatp float) -(define-type-predicate functionp function) -(define-type-predicate integerp integer) -(define-type-predicate keywordp keyword) -(define-type-predicate listp list) -(define-type-predicate null null) -(define-type-predicate numberp number) -(define-type-predicate rationalp rational) -(define-type-predicate simple-bit-vector-p simple-bit-vector) -(define-type-predicate simple-string-p simple-string) -(define-type-predicate simple-vector-p simple-vector) -(define-type-predicate stringp string) -(define-type-predicate structurep structure) -(define-type-predicate symbolp symbol) -(define-type-predicate vectorp vector) - - -;;;; Transforms for type predicates not implemented primitively: -;;; -;;; See also VM dependent transforms. - -(def-source-transform atom (x) - `(not (consp ,x))) - - -;;;; Internal predicates: -;;; -;;; These type predicates are used to implement simple cases of typep. They -;;; shouldn't be used explicitly. - -;;; Numeric type predicates: -;;; -(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) - -;;; Character type predicates. 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) - - -;;;; Typep source transform: - -;;; Transform-Numeric-Bound-Test -- Internal -;;; -;;; Return a form that tests the variable N-Object for being in the binds -;;; specified by Type. Base is the name of the base type, for declaration. We -;;; make safety locally 0 to inhibit any checking of this assertion. -;;; -(defun transform-numeric-bound-test (n-object type base) - (declare (type numeric-type type)) - (let ((low (numeric-type-low type)) - (high (numeric-type-high type))) - `(locally - (declare (optimize (safety 0))) - (and ,@(when low - (if (consp low) - `((> (the ,base ,n-object) ,(car low))) - `((>= (the ,base ,n-object) ,low)))) - ,@(when high - (if (consp high) - `((< (the ,base ,n-object) ,(car high))) - `((<= (the ,base ,n-object) ,high)))))))) - - -;;; Source-Transform-Numeric-Typep -- Internal -;;; -;;; Do source transformation of a test of a known numeric type. We can -;;; assume that the type doesn't have a corresponding predicate, since those -;;; types have already been picked off. In particular, Class must be -;;; specified, since it is unspecified only in NUMBER and COMPLEX. Similarly, -;;; we assume that Complexp is always specified. -;;; -;;; For non-complex types, we just test that the number belongs to the base -;;; type, and then test that it is in bounds. When Class is Integer, we check -;;; to see if the range is no bigger than FIXNUM. If so, we check for FIXNUM -;;; instead of INTEGER. This allows us to use fixnum comparison to test the -;;; bounds. -;;; -;;; For complex types, we must test for complex, then do the above on both -;;; the real and imaginary parts. When Class is float, we need only check the -;;; type of the realpart, since the format of the realpart and the imagpart -;;; must be the same. -;;; -(defun source-transform-numeric-typep (object type) - (let* ((class (numeric-type-class type)) - (low (numeric-type-low type)) - (high (numeric-type-high type)) - (base (ecase class - (integer - (if (and low (>= low most-negative-fixnum) - high (<= high most-positive-fixnum)) - 'fixnum - 'integer)) - (rational 'rational) - (float (or (numeric-type-format type) 'float))))) - (once-only ((n-object object)) - (ecase (numeric-type-complexp type) - (:real - `(and (typep ,n-object ',base) - ,(transform-numeric-bound-test n-object type base))) - (:complex - `(and (complexp ,n-object) - ,(once-only ((n-real `(realpart (the complex ,n-object))) - (n-imag `(imagpart (the complex ,n-object)))) - `(and (typep ,n-real ',base) - ,@(unless (eq class 'float) `((typep ,n-imag ',base))) - ,(transform-numeric-bound-test n-real type base) - ,(transform-numeric-bound-test n-imag type - base))))))))) - - -;;; Source-Transform-Hairy-Typep -- Internal -;;; -;;; Do the source transformation for a test of a hairy type. AND, SATISFIES -;;; and NOT are converted into the obvious code. We convert unknown types to -;;; %TYPEP, emitting an efficiency note if appropriate. -;;; -(defun source-transform-hairy-typep (object type) - (declare (type hairy-type type)) - (let ((spec (hairy-type-specifier type))) - (cond ((unknown-type-p type) - (when (policy nil (> speed brevity)) - (compiler-note "Can't open-code test of unknown type ~S." - (specifier-type type))) - `(%typep ,object ',spec)) - (t - (ecase (first spec) - (satisfies `(funcall #',(second spec) ,object)) - ((not and) - (once-only ((n-obj object)) - `(,(first spec) ,@(mapcar #'(lambda (x) - `(typep ,n-obj ',x)) - (rest spec)))))))))) - - -;;; Source-Transform-Union-Typep -- Internal -;;; -;;; Do source transformation for Typep of a known union type. If a union -;;; type contains LIST, then we pull that out and make it into a single LISTP -;;; call. Note that if SYMBOL is in the union, then LIST will be a subtype -;;; even without there being any (member NIL). We just drop through to the -;;; general code in this case, rather than trying to optimize it. -;;; -(defun source-transform-union-typep (object type) - (let* ((types (union-type-types type)) - (ltype (specifier-type 'list)) - (mtype (find-if #'member-type-p types))) - (cond ((and mtype (csubtypep ltype type)) - (let ((members (member-type-members mtype))) - (once-only ((n-obj object)) - `(if (listp ,n-obj) - t - (typep ,n-obj - '(or ,@(mapcar #'type-specifier - (remove (specifier-type 'cons) - (remove mtype types))) - (member ,@(remove nil members)))))))) - (t - (once-only ((n-obj object)) - `(or ,@(mapcar #'(lambda (x) - `(typep ,n-obj ',(type-specifier x))) - types))))))) - - -;;; FIND-SUPERTYPE-PREDICATE -- Internal -;;; -;;; Return the predicate and type from the most specific entry in -;;; *TYPE-PREDICATES* that is a supertype of Type. -;;; -(defun find-supertype-predicate (type) - (declare (type ctype ctype)) - (let ((res nil) - (res-type nil)) - (dolist (x *type-predicates*) - (let ((stype (car x))) - (when (and (csubtypep type stype) - (or (not res-type) - (csubtypep stype res-type))) - (setq res-type stype) - (setq res (cdr x))))) - (values res res-type))) - - -;;; TEST-ARRAY-DIMENSIONS -- Internal -;;; -;;; Return forms to test that Obj has the rank and dimensions specified by -;;; Type, where Stype is the type we have checked against (which is the same -;;; but for dimensions.) -;;; -(defun test-array-dimensions (obj type stype) - (declare (type array-type type stype)) - (let ((obj `(truly-the ,(type-specifier stype) ,obj)) - (dims (array-type-dimensions type))) - (unless (eq dims '*) - (collect ((res)) - (when (eq (array-type-dimensions stype) '*) - (res `(= (array-rank ,obj) ,(length dims)))) - - (do ((i 0 (1+ i)) - (dim dims (cdr dim))) - ((null dim)) - (let ((dim (car dim))) - (unless (eq dim '*) - (res `(= (array-dimension ,obj ,i) ,dim))))) - (res))))) - - -;;; SOURCE-TRANSFORM-ARRAY-TYPEP -- Internal -;;; -;;; If we can find a type predicate that tests for the type w/o dimensions, -;;; then use that predicate and test for dimensions. Otherwise, just do -;;; %TYPEP. -;;; -(defun source-transform-array-typep (obj type) - (multiple-value-bind (pred stype) - (find-supertype-predicate type) - (if (and (array-type-p stype) - (type= (array-type-specialized-element-type stype) - (array-type-specialized-element-type type)) - (eq (array-type-complexp stype) (array-type-complexp type))) - (once-only ((n-obj obj)) - `(and (,pred ,n-obj) - ,@(test-array-dimensions n-obj type stype))) - `(%typep ,obj ',(type-specifier type))))) - - -;;; Source-Transform-Typep -- Internal -;;; -;;; If the specifier argument is a quoted constant, then we consider -;;; converting into a simple predicate or other stuff. If the type is -;;; constant, but we can't transform the call, then we convert to %Typep. We -;;; only pass when the type is non-constant. This allows us to recognize -;;; between calls that might later be transformed sucessfully when a constant -;;; type is discovered. We don't given an efficiency note when we pass, since -;;; the IR1 transform will give one if necessary and appropriate. -;;; -;;; If the type is Type= to a type that has a predicate, then expand to that -;;; predicate. Otherwise, we dispatch off of the type's type. These -;;; transformations can increase space, but it is hard to tell when, so we -;;; ignore policy and always do them. -;;; -(def-source-transform typep (object spec) - (if (and (consp spec) (eq (car spec) 'quote)) - (let* ((type (specifier-type (cadr spec))) - (pred (cdr (assoc type *type-predicates* :test #'type=)))) - (if pred - `(,pred ,object) - (typecase type - (numeric-type - (source-transform-numeric-typep object type)) - (hairy-type - (source-transform-hairy-typep object type)) - (union-type - (source-transform-union-typep object type)) - (member-type - `(member ,object ',(member-type-members type))) - (structure-type - (once-only ((n-obj object)) - (structure-predicate n-obj (structure-type-name type)))) - (args-type - (compiler-warning "Illegal type specifier for Typep: ~S." - (cadr spec)) - `(%typep ,object ,spec)) - (array-type - (source-transform-array-typep object type)) - (t - `(%typep ,object ,spec))))) - (values nil t))) diff --git a/compiler/vmdef.lisp b/compiler/vmdef.lisp deleted file mode 100644 index 77901f2119c520e263092940dffe55eb5e06fbe6..0000000000000000000000000000000000000000 --- a/compiler/vmdef.lisp +++ /dev/null @@ -1,2345 +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-independent facilities used for -;;; defining the compiler's interface to the VM in a given implementation. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; -;;; 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. -(defvar *sc-numbers* (make-array sc-number-limit)) -(proclaim '(type sc-vector *sc-numbers*)) - -;;; -;;; A list of all the SBs defined, so that we can easily iterate over them. -(defvar *sb-list* ()) -(proclaim '(type list *sb-list*)) - -;;; -;;; Translates from template names to template structures. -(defvar *template-names* (make-hash-table :test #'eq)) -(proclaim '(type hash-table *template-names*)) - -;;; Template-Or-Lose -- Internal -;;; -;;; Return the template having the specified name, or die trying. -;;; -(defun template-or-lose (x) - (the template - (or (gethash x *template-names*) - (error "~S is not a defined template." x)))) - - -(eval-when (compile load eval) - -;;; 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. -;;; -(defvar *sc-names* (make-hash-table :test #'eq)) -(defvar *sb-names* (make-hash-table :test #'eq)) -(defvar *meta-sc-names* (make-hash-table :test #'eq)) -(defvar *meta-sb-names* (make-hash-table :test #'eq)) -(proclaim '(hash-table *sc-names* *sb-names*)) - -;;; -;;; Like *SC-Numbers*, but is updated at meta-compile time. -(defvar *meta-sc-numbers* (make-array sc-number-limit)) -(proclaim '(type sc-vector *meta-sc-numbers*)) - - -;;; 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) - (the sc - (or (gethash x *sc-names*) - (error "~S is not a defined storage class." x)))) -;;; -(defun sb-or-lose (x) - (the sb - (or (gethash x *sb-names*) - (error "~S is not a defined storage base." x)))) -;;; -(defun sc-number-or-lose (x) - (the sc-number (sc-number (sc-or-lose x)))) - - -;;; META-SC-OR-LOSE, META-SB-OR-LOSE, META-SC-NUMBER-OR-LOSE -- Internal -;;; -;;; Like the non-meta versions, but go for the meta-compile-time info. -;;; These should not be used after load time, since compiling the compiler -;;; changes the definitions. -;;; -(defun meta-sc-or-lose (x) - (the sc - (or (gethash x *meta-sc-names*) - (error "~S is not a defined storage class." x)))) -;;; -(defun meta-sb-or-lose (x) - (the sb - (or (gethash x *meta-sb-names*) - (error "~S is not a defined storage base." x)))) -;;; -(defun meta-sc-number-or-lose (x) - (the sc-number (sc-number (meta-sc-or-lose x)))) - -); Eval-When (Compile Load Eval) - - -;;;; Storage class and storage base definition: - -;;; Define-Storage-Base -- Public -;;; -;;; Enter the basic structure at meta-compile time, and then fill in the -;;; missing slots at load time. -;;; -(defmacro define-storage-base (name kind &key size) - "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." - (check-type name symbol) - (check-type kind (member :finite :unbounded :non-packed)) - (ecase kind - (:non-packed - (when size - (error "Size specification meaningless in a ~S SB." kind))) - ((:finite :unbounded) - (unless size (error "Size not specified in a ~S SB." kind)) - (check-type size unsigned-byte))) - - (let ((res (if (eq kind :non-packed) - (make-sb :name name :kind kind) - (make-finite-sb :name name :kind kind :size size)))) - `(progn - (eval-when (compile load eval) - (setf (gethash ',name *meta-sb-names*) ',res)) - ,(if (eq kind :non-packed) - `(setf (gethash ',name *sb-names*) (copy-sb ',res)) - `(let ((res (copy-finite-sb ',res))) - (setf (finite-sb-always-live res) - (make-array ',size :initial-element #*)) - (setf (finite-sb-conflicts res) - (make-array ',size :initial-element '#())) - (setf (finite-sb-live-tns res) - (make-array ',size :initial-element nil)) - (setf (gethash ',name *sb-names*) res))) - - (setq *sb-list* (cons (sb-or-lose ',name) - (remove ',name *sb-list* :key #'sb-name))) - ',name))) - - -;;; Define-Storage-Class -- Public -;;; -;;; -(defmacro define-storage-class (name number sb-name &key (element-size '1) - locations save-p alternate-scs - constant-scs) - "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 (Location*) - If the SB is :Finite, then this is a list of the offsets within the SB - that are in this SC. - - :Save-P {T | NIL} - If T, then values stored in this SC must be saved in one of the - non-save-p :Alternate-SCs across calls. - - :Alternate-SCs (SC*) - Indicates other SCs that can be used to hold values from this SC across - calls or when storage in this SC is exhausted. The SCs should be - specified in order of decreasing \"goodness\". Unless this SC is only - used for restricted or wired TNs, then there must be a last SC in an - unbounded SB. - - :Constant-SCs (SC*) - A list of the names of all the constant SCs that can be loaded into this - SC by a load function." - - (check-type name symbol) - (check-type number sc-number) - (check-type sb-name symbol) - (check-type locations list) - (check-type save-p boolean) - (check-type alternate-scs list) - (check-type constant-scs list) - - (let ((sb (meta-sb-or-lose sb-name))) - (if (eq (sb-kind sb) :finite) - (let ((size (sb-size sb)) - (element-size (eval element-size))) - (check-type element-size unsigned-byte) - (dolist (el locations) - (check-type el unsigned-byte) - (unless (<= 1 (+ el element-size) size) - (error "SC element ~D out of bounds for ~S." el sb)))) - (when locations - (error ":Locations is meaningless in a ~S SB." (sb-kind sb)))) - - (when (and (or alternate-scs constant-scs) - (eq (sb-kind sb) :non-packed)) - (error "Meaningless to specify alternate or constant SCs in a ~S SB." - (sb-kind sb)))) - - (let ((nstack-p - (if (or (eq sb-name 'non-descriptor-stack) - (find 'non-descriptor-stack - (mapcar #'meta-sc-or-lose alternate-scs) - :key #'(lambda (x) - (sb-name (sc-sb x))))) - t nil))) - `(progn - (eval-when (compile load eval) - (let ((res (make-sc :name ',name :number ',number - :sb (meta-sb-or-lose ',sb-name) - :element-size ,element-size - :locations ',locations - :save-p ',save-p - :number-stack-p ,nstack-p - :alternate-scs (mapcar #'meta-sc-or-lose - ',alternate-scs) - :constant-scs (mapcar #'meta-sc-or-lose - ',constant-scs)))) - (setf (gethash ',name *meta-sc-names*) res) - (setf (svref *meta-sc-numbers* ',number) res) - (setf (svref (sc-load-costs res) ',number) 0))) - - (let ((old (svref *sc-numbers* ',number))) - (when (and old (not (eq (sc-name old) ',name))) - (warn "Redefining SC number ~D from ~S to ~S." ',number - (sc-name old) ',name))) - - (setf (svref *sc-numbers* ',number) (meta-sc-or-lose ',name)) - (setf (gethash ',name *sc-names*) (meta-sc-or-lose ',name)) - (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name)) - ',name))) - - -;;;; Move/coerce definition: - - -;;; DO-SC-PAIRS -- Internal -;;; -;;; Given a list of paris of lists of SCs (as given to DEFINE-MOVE-VOP, -;;; etc.), bind TO-SC and FROM-SC to all the combinations. -;;; -(eval-when (compile load eval) - (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body) - `(do ((froms ,scs (cddr froms)) - (tos (cdr ,scs) (cddr tos))) - ((null froms)) - (dolist (from (car froms)) - (let ((,from-sc-var (meta-sc-or-lose from))) - (dolist (to (car tos)) - (let ((,to-sc-var (meta-sc-or-lose to))) - ,@body))))))) - - -;;; DEFINE-MOVE-FUNCTION -- Public -;;; -(defmacro define-move-function ((name cost) lambda-list scs &body body) - "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form* - Define the function Name and note it as the function used for moving operands - from the From-SCs to the To-SCs. Cost is the cost of this move operation. - The function is called with three arguments: the VOP (for context), and the - source and destination TNs. An ASSEMBLE form is wrapped around the body. - All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of - DEFINE-VOP." - (when (or (oddp (length scs)) (null scs)) - (error "Malformed SCs spec: ~S." scs)) - (check-type cost index) - `(progn - (eval-when (compile load eval) - (do-sc-pairs (from-sc to-sc ',scs) - (unless (eq from-sc to-sc) - (let ((num (sc-number from-sc))) - (setf (svref (sc-load-functions to-sc) num) ',name) - (setf (svref (sc-load-costs to-sc) num) ',cost))))) - - (defun ,name ,lambda-list - (assemble (vop-node ,(first lambda-list)) ,@body)))) - - -(defconstant sc-vop-slots '((:move . sc-move-vops) - (:move-argument . sc-move-arg-vops))) - - -;;; COMPUTE-MOVE-COSTS -- Internal -;;; -;;; Compute at meta-compile 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)))))))) - - -;;; DEFINE-MOVE-VOP -- Public -;;; -;;; We record the VOP and costs for all SCs that we can move between -;;; (including implicit loading). -;;; -(defmacro define-move-vop (name kind &rest scs) - "Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}* - Make Name be the VOP used to move values in the specified From-SCs to the - representation of the To-SCs. If kind is :Move-Argument, then the VOP takes - an extra argument, which is the frame pointer of the frame to move into." - (when (or (oddp (length scs)) (null scs)) - (error "Malformed SCs spec: ~S." scs)) - (let ((accessor (or (cdr (assoc kind sc-vop-slots)) - (error "Unknown kind ~S." kind)))) - `(progn - ,@(when (eq kind :move) - `((eval-when (compile load eval) - (do-sc-pairs (from-sc to-sc ',scs) - (compute-move-costs from-sc to-sc - ,(vop-parse-cost - (vop-parse-or-lose name))))))) - - (let ((vop (template-or-lose ',name))) - (do-sc-pairs (from-sc to-sc ',scs) - (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) - (let ((vec (,accessor dest-sc))) - (setf (svref vec (sc-number from-sc)) vop) - (dolist (sc (append (sc-alternate-scs from-sc) - (sc-constant-scs from-sc))) - (let ((scn (sc-number sc))) - (unless (svref vec scn) - (setf (svref vec scn) vop))))))))))) - - -;;;; Primitive type definition: - -;;; Translates from primitive type names to the corresponding primitive-type -;;; structure. -;;; -(defvar *primitive-type-names* (make-hash-table :test #'eq)) - -;;; 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. -;;; -(proclaim '(special *any-primitive-type*)) -(proclaim '(type primitive-type *any-primitive-type*)) - - -;;; Def-Primitive-Type -- Public -;;; -;;; If the primitive-type structure already exists, we destructively modify -;;; it so that existing references in templates won't be invalidated. -;;; Primitive-type definition isn't done at meta-compile time, so this doesn't -;;; break the running compiler. -;;; -(defmacro def-primitive-type (name scs &key (type name)) - "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.)" - (check-type name symbol) - (check-type scs list) - (once-only ((n-old `(gethash ',name *primitive-type-names*)) - (n-scs `(mapcar #'meta-sc-number-or-lose ',scs)) - (n-type `(specifier-type ',type))) - `(progn - (cond (,n-old - (setf (primitive-type-scs ,n-old) ,n-scs) - (setf (primitive-type-type ,n-old) ,n-type)) - (t - (setf (gethash ',name *primitive-type-names*) - (make-primitive-type :name ',name - :scs ,n-scs - :type ,n-type)))) - ',name))) - - -;;; Primitive-Type-Or-Lose -- Interface -;;; -;;; Return the primitive type corresponding to the spesicifed name, or die -;;; trying. -;;; -(defun primitive-type-or-lose (name) - (the primitive-type - (or (gethash name *primitive-type-names*) - (error "~S is not a defined primitive type." name)))) - - -(eval-when (compile load eval) - (defparameter primitive-type-slot-alist - '((:check . primitive-type-check)))) - - -;;; Primitive-Type-Vop -- Public -;;; -(defmacro primitive-type-vop (vop kinds &rest types) - "Primitive-Type-VOP Vop (Kind*) Type* - Annotate all the specified primitive Types with the named VOP under each of - the specified kinds: - - :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." - (let ((n-vop (gensym)) - (n-type (gensym))) - `(let ((,n-vop (template-or-lose ',vop))) - ,@(mapcar - #'(lambda (type) - `(let ((,n-type (primitive-type-or-lose ',type))) - ,@(mapcar - #'(lambda (kind) - (let ((slot (or (cdr (assoc kind - primitive-type-slot-alist)) - (error "Unknown kind: ~S." kind)))) - `(setf (,slot ,n-type) ,n-vop))) - kinds))) - types) - nil))) - - -;;;; VOP definition structures: -;;; -;;; Define-VOP uses some fairly complex data structures at meta-compile -;;; time, both to hold the results of parsing the elaborate syntax and to -;;; retain the information so that it can be inherited by other VOPs. - -(eval-when (compile load eval) - -;;; -;;; Hashtable translating from VOP names to the corresponding VOP-Parse -;;; structures. This information is only used at meta-compile time. -(defvar *parsed-vops* (make-hash-table :test #'eq)) -(proclaim '(type hash-table *parsed-vops*)) - -;;; The VOP-Parse structure holds everything we need to know about a VOP at -;;; meta-compile time. -;;; -(defstruct (vop-parse - (:print-function %print-vop-parse)) - ;; - ;; The name of this VOP. - (name nil :type symbol) - ;; - ;; If true, then the name of the VOP we inherit from. - (inherits nil :type (or symbol null)) - ;; - ;; Lists of Operand-Parse structures describing the arguments, results and - ;; temporaries of the VOP. - (args nil :type list) - (results nil :type list) - (temps nil :type list) - ;; - ;; Operand-Parse structures containing information about more args and - ;; results. If null, then there there are no more operands of that kind. - (more-args nil :type (or operand-parse null)) - (more-results nil :type (or operand-parse null)) - ;; - ;; A list of all the above together. - (operands nil :type list) - ;; - ;; Names of variables that should be declared ignore. - (ignores () :type list) - ;; - ;; True if this is a :Conditional VOP. - (conditional-p nil) - ;; - ;; Argument and result primitive types. These are pulled out of the - ;; operands, since we often want to change them without respecifying the - ;; operands. - (arg-types :unspecified :type (or (member :unspecified) list)) - (result-types :unspecified :type (or (member :unspecified) list)) - ;; - ;; The guard expression specified, or NIL if none. - (guard nil) - ;; - ;; The cost of and body code for the generator. - (cost 0 :type unsigned-byte) - (body :unspecified :type (or (member :unspecified) list)) - ;; - ;; Info for VOP variants. The list of forms to be evaluated to get the - ;; variant args for this VOP, and the list of variables to be bound to the - ;; variant args. - (variant () :type list) - (variant-vars () :type list) - ;; - ;; Variables bound to the VOP and Vop-Node when in the generator body. - (vop-var (gensym) :type symbol) - (node-var nil :type (or symbol null)) - ;; - ;; A list of the names of the codegen-info arguments to this VOP. - (info-args () :type list) - ;; - ;; An efficiency note associated with this VOP. - (note nil :type (or string null)) - ;; - ;; A list of the names of the Effects and Affected attributes for this VOP. - (effects '(any) :type list) - (affected '(any) :type list) - ;; - ;; A list of the names of functions this VOP is a translation of and the - ;; policy that allows this translation to be done. :Fast is a safe default, - ;; since it isn't a safe policy. - (translate () :type list) - (policy :fast :type policies) - ;; - ;; Stuff used by life analysis. - (save-p nil :type (member t nil :compute-only :force-to-stack)) - ;; - ;; Info about how to emit move-argument VOPs for the more operand in - ;; call/return VOPs. - (move-args nil :type (member nil :local-call :full-call :known-return))) - - -(defprinter vop-parse - name - (inherits :test inherits) - args - results - temps - (more-args :test more-args) - (more-results :test more-results) - (conditional-p :test conditional-p) - ignores - arg-types - result-types - cost - body - (variant :test variant) - (variant-vars :test variant-vars) - (info-args :test info-args) - (note :test note) - effects - affected - translate - policy - (save-p :test save-p) - (move-args :test move-args)) - -;;; The Operand-Parse structure contains stuff we need to know about and -;;; operand or temporary at meta-compile time. Besides the obvious stuff, we -;;; also store the names of per-operand temporaries here. -;;; -(defstruct (operand-parse - (:print-function %print-operand-parse)) - ;; - ;; Name of the operand (which we bind to the TN). - (name nil :type symbol) - ;; - ;; The way this operand is used: - (kind nil :type (member :argument :result :temporary - :more-argument :more-result)) - ;; - ;; If true, the name of an operand that this operand is targeted to. This is - ;; only meaningful in :Argument and :Temporary operands. - (target nil :type (or symbol null)) - ;; - ;; Temporary that holds the TN-Ref for this operand. Temp-Temp holds the - ;; write reference that begins a temporary's lifetime. - (temp (gensym) :type symbol) - (temp-temp nil :type (or symbol null)) - ;; - ;; The time that this operand is first live and the time at which it becomes - ;; dead again. These are time-specs, as returned by parse-time-spec. - born - dies - ;; - ;; A list of the names of the SCs that this operand is allowed into. If - ;; false, there is no restriction. - (scs nil :type list) - ;; - ;; Variable that is bound to the load TN allocated for this operand, or to - ;; NIL if no load-TN was allocated. - (load-tn (gensym) :type symbol) - ;; - ;; If true, automatic operand loading is inhibited and the operand name is - ;; always bound to the original TN. - (load t :type boolean) - ;; - ;; In a wired or restricted temporary this is the SC the TN is to be packed - ;; in. Null otherwise. - (sc nil :type (or symbol null)) - ;; - ;; If non-null, we are a temp wired to this offset in SC. - (offset nil :type (or unsigned-byte null))) - - -(defprinter operand-parse - name - kind - (target :test target) - born - dies - (scs :test scs) - (load :test load) - (sc :test sc) - (offset :test offset)) - -); Eval-When (Compile Load Eval) - - -;;;; Random utilities: - -(eval-when (compile load eval) - -;;; Find-Operand -- Internal -;;; -;;; Find the operand or temporary with the specifed Name in the VOP Parse. -;;; If there is no such operand, signal an error. Also error if the operand -;;; kind isn't one of the specified Kinds. -;;; -(defun find-operand (name parse &optional - (kinds '(:argument :result :temporary))) - (declare (symbol name) (type vop-parse parse) (list kinds)) - (let ((found (find name (vop-parse-operands parse) - :key #'operand-parse-name))) - (unless found - (error "~S is not an operand to ~S." name (vop-parse-name parse))) - (unless (member (operand-parse-kind found) kinds) - (error "Operand ~S isn't one of these kinds: ~S." name kinds)) - found)) - - -;;; VOP-Parse-Or-Lose -- Internal -;;; -;;; Get the VOP-Parse structure for Name or die trying. For all -;;; meta-compile time uses, the VOP-Parse should be used instead of the -;;; VOP-Info -;;; -(defun vop-parse-or-lose (name) - (the vop-parse - (or (gethash name *parsed-vops*) - (error "~S is not the name of a defined VOP." name)))) - - -;;; Access-Operands -- Internal -;;; -;;; Return a list of let-forms to parse a tn-ref list into a the temps -;;; specified by the operand-parse structures. More-Operand is the -;;; Operand-Parse describing any more operand, or NIL if none. Refs is an -;;; expression that evaluates into the first tn-ref. -;;; -(defun access-operands (operands more-operand refs) - (declare (list operands)) - (collect ((res)) - (let ((prev refs)) - (dolist (op operands) - (let ((n-ref (operand-parse-temp op))) - (res `(,n-ref ,prev)) - (setq prev `(tn-ref-across ,n-ref)))) - - (when more-operand - (res `(,(operand-parse-name more-operand) ,prev)))) - (res))) - - -;;; Ignore-Unreferenced-Temps -- Internal -;;; -;;; Used with Access-Operands to prevent warnings for TN-Ref temps not used -;;; by some particular function. It returns the name of the last operand, or -;;; NIL if Operands is NIL. -;;; -(defun ignore-unreferenced-temps (operands) - (when operands - (operand-parse-temp (car (last operands))))) - - -;;; VOP-Spec-Arg -- Internal -;;; -;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff. -;;; -(defun vop-spec-arg (spec type &optional (n 1) (last t)) - (let ((len (length spec))) - (when (<= len n) - (error "~:R argument missing: ~S." n spec)) - (when (and last (> len (1+ n))) - (error "Extra junk at end of ~S." spec)) - (let ((thing (elt spec n))) - (unless (typep thing type) - (error "~:R argument is not a ~S: ~S." n type spec)) - thing))) - - -;;;; Time specs: - -;;; Parse-Time-Spec -- Internal -;;; -;;; Return a time spec describing a time during the evaluation of a VOP, -;;; used to delimit operand and temporary lifetimes. The representation is a -;;; cons whose CAR is the number of the evaluation phase and the CDR is the -;;; sub-phase. The sub-phase is 0 in the :Load and :Save phases. -;;; -(defun parse-time-spec (spec) - (let ((dspec (if (atom spec) (list spec 0) spec))) - (unless (and (= (length dspec) 2) - (typep (second dspec) 'unsigned-byte)) - (error "Malformed time specifier: ~S." spec)) - - (cons (case (first dspec) - (:load 0) - (:argument 1) - (:eval 2) - (:result 3) - (:save 4) - (t - (error "Unknown phase in time specifier: ~S." spec))) - (second dspec)))) - - -;;; Time-Spec-Order -- Internal -;;; -;;; Return true if the time spec X is the same or later time than Y. -;;; -(defun time-spec-order (x y) - (or (> (car x) (car y)) - (and (= (car x) (car y)) - (>= (cdr x) (cdr y))))) - - -;;;; Emit function generation: - -;;; Compute-Reference-Order -- Internal -;;; -;;; Return a list of 2-lists (<Temporary> <More-P>) in reverse reference -;;; order describing how to build the next-ref linkage for Parse. If More-P is -;;; false, then the Temporary points to a single TN-Ref that should be linked -;;; in. If More-P is true, then Temporary points to a chain of Tn-Refs linked -;;; together by Tn-Ref-Across that should be linked in reverse order. -;;; -;;; In implementation, we build a temporary list containing the result -;;; tuples augmented with reference time and whether the reference is a write. -;;; We sort this list using Time-Spec-Order augmented by the subsidiary rule -;;; that when the specs are equal, we do read references first. This -;;; implements the desired semantics of open intervals for temporary lifetimes. -;;; -(defun compute-reference-order (parse) - (declare (type vop-parse parse)) - (collect ((refs)) - (dolist (op (vop-parse-operands parse)) - (let ((born (operand-parse-born op)) - (dies (operand-parse-dies op)) - (name (operand-parse-name op)) - (temp (operand-parse-temp op)) - (temp-temp (operand-parse-temp-temp op))) - (ecase (operand-parse-kind op) - (:argument - (refs (list (cons dies nil) temp nil))) - (:more-argument - (refs (list (cons dies nil) name t))) - (:result - (refs (list (cons born t) temp nil))) - (:more-result - (refs (list (cons born t) name t))) - (:temporary - (refs (list (cons born t) temp nil)) - (refs (list (cons dies nil) temp-temp nil)))))) - - (mapcar #'cdr - (sort (refs) - #'(lambda (x y) - (let ((x-time (car x)) - (y-time (car y))) - (if (time-spec-order x-time y-time) - (if (time-spec-order y-time x-time) - (or (cdr x) (not (cdr y))) - t) - nil))) - :key #'first)))) - - -;;; Make-Next-Ref-Linkage -- Internal -;;; -;;; Use the operand lifetime annotations to set up the next-ref slots in all -;;; the TN-Refs used in the VOP. We set the Refs in the VOP to point to the -;;; head of this list. More operands make life a bit interesting, since they -;;; introduce uncertainty as to whether we have seen any operands yet, and also -;;; must be linked together contiguously with the other TN-Refs. -;;; -(defun make-next-ref-linkage (parse n-vop) - (declare (type vop-parse parse)) - (collect ((forms) - (binds)) - (let ((first-seen :no) - (prev nil)) - (dolist (x (compute-reference-order parse)) - (let* ((var (first x)) - (more-p (second x)) - (n-tail (if more-p (gensym) var))) - (ecase first-seen - (:no - (forms `(setf (vop-refs ,n-vop) ,n-tail))) - (:yes - (forms `(setf (tn-ref-next-ref ,prev) ,n-tail))) - (:maybe - (forms `(if ,prev - (setf (tn-ref-next-ref ,prev) ,n-tail) - (setf (vop-refs ,n-vop) ,n-tail))))) - - (unless (eq first-seen :yes) - (setq first-seen (if more-p :maybe :yes))) - - (if more-p - (let ((n-current (gensym)) - (n-prev (gensym)) - (n-head (gensym))) - (binds `(,n-head (or ,var ,prev))) - (binds - `(,n-tail - (do ((,n-current ,var (tn-ref-across ,n-current)) - (,n-prev nil ,n-current)) - ((null ,n-current) ,n-prev) - (setf (tn-ref-next-ref ,n-current) ,n-prev)))) - (setq prev n-head)) - (setq prev var))))) - - `((let* ,(binds) - ,@(forms))))) - - -;;; Make-Temporary -- Internal -;;; -;;; Return a form that creates a TN as specified by Temp. This requires -;;; deciding whether the temp is wired or restricted. -;;; -(defun make-temporary (temp) - (declare (type operand-parse temp)) - (let ((sc (operand-parse-sc temp)) - (offset (operand-parse-offset temp))) - (assert sc) - (if offset - `(make-wired-tn ,(meta-sc-number-or-lose sc) ,offset) - `(make-restricted-tn ,(meta-sc-number-or-lose sc))))) - - -;;; Allocate-Temporaries -- Internal -;;; -;;; Allocate VOP temporary TNs, making TN-Refs for their start and end, and -;;; setting up various per-ref information. N-Vop is the temporary holding the -;;; VOP we are emitting. We return a list of let* binding forms that create -;;; the TN-Refs, a list of forms that initialize the TN-Refs. -;;; -(defun allocate-temporaries (parse n-vop) - (declare (type vop-parse parse)) - (collect ((binds) - (forms)) - (let ((prev-write nil)) - (dolist (temp (vop-parse-temps parse)) - (let ((n-write (operand-parse-temp temp)) - (n-read (operand-parse-temp-temp temp)) - (n-tn (gensym))) - (binds `(,n-tn ,(make-temporary temp))) - (binds `(,n-write (reference-tn ,n-tn t))) - (binds `(,n-read (reference-tn ,n-tn nil))) - (if prev-write - (forms `(setf (tn-ref-across ,prev-write) ,n-write)) - (forms `(setf (vop-temps ,n-vop) ,n-write))) - (setq prev-write n-write) - (forms `(setf (tn-ref-vop ,n-read) ,n-vop)) - (forms `(setf (tn-ref-vop ,n-write) ,n-vop))))) - - (values (binds) (forms)))) - - -;;; Set-VOP-Pointers -- Internal -;;; -;;; Return code to set the TN-Ref-Vop slots in some operands to the value of -;;; N-Vop. If there is no more operand, set the set the slots individually, -;;; otherwise loop over the whole list N-Refs. -;;; -(defun set-vop-pointers (operands more-operand n-vop n-refs) - (if more-operand - `((do ((,n-refs ,n-refs (tn-ref-across ,n-refs))) - ((null ,n-refs)) - (setf (tn-ref-vop ,n-refs) ,n-vop))) - (mapcar #'(lambda (op) - `(setf (tn-ref-vop ,(operand-parse-temp op)) ,n-vop)) - operands))) - - -;;; Make-Emit-Function -- Internal -;;; -;;; Make the Template Emit-Function for a VOP. -;;; -(defun make-emit-function (parse) - (declare (type vop-parse parse)) - (let ((n-node (gensym)) (n-block (gensym)) - (n-template (gensym)) (n-args (gensym)) - (n-results (gensym)) (n-info (gensym)) - (n-vop (gensym)) - (info-args (vop-parse-info-args parse))) - (multiple-value-bind (temp-binds temp-forms) - (allocate-temporaries parse n-vop) - `#'(lambda (,n-node ,n-block ,n-template ,n-args ,n-results - ,@(when info-args `(,n-info))) - (let ((,n-vop (make-vop ,n-block ,n-node ,n-template - ,n-args ,n-results))) - - ,@(when info-args - `((setf (vop-codegen-info ,n-vop) ,n-info))) - - (let* (,@(access-operands (vop-parse-args parse) - (vop-parse-more-args parse) - n-args) - ,@(access-operands (vop-parse-results parse) - (vop-parse-more-results parse) - n-results) - ,@temp-binds) - ,@temp-forms - ,@(set-vop-pointers (vop-parse-args parse) - (vop-parse-more-args parse) - n-vop n-args) - ,@(set-vop-pointers (vop-parse-results parse) - (vop-parse-more-results parse) - n-vop n-results) - ,@(make-next-ref-linkage parse n-vop)) - (values ,n-vop ,n-vop)))))) - - -;;; Make-Target-Function -- Internal -;;; -;;; Make lambda that does operand targeting as indicated by the -;;; Operand-Parse-Target slots. We do some meta-compile-time consistency -;;; checking, and the emit a call to Target-If-Desirable for each operand -;;; with a target specified. -;;; -;;; If we are targeting from a temporary, then we indirect through the TN to -;;; find the read ref. This exploits the fact that a temp has exactly one -;;; read. -;;; -(defun make-target-function (parse) - (collect ((forms)) - (dolist (op (vop-parse-operands parse)) - (when (operand-parse-target op) - (unless (member (operand-parse-kind op) '(:argument :temporary)) - (error "Cannot target a ~S operand: ~S." (operand-parse-kind op) - (operand-parse-name op))) - (let ((target (find-operand (operand-parse-target op) parse - '(:temporary :result)))) - (forms `(target-if-desirable - ,(ecase (operand-parse-kind op) - (:temporary - `(tn-reads (tn-ref-tn ,(operand-parse-temp op)))) - (:argument - (operand-parse-temp op))) - ,(operand-parse-temp target)))))) - - (let ((n-vop (gensym))) - `#'(lambda (,n-vop) - (let* (,@(access-operands (vop-parse-args parse) nil - `(vop-args ,n-vop)) - ,@(access-operands (vop-parse-results parse) nil - `(vop-results ,n-vop)) - ,@(access-operands (vop-parse-temps parse) nil - `(vop-temps ,n-vop))) - ,(ignore-unreferenced-temps (vop-parse-args parse)) - ,(ignore-unreferenced-temps (vop-parse-results parse)) - ,(ignore-unreferenced-temps (vop-parse-temps parse)) - ,@(forms)))))) - - -;;;; Generator functions: - -;;; FIND-LOAD-FUNCTIONS -- Internal -;;; -;;; Return an alist that translates from lists of SCs we can load OP from to -;;; the load function used for loading those SCs. We quietly ignore -;;; restrictions to :non-packed (constant) SCs, since we don't load into those -;;; SCs. -;;; -(defun find-load-functions (op load-p) - (collect ((funs)) - (dolist (sc-name (operand-parse-scs op)) - (let* ((sc (meta-sc-or-lose sc-name)) - (scn (sc-number sc)) - (load-scs (append (when load-p - (sc-constant-scs sc)) - (sc-alternate-scs sc)))) - (cond - (load-scs - (dolist (alt load-scs) - (let* ((altn (sc-number alt)) - (name (if load-p - (svref (sc-load-functions sc) altn) - (svref (sc-load-functions alt) scn))) - (found (or (assoc alt (funs) :test #'member) - (rassoc name (funs))))) - (unless name - (error "No load function defined to ~:[save~;load~] SC ~S~ - ~:[to~;from~] from SC ~S." - load-p sc-name load-p (sc-name alt))) - - (cond (found - (unless (eq (cdr found) name) - (error "Can't tell whether to ~:[save~;load~] with ~S~@ - or ~S when operand is in SC ~S." - load-p name (cdr found) (sc-name alt))) - (pushnew alt (car found))) - (t - (funs (cons (list alt) name))))))) - ((eq (sb-kind (sc-sb sc)) :non-packed)) - (t - (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@ - mentioned in the restriction for operand ~S." - sc-name load-p (operand-parse-name op)))))) - - (funs))) - - -;;; CALL-LOAD-FUNCTION -- Internal -;;; -;;; Return a form to load/save the specified operand when it has a load TN. -;;; For any given SC that we can load from, there must be a unique load -;;; function. If all SCs we can load from have the same load function, then we -;;; just call that when there is a load TN. If there are multiple possible -;;; load functions, then we dispatch off of the operand TN's type to see which -;;; load function to use. -;;; -(defun call-load-function (parse op load-p) - (let ((funs (find-load-functions op load-p)) - (load-tn (operand-parse-load-tn op))) - (if funs - (let* ((tn `(tn-ref-tn ,(operand-parse-temp op))) - (n-vop (or (vop-parse-vop-var parse) - (setf (vop-parse-vop-var parse) (gensym)))) - (form (if (rest funs) - `(sc-case ,tn - ,@(mapcar #'(lambda (x) - `(,(mapcar #'sc-name (car x)) - ,(if load-p - `(,(cdr x) ,n-vop ,tn - ,load-tn) - `(,(cdr x) ,n-vop ,load-tn - ,tn)))) - funs)) - (if load-p - `(,(cdr (first funs)) ,n-vop ,tn ,load-tn) - `(,(cdr (first funs)) ,n-vop ,load-tn ,tn))))) - (if (eq (operand-parse-load op) t) - `(when ,load-tn ,form) - `(when (eq ,load-tn ,(operand-parse-name op)) - ,form))) - `(when ,load-tn - (error "Load TN allocated, but no load function?~@ - VM definition inconsistent, recompile and try again."))))) - - -;;; DECIDE-TO-LOAD -- Internal -;;; -;;; Return the TN that we should bind to the operand's var in the generator -;;; body. In general, this involves evaluating the :LOAD-IF test expression. -;;; -(defun decide-to-load (parse op) - (let ((load (operand-parse-load op)) - (load-tn (operand-parse-load-tn op)) - (temp (operand-parse-temp op))) - (if (eq load t) - `(or ,load-tn (tn-ref-tn ,temp)) - (collect ((binds) - (ignores)) - (dolist (x (vop-parse-operands parse)) - (when (member (operand-parse-kind x) '(:argument :result)) - (let ((name (operand-parse-name x))) - (binds `(,name (tn-ref-tn ,(operand-parse-temp x)))) - (ignores name)))) - `(if (and ,load-tn - (let ,(binds) - #+new-compiler - (declare (ignorable ,@(ignores))) - #-new-compiler - (progn ,@(ignores)) - ,load)) - ,load-tn - (tn-ref-tn ,temp)))))) - - -;;; Make-Generator-Function -- Internal -;;; -;;; Make a lambda that parses the VOP TN-Refs, does automatic operand -;;; loading, and runs the appropriate code generator. -;;; -(defun make-generator-function (parse) - (declare (type vop-parse parse)) - (let ((n-vop (vop-parse-vop-var parse)) - (operands (vop-parse-operands parse)) - (n-info (gensym)) (n-variant (gensym))) - (collect ((binds) - (loads) - (saves)) - (dolist (op operands) - (ecase (operand-parse-kind op) - ((:argument :result) - (let ((temp (operand-parse-temp op)) - (name (operand-parse-name op))) - (binds `(,(operand-parse-load-tn op) (tn-ref-load-tn ,temp))) - (cond ((and (operand-parse-load op) (operand-parse-scs op)) - (binds `(,name ,(decide-to-load parse op))) - (if (eq (operand-parse-kind op) :argument) - (loads (call-load-function parse op t)) - (saves (call-load-function parse op nil)))) - (t - (binds `(,name (tn-ref-tn ,temp))))))) - (:temporary - (binds `(,(operand-parse-name op) - (tn-ref-tn ,(operand-parse-temp op))))) - ((:more-argument :more-result)))) - - `#'(lambda (,n-vop) - (let* (,@(access-operands (vop-parse-args parse) - (vop-parse-more-args parse) - `(vop-args ,n-vop)) - ,@(access-operands (vop-parse-results parse) - (vop-parse-more-results parse) - `(vop-results ,n-vop)) - ,@(access-operands (vop-parse-temps parse) nil - `(vop-temps ,n-vop)) - ,@(when (vop-parse-info-args parse) - `((,n-info (vop-codegen-info ,n-vop)) - ,@(mapcar #'(lambda (x) `(,x (pop ,n-info))) - (vop-parse-info-args parse)))) - ,@(when (vop-parse-variant-vars parse) - `((,n-variant (vop-info-variant (vop-info ,n-vop))) - ,@(mapcar #'(lambda (x) `(,x (pop ,n-variant))) - (vop-parse-variant-vars parse)))) - ,@(when (vop-parse-node-var parse) - `((,(vop-parse-node-var parse) (vop-node ,n-vop)))) - ,@(binds)) - (declare (ignore ,@(vop-parse-ignores parse))) - ,@(loads) - (assemble (vop-node ,n-vop) - ,@(vop-parse-body parse)) - ,@(saves)))))) - - -;;; Parse-Operands -- Internal -;;; -;;; Given a list of operand specifications as given to Define-VOP, return a -;;; list of Operand-Parse structures describing the fixed operands, and a -;;; single Operand-Parse describing any more operand. -;;; -(defun parse-operands (specs kind) - (declare (list specs) - (type (member :argument :result) kind)) - (let ((num -1) - (more nil)) - (collect ((operands)) - (dolist (spec specs) - (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec))) - (error "Malformed operand specifier: ~S." spec)) - (when more - (error "More operand isn't last: ~S." specs)) - (let ((res (ecase kind - (:argument - (make-operand-parse - :name (first spec) :kind :argument - :born (parse-time-spec :load) - :dies (parse-time-spec `(:argument ,(incf num))))) - (:result - (make-operand-parse - :name (first spec) :kind :result - :born (parse-time-spec `(:result ,(incf num))) - :dies (parse-time-spec :save)))))) - (do ((key (rest spec) (cddr key))) - ((null key)) - (let ((value (second key))) - (case (first key) - (:scs - (check-type value list) - (setf (operand-parse-scs res) (remove-duplicates value))) - (:load-tn - (check-type value symbol) - (setf (operand-parse-load-tn res) value)) - (:load-if - (setf (operand-parse-load res) value)) - (:more - (check-type value boolean) - (setf (operand-parse-kind res) - (if (eq kind :argument) :more-argument :more-result)) - (setf (operand-parse-load res) nil) - (setq more res)) - (:target - (check-type value symbol) - (setf (operand-parse-target res) value)) - (:from - (unless (eq kind :result) - (error "Can only specify :FROM in a result: ~S" spec)) - (setf (operand-parse-born res) (parse-time-spec value))) - (:to - (unless (eq kind :argument) - (error "Can only specify :TO in an argument: ~S" spec)) - (setf (operand-parse-dies res) (parse-time-spec value))) - (t - (error "Unknown keyword in operand specifier: ~S." spec))))) - - (cond ((not more) - (operands res)) - ((operand-parse-target more) - (error "Cannot specify :TARGET in a :MORE operand.")) - ((operand-parse-load more) - (error "Cannot specify :LOAD-IF in a :MORE operand."))))) - (values (the list (operands)) more)))) - - -;;; Parse-Temporary -- Internal -;;; -;;; Parse a temporary specification, entering the Operand-Parse structures in -;;; the Parse structure. -;;; -(defun parse-temporary (spec parse) - (declare (list spec) - (type vop-parse parse)) - (let ((len (length spec))) - (unless (>= len 2) - (error "Malformed temporary spec: ~S." spec)) - (dolist (name (cddr spec)) - (unless (symbolp name) - (error "Bad temporary name: ~S." name)) - (let ((res (make-operand-parse :name name :kind :temporary - :temp-temp (gensym) - :born (parse-time-spec :load) - :dies (parse-time-spec :save)))) - (unless (evenp (length (second spec))) - (error "Odd number of argument in keyword options: ~S." spec)) - (do ((opt (second spec) (cddr opt))) - ((null opt)) - (case (first opt) - (:target - (setf (operand-parse-target res) - (vop-spec-arg opt 'symbol 1 nil))) - (:sc - (setf (operand-parse-sc res) - (vop-spec-arg opt 'symbol 1 nil))) - (:offset - (let ((offset (eval (second opt)))) - (check-type offset unsigned-byte) - (setf (operand-parse-offset res) offset))) - (:from - (setf (operand-parse-born res) (parse-time-spec (second opt)))) - (:to - (setf (operand-parse-dies res) (parse-time-spec (second opt)))) - ;; - ;; Backward compatibility... - (:scs - (let ((scs (vop-spec-arg opt 'list 1 nil))) - (unless (= (length scs) 1) - (error "Must specify exactly one SC for a temporary.")) - (setf (operand-parse-sc res) (first scs)))) - (:type) - (t - (error "Unknown temporary option: ~S." opt)))) - - (unless (and (time-spec-order (operand-parse-dies res) - (operand-parse-born res)) - (not (time-spec-order (operand-parse-born res) - (operand-parse-dies res)))) - (error "Temporary lifetime doesn't begin before it ends: ~S." spec)) - - (unless (operand-parse-sc res) - (error "Must specifiy :SC for all temporaries: ~S" spec)) - - (setf (vop-parse-temps parse) - (cons res - (remove name (vop-parse-temps parse) - :key #'operand-parse-name)))))) - (undefined-value)) - - -;;; Parse-Define-VOP -- Internal -;;; -;;; Top-level parse function. Clobber Parse to represent the specified -;;; options. -;;; -(defun parse-define-vop (parse specs) - (declare (type vop-parse parse) (list specs)) - (dolist (spec specs) - (unless (consp spec) - (error "Malformed option specification: ~S." spec)) - (case (first spec) - (:args - (multiple-value-bind - (fixed more) - (parse-operands (rest spec) :argument) - (setf (vop-parse-args parse) fixed) - (setf (vop-parse-more-args parse) more))) - (:results - (multiple-value-bind - (fixed more) - (parse-operands (rest spec) :result) - (setf (vop-parse-results parse) fixed) - (setf (vop-parse-more-results parse) more)) - (setf (vop-parse-conditional-p parse) nil)) - (:conditional - (setf (vop-parse-result-types parse) ()) - (setf (vop-parse-results parse) ()) - (setf (vop-parse-more-results parse) nil) - (setf (vop-parse-conditional-p parse) t)) - (:temporary - (parse-temporary spec parse)) - (:generator - (setf (vop-parse-cost parse) - (vop-spec-arg spec 'unsigned-byte 1 nil)) - (setf (vop-parse-body parse) (cddr spec))) - (:effects - (setf (vop-parse-effects parse) (rest spec))) - (:affected - (setf (vop-parse-affected parse) (rest spec))) - (:info - (setf (vop-parse-info-args parse) (rest spec))) - (:ignore - (setf (vop-parse-ignores parse) (rest spec))) - (:variant - (setf (vop-parse-variant parse) (rest spec))) - (:variant-vars - (let ((vars (rest spec))) - (setf (vop-parse-variant-vars parse) vars) - (setf (vop-parse-variant parse) - (make-list (length vars) :initial-element nil)))) - (:variant-cost - (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte))) - (:vop-var - (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol))) - (:move-args - (setf (vop-parse-move-args parse) - (vop-spec-arg spec '(member nil :local-call :full-call - :known-return)))) - (:node-var - (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol))) - (:note - (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null)))) - (:arg-types - (setf (vop-parse-arg-types parse) - (parse-operand-types (rest spec) t))) - (:result-types - (setf (vop-parse-result-types parse) - (parse-operand-types (rest spec) nil))) - (:translate - (setf (vop-parse-translate parse) (rest spec))) - (:guard - (setf (vop-parse-guard parse) (vop-spec-arg spec t))) - (:policy - (setf (vop-parse-policy parse) (vop-spec-arg spec 'policies))) - (:save-p - (setf (vop-parse-save-p parse) - (vop-spec-arg spec - '(member t nil :compute-only :force-to-stack)))) - (t - (error "Unknown option specifier: ~S." (first spec))))) - (undefined-value)) - - -;;;; Make costs and restrictions: - -;;; Compute-Loading-Costs -- Internal -;;; -;;; Given an operand, returns two values: -;;; 1] A SC-vector of the cost for the operand being in that SC, including both -;;; the costs for load functions and coercion VOPs. -;;; 2] A SC-vector holding the SC that we load into, for any SC that we can -;;; directly load from. -;;; -;;; In both vectors, unused entries are NIL. Load-P specifies the direction: -;;; if true, we are loading, if false we are saving. -;;; -(defun compute-loading-costs (op load-p) - (declare (type operand-parse op)) - (let ((scs (operand-parse-scs op)) - (costs (make-array sc-number-limit :initial-element nil)) - (load-scs (make-array sc-number-limit :initial-element nil))) - (dolist (sc-name scs) - (let* ((load-sc (meta-sc-or-lose sc-name)) - (load-scn (sc-number load-sc))) - (setf (svref costs load-scn) 0) - (setf (svref load-scs load-scn) load-scn) - (dolist (op-sc (append (when load-p - (sc-constant-scs load-sc)) - (sc-alternate-scs load-sc))) - (let* ((op-scn (sc-number op-sc)) - (load (if load-p - (aref (sc-load-costs load-sc) op-scn) - (aref (sc-load-costs op-sc) load-scn)))) - (unless load - (error "No load function defined to move ~:[from~;to~] SC ~ - ~S~%~:[to~;from~] alternate or constant SC ~S." - load-p sc-name load-p (sc-name op-sc))) - - (let ((op-cost (svref costs op-scn))) - (when (or (not op-cost) (< load op-cost)) - (setf (svref costs op-scn) load))) - - (setf (svref load-scs op-scn) load-scn))) - - (dotimes (i sc-number-limit) - (unless (svref costs i) - (let ((op-sc (svref *meta-sc-numbers* i))) - (when op-sc - (let ((cost (if load-p - (svref (sc-move-costs load-sc) i) - (svref (sc-move-costs op-sc) load-scn)))) - (when cost - (setf (svref costs i) cost))))))))) - - (values costs load-scs))) - - -(defconstant no-costs - (make-array sc-number-limit :initial-element 0)) - -(defconstant no-loads - (let ((res (make-array sc-number-limit))) - (dotimes (i sc-number-limit) - (setf (svref res i) i)) - res)) - - -;;; COMPUTE-LOADING-COSTS-IF-ANY -- Internal -;;; -;;; Pick off the case of operands with no restrictions. -;;; -(defun compute-loading-costs-if-any (op load-p) - (declare (type operand-parse op)) - (if (operand-parse-scs op) - (compute-loading-costs op load-p) - (values no-costs no-loads))) - - -;;; COMPUTE-COSTS-AND-RESTRICTIONS-LIST -- Internal -;;; -(defun compute-costs-and-restrictions-list (ops load-p) - (declare (list ops)) - (collect ((costs) - (scs)) - (dolist (op ops) - (multiple-value-bind (costs scs) - (compute-loading-costs-if-any op load-p) - (costs costs) - (scs scs))) - (values (costs) (scs)))) - - -;;; Make-Costs-And-Restrictions -- Internal -;;; -(defun make-costs-and-restrictions (parse) - (multiple-value-bind - (arg-costs arg-scs) - (compute-costs-and-restrictions-list (vop-parse-args parse) t) - (multiple-value-bind - (result-costs result-scs) - (compute-costs-and-restrictions-list (vop-parse-results parse) nil) - `( - :cost ,(vop-parse-cost parse) - - :arg-costs ',arg-costs - :arg-load-scs ',arg-scs - :result-costs ',result-costs - :result-load-scs ',result-scs - - :more-arg-costs - ',(if (vop-parse-more-args parse) - (compute-loading-costs-if-any (vop-parse-more-args parse) t) - nil) - - :more-result-costs - ',(if (vop-parse-more-results parse) - (compute-loading-costs-if-any (vop-parse-more-results parse) nil) - nil))))) - - -;;;; Operand checking and stuff: - -;;; PARSE-OPERAND-TYPES -- Internal -;;; -;;; Given a list of arg/result restrictions, check for valid syntax and -;;; convert to canonical form. -;;; -(defun parse-operand-types (specs args-p) - (declare (list specs)) - (mapcar #'(lambda (spec) - (cond ((eq spec '*) spec) - ((symbolp spec) - `(:or ,spec)) - ((atom spec) - (error "Bad thing to be a operand type: ~S." spec)) - (t - (case (first spec) - (:or - (unless (every #'symbolp (rest spec)) - (error "Bad PRIMITIVE-TYPE name in ~S." spec)) - spec) - (:constant - (unless args-p - (error "Can't :CONSTANT for a result.")) - (unless (= (length spec) 2) - (error "Bad :CONSTANT argument type spec: ~S." spec)) - spec) - (t - (error "Bad thing to be a operand type: ~S." spec)))))) - specs)) - - -;;; Check-Operand-Types -- Internal -;;; -;;; If the operand types are specified, then check the number specified -;;; against the number of defined operands. -;;; -;;; [### This would be a good place to check if the operand type is consistent -;;; with the SC restriction.] -;;; -(defun check-operand-types (ops more-op types what) - (declare (list ops) (type (or list (member :unspecified)) types) - (type (or operand-parse null) more-op) (string what)) - (unless (eq types :unspecified) - (let ((num (+ (length ops) (if more-op 1 0)))) - (unless (= (count-if-not #'(lambda (x) - (and (consp x) - (eq (car x) :constant))) - types) - num) - (error "Expected ~D ~A type~P: ~S." num what types num))) - (when more-op - (let ((mtype (car (last types)))) - (when (and (consp mtype) (eq (first mtype) :constant)) - (error "Can't use :CONSTANT on VOP more args."))))) - - (undefined-value)) - - -;;; Grovel-Operands -- Internal -;;; -;;; Compute stuff that can only be computed after we are done parsing -;;; everying. We set the VOP-Parse-Operands, and do various error checks. -;;; -(defun grovel-operands (parse) - (declare (type vop-parse parse)) - - (setf (vop-parse-operands parse) - (append (vop-parse-args parse) - (if (vop-parse-more-args parse) - (list (vop-parse-more-args parse))) - (vop-parse-results parse) - (if (vop-parse-more-results parse) - (list (vop-parse-more-results parse))) - (vop-parse-temps parse))) - - (check-operand-types (vop-parse-args parse) - (vop-parse-more-args parse) - (vop-parse-arg-types parse) - "argument") - - - (check-operand-types (vop-parse-results parse) - (vop-parse-more-results parse) - (vop-parse-result-types parse) - "result") - - (undefined-value)) - - -;;;; Function translation stuff: - -;;; Adjoin-Template -- Internal -;;; -;;; Add Template into Info's Templates, removing any old template with the -;;; same name. -;;; -(defun adjoin-template (info template) - (declare (type function-info info) (type template template)) - (setf (function-info-templates info) - (sort (cons template - (remove (template-name template) - (function-info-templates info) - :key #'template-name)) - #'<= - :key #'template-cost)) - (undefined-value)) - - -;;; Set-Up-Function-Translation -- Internal -;;; -;;; Return forms to establish this VOP as a IR2 translation template for the -;;; :Translate functions specified in the VOP-Parse. We also set the -;;; Predicate attribute for each translated function when the VOP is -;;; conditional, causing IR1 conversion to ensure that a call to the translated -;;; is always used in a predicate position. -;;; -(defun set-up-function-translation (parse n-template) - (declare (type vop-parse parse)) - (mapcar #'(lambda (name) - `(let ((info (function-info-or-lose ',name))) - (adjoin-template info ,n-template) - ,@(when (vop-parse-conditional-p parse) - '((setf (function-info-attributes info) - (attributes-union - (ir1-attributes predicate) - (function-info-attributes info))))))) - (vop-parse-translate parse))) - - -;;; Make-Operand-Type -- Internal -;;; -;;; Return a form that can be evaluated to get the TEMPLATE operand type -;;; restriction from the given specification. -;;; -(defun make-operand-type (type) - (cond ((eq type '*) ''*) - ((symbolp type) - ``(:or ,(primitive-type-or-lose ',type))) - (t - (ecase (first type) - (:or - ``(:or ,,@(mapcar #'(lambda (type) - `(primitive-type-or-lose ',type)) - (rest type)))) - (:constant - ``(:constant ,#'(lambda (x) - (typep x ',(second type))) - ,',(second type))))))) - - -;;; Specify-Operand-Types -- Internal -;;; -(defun specify-operand-types (types ops more-ops) - (if (eq types :unspecified) - (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*) - types)) - - -;;; Make-VOP-Info-Types -- Internal -;;; -;;; Return a list of forms to use as keyword args to Make-VOP-Info for -;;; setting up the template argument and result types. Here we make an initial -;;; dummy Template-Type, since it is awkward to compute the type until the -;;; template has been made. -;;; -(defun make-vop-info-types (parse) - (let* ((more-args (vop-parse-more-args parse)) - (all-args (specify-operand-types (vop-parse-arg-types parse) - (vop-parse-args parse) - more-args)) - (args (if more-args (butlast all-args) all-args)) - (more-arg (when more-args (car (last all-args)))) - (more-results (vop-parse-more-results parse)) - (all-results (specify-operand-types (vop-parse-result-types parse) - (vop-parse-results parse) - more-results)) - (results (if more-results (butlast all-results) all-results)) - (more-result (when more-results (car (last all-results)))) - (conditional (vop-parse-conditional-p parse))) - - `( - :type (specifier-type '(function () nil)) - :arg-types (list ,@(mapcar #'make-operand-type args)) - :more-args-type ,(when more-args (make-operand-type more-arg)) - :result-types ,(if conditional - :conditional - `(list ,@(mapcar #'make-operand-type results))) - :more-results-type ,(when more-results - (make-operand-type more-result))))) - - - -;;;; Set up VOP-Info: - -(defconstant slot-inherit-alist - '((:emit-function . vop-info-emit-function) - (:generator-function . vop-info-generator-function) - (:target-function . vop-info-target-function))) - -;;; Inherit-VOP-Info -- Internal -;;; -;;; Something to help with inheriting VOP-Info slots. We return a -;;; keyword/value pair that can be passed to the constructor. Slot is the -;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse -;;; structure for the VOP inherited. If Parse is NIL, then we do nothing. If -;;; the Test form evaluates to true, then we return a form that selects the -;;; named slot from the VOP-Info structure corresponding to Parse. Otherwise, -;;; we return the Form so that the slot is recomputed. -;;; -(defmacro inherit-vop-info (slot parse test form) - `(if (and iparse ,test) - (list ,slot `(,',(or (cdr (assoc slot slot-inherit-alist)) - (error "Unknown slot ~S." slot)) - (template-or-lose ',(vop-parse-name ,parse)))) - (list ,slot ,form))) - - -;;; Set-Up-VOP-Info -- Internal -;;; -;;; Return a form that creates a VOP-Info structure which describes VOP. -;;; -(defun set-up-vop-info (iparse parse) - (declare (type vop-parse parse) (type (or vop-parse null) iparse)) - (let ((same-operands - (and iparse - (equal (vop-parse-operands parse) - (vop-parse-operands iparse)) - (equal (vop-parse-info-args iparse) - (vop-parse-info-args parse)))) - (variant (vop-parse-variant parse))) - - (let ((nvars (length (vop-parse-variant-vars parse)))) - (unless (= (length variant) nvars) - (error "Expected ~D variant values: ~S." nvars variant))) - - `(make-vop-info - :name ',(vop-parse-name parse) - ,@(make-vop-info-types parse) - :guard ,(when (vop-parse-guard parse) - `#'(lambda () ,(vop-parse-guard parse))) - :note ',(vop-parse-note parse) - :info-arg-count ,(length (vop-parse-info-args parse)) - :policy ',(vop-parse-policy parse) - :save-p ',(vop-parse-save-p parse) - :move-args ',(vop-parse-move-args parse) - :effects (vop-attributes ,@(vop-parse-effects parse)) - :affected (vop-attributes ,@(vop-parse-affected parse)) - ,@(make-costs-and-restrictions parse) - ,@(inherit-vop-info :emit-function iparse - same-operands - (make-emit-function parse)) - ,@(inherit-vop-info :generator-function iparse - (and same-operands - (equal (vop-parse-body parse) (vop-parse-body iparse))) - (unless (eq (vop-parse-body parse) :unspecified) - (make-generator-function parse))) - ,@(inherit-vop-info :target-function iparse - same-operands - (when (some #'operand-parse-target (vop-parse-operands parse)) - (make-target-function parse))) - :variant (list ,@variant)))) - -); Eval-When (Compile Load Eval) - - -;;; 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)))))) - - -;;; Define-VOP -- Public -;;; -;;; Parse the syntax into a VOP-Parse structure, and then expand into code -;;; that creates the appropriate VOP-Info structure at load time. We implement -;;; inheritance by copying the VOP-Parse structure for the inherited structure. -;;; -(defmacro define-vop ((name &optional inherits) &rest specs) - "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*) - :SCs specifies good SCs for this operand. Other SCs will be - penalized according to move costs. A load TN will be allocated if - necessary, guaranteeing that the operand is always one of the - specified SCs. - - :Load-TN Load-Name - Load-Name is bound to the load TN allocated for this operand, or to - NIL if no load TN was allocated. - - :Load-If Expression - Controls whether automatic operand loading is done. Expression is - evaluated with the fixed operand TNs bound. If Expression is true, - then loading is done and the variable is bound to the load TN in - the generator body. Otherwise, loading is not done, and the variable - is bound to the actual operand. - - :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. - - :From Time-Spec - :To Time-Spec - Specify the beginning or end of the operand's lifetime. :From can - only be used with results, and :To only with arguments. The default - for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These - options are necessary primarily when operands are read or written out - of order. - - :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 target - label is passed as the first :INFO arg. The second :INFO arg is true if - the sense of the test should be negated. 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: - - :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. If - Offset is emitted, the register allocator chooses a free location in - SC. If both SC and Offset are omitted, then the temporary is packed - according to its primitive type. - - :From Time-Spec - :To Time-Spec - Similar to the argument/result option, this specifies the start and - end of the temporarys' 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. by default 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 | NIL} - A short noun-like phrase describing what this VOP \"does\", i.e. the - implementation strategy. If supplied, efficency notes will be generated - when type uncertainty prevents :TRANSLATE from working. NIL inhibits any - efficency note. - - :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}* - :Result-Types {* | PType | (:OR PType*)}* - Specify the template type restrictions used for automatic translation. - If there is a :More operand, the last type is the more type. :CONSTANT - specifies that the argument must be a compile-time constant of the - specified Lisp type. The constant values of :CONSTANT arguments are - passed as additional :INFO arguments rather than as :ARGS. - - :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. - - :VOP-Var Name - :Node-Var Name - In the generator, bind the specified variable to the VOP or the Node that - generated this VOP. - - :Save-P {NIL | T | :Compute-Only | :Force-To-Stack} - Indicates how a VOP wants live registers saved. - - :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return} - Indicates if and how the more args should be moved into a different - frame." - (check-type name symbol) - - (let* ((iparse (when inherits - (vop-parse-or-lose inherits))) - (parse (if inherits - (copy-vop-parse iparse) - (make-vop-parse))) - (n-res (gensym))) - (setf (vop-parse-name parse) name) - (setf (vop-parse-inherits parse) inherits) - - (parse-define-vop parse specs) - (grovel-operands parse) - - `(progn - (eval-when (compile load eval) - (setf (gethash ',name *parsed-vops*) ',parse)) - - (let ((,n-res ,(set-up-vop-info iparse parse))) - (setf (gethash ',name *template-names*) ,n-res) - (setf (template-type ,n-res) - (specifier-type (template-type-specifier ,n-res))) - ,@(set-up-function-translation parse n-res)) - ',name))) - - -;;;; Emission macros: - -(eval-when (compile load eval) - -;;; Make-Operand-List -- Internal -;;; -;;; Return code to make a list of VOP arguments or results, linked by -;;; TN-Ref-Across. The first value is code, the second value is LET* forms, -;;; and the third value is a variable that evaluates to the head of the list, -;;; or NIL if there are no operands. Fixed is a list of forms that evaluate to -;;; TNs for the fixed operands. TN-Refs will be made for these operands -;;; according using the specified value of Write-P. More is an expression that -;;; evaluates to a list of TN-Refs that will be made the tail of the list. If -;;; it is constant NIL, then we don't bother to set the tail. -;;; -(defun make-operand-list (fixed more write-p) - (collect ((forms) - (binds)) - (let ((n-head nil) - (n-prev nil)) - (dolist (op fixed) - (let ((n-ref (gensym))) - (binds `(,n-ref (reference-tn ,op ,write-p))) - (if n-prev - (forms `(setf (tn-ref-across ,n-prev) ,n-ref)) - (setq n-head n-ref)) - (setq n-prev n-ref))) - - (when more - (let ((n-more (gensym))) - (binds `(,n-more ,more)) - (if n-prev - (forms `(setf (tn-ref-across ,n-prev) ,n-more)) - (setq n-head n-more)))) - - (values (forms) (binds) n-head)))) - -); Eval-When (Compile Load Eval) - - -;;; Emit-Template -- Interface -;;; -(defmacro emit-template (node block template args results &optional info) - "Emit-Template Node Block Template Args Results [Info] - Call the emit function for Template, linking the result in at the end of - Block." - (let ((n-first (gensym)) - (n-last (gensym))) - (once-only ((n-node node) - (n-block block) - (n-template template)) - `(multiple-value-bind - (,n-first ,n-last) - (funcall (template-emit-function ,n-template) - ,n-node ,n-block ,n-template ,args ,results - ,@(when info `(,info))) - (insert-vop-sequence ,n-first ,n-last ,n-block nil))))) - - -;;; VOP -- Interface -;;; -(defmacro vop (name node block &rest operands) - "VOP Name Node Block Arg* Info* Result* - Emit the VOP (or other template) Name at the end of the IR2-Block Block, - using Node for the source context. The interpretation of the remaining - arguments depends on the number of operands of various kinds that are - declared in the template definition. VOP cannot be used for templates that - have more-args or more-results, since the number of arguments and results is - indeterminate for these templates. Use VOP* instead. - - Args and Results are the TNs that are to be referenced by the template - as arguments and results. If the template has codegen-info arguments, then - the appropriate number of Info forms following the Arguments are used for - codegen info." - (let* ((parse (vop-parse-or-lose name)) - (arg-count (length (vop-parse-args parse))) - (result-count (length (vop-parse-results parse))) - (info-count (length (vop-parse-info-args parse))) - (noperands (+ arg-count result-count info-count)) - (n-node (gensym)) - (n-block (gensym)) - (n-template (gensym))) - - (when (or (vop-parse-more-args parse) (vop-parse-more-results parse)) - (error "Cannot use VOP with variable operand count templates.")) - (unless (= noperands (length operands)) - (error "Called with ~D operands, but was expecting ~D." - (length operands) noperands)) - - (multiple-value-bind - (acode abinds n-args) - (make-operand-list (subseq operands 0 arg-count) nil nil) - (multiple-value-bind - (rcode rbinds n-results) - (make-operand-list (subseq operands (+ arg-count info-count)) nil t) - - (collect ((ibinds) - (ivars)) - (dolist (info (subseq operands arg-count (+ arg-count info-count))) - (let ((temp (gensym))) - (ibinds `(,temp ,info)) - (ivars temp))) - - `(let* ((,n-node ,node) - (,n-block ,block) - (,n-template (template-or-lose ',name)) - ,@abinds - ,@(ibinds) - ,@rbinds) - ,@acode - ,@rcode - (emit-template ,n-node ,n-block ,n-template ,n-args - ,n-results - ,@(when (ivars) - `((list ,@(ivars))))) - (undefined-value))))))) - - -;;; VOP* -- Interface -;;; -(defmacro vop* (name node block args results &rest info) - "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info* - Like VOP, but allows for emission of templates with arbitrary numbers of - arguments, and for emission of templates using already-created TN-Ref lists. - - The Arguments and Results are TNs to be referenced as the first arguments - and results to the template. More-Args and More-Results are heads of TN-Ref - lists that are added onto the end of the TN-Refs for the explicitly supplied - operand TNs. The TN-Refs for the more operands must have the TN and Write-P - slots correctly initialized. - - As with VOP, the Info forms are evaluated and passed as codegen info - arguments." - (check-type args cons) - (check-type results cons) - (let* ((parse (vop-parse-or-lose name)) - (arg-count (length (vop-parse-args parse))) - (result-count (length (vop-parse-results parse))) - (info-count (length (vop-parse-info-args parse))) - (fixed-args (butlast args)) - (fixed-results (butlast results)) - (n-node (gensym)) - (n-block (gensym)) - (n-template (gensym))) - - (unless (or (vop-parse-more-args parse) - (<= (length fixed-args) arg-count)) - (error "Too many fixed arguments.")) - (unless (or (vop-parse-more-results parse) - (<= (length fixed-results) result-count)) - (error "Too many fixed results.")) - (unless (= (length info) info-count) - (error "Expected ~D info args." info-count)) - - (multiple-value-bind - (acode abinds n-args) - (make-operand-list fixed-args (car (last args)) nil) - (multiple-value-bind - (rcode rbinds n-results) - (make-operand-list fixed-results (car (last results)) t) - - `(let* ((,n-node ,node) - (,n-block ,block) - (,n-template (template-or-lose ',name)) - ,@abinds - ,@rbinds) - ,@acode - ,@rcode - (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results - ,@(when info - `((list ,@info)))) - (undefined-value)))))) - - -;;;; Random macros: - -;;; SC-Case -- Public -;;; -(defmacro sc-case (tn &rest forms) - "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." - (let ((n-sc (gensym)) - (n-tn (gensym))) - (collect ((clauses)) - (do ((cases forms (rest cases))) - ((null cases) - (clauses `(t (error "Unknown SC to SC-Case for ~S." ,n-tn)))) - (let ((case (first cases))) - (when (atom case) - (error "Illegal SC-Case clause: ~S." case)) - (let ((head (first case))) - (when (eq head t) - (when (rest cases) - (error "T case is not last in SC-Case.")) - (clauses `(t nil ,@(rest case))) - (return)) - (clauses `((or ,@(mapcar #'(lambda (x) - `(eql ,(meta-sc-number-or-lose x) - ,n-sc)) - (if (atom head) (list head) head))) - nil ,@(rest case)))))) - - `(let* ((,n-tn ,tn) - (,n-sc (sc-number (tn-sc ,n-tn)))) - (cond ,@(clauses)))))) - - -;;; SC-Is -- Interface -;;; -(defmacro sc-is (tn &rest scs) - "SC-Is TN SC* - Returns true if TNs SC is any of the named SCs, false otherwise." - (once-only ((n-sc `(sc-number (tn-sc ,tn)))) - `(or ,@(mapcar #'(lambda (x) - `(eql ,n-sc ,(meta-sc-number-or-lose x))) - scs)))) - - -;;; Do-IR2-Blocks -- Interface -;;; -(defmacro do-ir2-blocks ((block-var component &optional result) - &body forms) - "Do-IR2-Blocks (Block-Var Component [Result]) Form* - Iterate over the IR2 blocks in component, in emission order." - `(do ((,block-var (block-info (component-head ,component)) - (ir2-block-next ,block-var))) - ((null ,block-var) ,result) - ,@forms))) - - -;;; DO-LIVE-TNS -- Interface -;;; -(defmacro do-live-tns ((tn-var live block &optional result) &body body) - "DO-LIVE-TNS (TN-Var Live Block [Result]) Form* - Iterate over all the TNs live at some point, with the live set represented by - a local conflicts bit-vector and the IR2-Block containing the location." - (let ((n-conf (gensym)) - (n-bod (gensym)) - (i (gensym)) - (ltns (gensym))) - (once-only ((n-live live) - (n-block block)) - `(block nil - (flet ((,n-bod (,tn-var) ,@body)) - ;; - ;; Do component-live TNs. - (dolist (,tn-var (ir2-component-component-tns - (component-info - (block-component - (ir2-block-block ,n-block))))) - (,n-bod ,tn-var)) - ;; - ;; Do environment-live TNs. - (dolist (,tn-var (ir2-environment-live-tns - (environment-info - (ir2-block-environment ,n-block)))) - (,n-bod ,tn-var)) - - (let ((,ltns (ir2-block-local-tns ,n-block))) - ;; - ;; Do TNs always-live in this block and live :More TNs. - (do ((,n-conf (ir2-block-global-tns ,n-block) - (global-conflicts-next ,n-conf))) - ((null ,n-conf)) - (when (or (eq (global-conflicts-kind ,n-conf) :live) - (let ((,i (global-conflicts-number ,n-conf))) - (and (eq (svref ,ltns ,i) :more) - (not (zerop (sbit ,n-live ,i)))))) - (,n-bod (global-conflicts-tn ,n-conf)))) - ;; - ;; Do TNs locally live in the designated live set. - (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result) - (unless (zerop (sbit ,n-live ,i)) - (let ((,tn-var (svref ,ltns ,i))) - (when (and ,tn-var (not (eq ,tn-var :more))) - (,n-bod ,tn-var))))))))))) - - -;;; DO-ENVIRONMENT-IR2-BLOCKS -- Interface -;;; -(defmacro do-environment-ir2-blocks ((block-var env &optional result) - &body body) - "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form* - Iterate over all the IR2 blocks in the environment Env, in emit order." - (once-only ((n-env env)) - (once-only ((n-first `(node-block - (lambda-bind - (environment-function ,n-env))))) - (once-only ((n-tail `(block-info - (component-tail - (block-component ,n-first))))) - `(do ((,block-var (block-info ,n-first) - (ir2-block-next ,block-var))) - ((or (eq ,block-var ,n-tail) - (not (eq (ir2-block-environment ,block-var) ,n-env))) - ,result) - ,@body))))) - - -;;; NOTE-THIS-LOCATION -- Interface -;;; -(defmacro note-this-location (vop kind) - "NOTE-THIS-LOCATION VOP Kind - Node 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." - (once-only ((n-lab '(gen-label))) - `(progn - (emit-label ,n-lab) - (note-debug-location ,vop ,n-lab ,kind)))) - - -;;;; Utilities for defining miscops: - -(eval-when (compile load eval) - -;;; Miscop-Name -- Internal -;;; -;;; Return the name for a miscop with the specified args/results. -;;; -(defun miscop-name (nargs nresults conditional) - (intern (if conditional - (format nil "~:@(~R-ARG-CONDITIONAL-MISCOP~)" - nargs) - (format nil "~:@(~R-ARG~[-NO-VALUE~;~:;-~:*~R-VALUE~]-MISCOP~)" - nargs nresults)) - (find-package "C"))) - -); Eval-When (Compile Load Eval) - - -;;; Define-Miscop-Variants -- Interface -;;; -;;; Define a bunch of miscops VOPs that inherit the specified VOP and whose -;;; Template name, Miscop name and translate function are all the same. -;;; -;;; ### We intern the Variant name in the COMPILER package to get around -;;; bootstrapping package lossage. -;;; -(defmacro define-miscop-variants (vop &rest names) - (collect ((res)) - (dolist (name names) - (res `(define-vop (,name ,vop) - (:translate ,name) - (:variant ',(intern (symbol-name name) - (find-package "COMPILER")))))) - `(progn ,@(res)))) - - -;;; Define-Miscop -- Interface -;;; -;;; Define a miscop with the specified args/results and options. -;;; -(defmacro define-miscop (name args &key (results '(r)) translate - policy arg-types result-types - cost conditional) - `(define-vop (,name ,(miscop-name (length args) (length results) - conditional)) - (:variant ',(intern (symbol-name name) - (find-package "COMPILER"))) - ,@(when arg-types - `((:arg-types ,@arg-types))) - ,@(when result-types - `((:result-types ,@result-types))) - ,@(when policy - `((:policy ,policy))) - ,@(when cost - `((:variant-cost ,cost))) - ,@(when translate - `((:translate ,translate))))) diff --git a/compiler/vop.lisp b/compiler/vop.lisp deleted file mode 100644 index 28b7ae3f792ad0748b08412dd63bfd8ec843c911..0000000000000000000000000000000000000000 --- a/compiler/vop.lisp +++ /dev/null @@ -1,1110 +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). -;;; ********************************************************************** -;;; -;;; Structures for the second (virtual machine) intermediate representation -;;; in the compiler, IR2. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(proclaim '(special *sc-numbers*)) - -(eval-when (compile load eval) - -;;; -;;; The largest number of TNs whose liveness changes that we can have in any -;;; block. -(defconstant local-tn-limit 64) - -(deftype local-tn-number () `(integer 0 (,local-tn-limit))) -(deftype local-tn-count () `(integer 0 ,local-tn-limit)) -(deftype local-tn-vector () `(simple-vector ,local-tn-limit)) -(deftype local-tn-bit-vector () `(simple-bit-vector ,local-tn-limit)) - -;;; Type of an SC number. -(deftype sc-number () `(integer 0 (,sc-number-limit))) - -;;; Types for vectors indexed by SC numbers. -(deftype sc-vector () `(simple-vector ,sc-number-limit)) -(deftype sc-bit-vector () `(simple-bit-vector ,sc-number-limit)) - -;;; The different policies we can use to determine the coding strategy. -;;; -(deftype policies () - '(member :safe :small :fast :fast-safe)) - -); Eval-When (Compile Load Eval) - - -;;;; Primitive types: -;;; -;;; The primitive type is used to represent the aspects of type interesting -;;; to the VM. Selection of IR2 translation templates is done on the basis of -;;; the primitive types of the operands, and the primitive type of a value -;;; is used to constrain the possible representations of that value. -;;; -(defstruct (primitive-type (:print-function %print-primitive-type)) - ;; - ;; The name of this primitive-type. - (name nil :type symbol) - ;; - ;; A list the SC numbers for all the SCs that a TN of this type can be - ;; allocated in. - (scs nil :type list) - ;; - ;; The Lisp type equivalent to this type. If this type could never be - ;; returned by Primitive-Type, then this is the NIL (or empty) type. - (type nil :type ctype) - ;; - ;; The template used to check that an object is of this type. This is - ;; a template of one argument and one result, both of primitive-type T. If - ;; the argument is of the correct type, then it is delivered into the result. - ;; If the type is incorrect, then an error is signalled. - (check nil :type (or template null))) - -(defprinter primitive-type - name - (type :test (not (eq (type-specifier type) - (primitive-type-name structure))) - :prin1 (type-specifier type))) - - -;;;; IR1 annotations used for IR2 conversion: -;;; -;;; Block-Info -;;; Holds the IR2-Block structure. If there are overflow blocks, then this -;;; points to the first IR2-Block. The Block-Info of the dummy component -;;; head and tail are dummy IR2 blocks that begin and end the emission order -;;; thread. -;;; -;;; Component-Info -;;; Holds the IR2-Component structure. -;;; -;;; Continuation-Info -;;; Holds the IR2-Continuation structure. Continuations whose values aren't -;;; used won't have any. -;;; -;;; Cleanup-Info -;;; If non-null, then a TN in which the affected dynamic environment pointer -;;; should be saved after the binding is instantiated. -;;; -;;; Environment-Info -;;; Holds the IR2-Environment structure. -;;; -;;; Tail-Set-Info -;;; Holds the Return-Info structure. -;;; -;;; NLX-Info-Info -;;; Holds the IR2-NLX-Info structure. -;;; -;;; Leaf-Info -;;; If a non-set lexical variable, the TN that holds the value in the home -;;; environment. If a constant, then the corresponding constant TN. -;;; If an XEP lambda, then the corresponding Entry-Info structure. -;;; -;;; Basic-Combination-Info -;;; The template chosen by LTN, or -;;; :FULL if this is definitely a full call. -;;; :FUNNY if this is a random thing with IR2-convert. -;;; :LOCAL if this is a local call. -;;; -;;; Node-Tail-P -;;; After LTN analysis, this is true only in combination nodes that are -;;; truly tail recursive. -;;; - -;;; The IR2-Block structure holds information about a block that is used during -;;; and after IR2 conversion. It is stored in the Block-Info slot for the -;;; associated block. -;;; -(defstruct (ir2-block - (:constructor really-make-ir2-block (block)) - (:print-function %print-ir2-block)) - ;; - ;; The IR2-Block's number, which differs from Block's Block-Number if any - ;; blocks are split. This is assigned by lifetime analysis. - (number nil :type (or unsigned-byte null)) - ;; - ;; The IR1 block that this block is in the Info for. - (block nil :type cblock) - ;; - ;; The next and previous block in emission order (not DFO). This determines - ;; which block we drop though to, and also used to chain together overflow - ;; blocks that result from splitting of IR2 blocks in lifetime analysis. - (next nil :type (or ir2-block null)) - (prev nil :type (or ir2-block null)) - ;; - unused-slot - ;; - ;; Information about unknown-values continuations that is used by stack - ;; analysis to do stack simulation. A unknown-values continuation is Pushed - ;; if it's Dest is in another block. Similarly, a continuation is Popped if - ;; its Dest is in this block but has its uses elsewhere. The continuations - ;; are in the order that are pushed/popped in the block. Note that the args - ;; to a single MV-Combination appear reversed in Popped, since we must - ;; effectively pop the last argument first. All pops must come before all - ;; pushes (although internal MV uses may be interleaved.) Popped is computed - ;; by LTN, and Pushed is computed by stack analysis. - (pushed () :type list) - (popped () :type list) - ;; - ;; The result of stack analysis: lists of all the unknown-values - ;; continuations on the stack at the block start and end, topmost - ;; continuation first. - (start-stack () :type list) - (end-stack () :type list) - ;; - ;; The first and last VOP in this block. If there are none, both slots are - ;; null. - (start-vop nil (or vop null)) - (last-vop nil (or vop null)) - ;; - ;; Number of local TNs actually allocated. - (local-tn-count 0 :type local-tn-count) - ;; - ;; A vector that maps local TN numbers to TNs. Some entries may be NIL, - ;; indicating that that number is unused. (This allows us to delete local - ;; conflict information without compressing the LTN numbers.) - ;; - ;; If an entry is :More, then this block contains only a single VOP. This - ;; VOP has so many more arguments and/or results that they cannot all be - ;; assigned distinct LTN numbers. In this case, we assign all the more args - ;; one LTN number, and all the more results another LTN number. We can do - ;; this, since more operands are referenced simultaneously as far as conflict - ;; analysis is concerned. Note that all these :More TNs will be global TNs. - (local-tns (make-array local-tn-limit) :type local-tn-vector) - ;; - ;; Bit-vectors used during lifetime analysis to keep track of references to - ;; local TNs. When indexed by the LTN number, the index for a TN is non-zero - ;; in Written if it is ever written in the block, and in Live-Out if - ;; the first reference is a read. - (written (make-array local-tn-limit :element-type 'bit - :initial-element 0) - :type local-tn-bit-vector) - (live-out (make-array local-tn-limit :element-type 'bit) - :type local-tn-bit-vector) - ;; - ;; Similar to the above, but is updated by lifetime flow analysis to have a 1 - ;; for LTN numbers of TNs live at the end of the block. This takes into - ;; account all TNs that aren't :Live. - (live-in (make-array local-tn-limit :element-type 'bit - :initial-element 0) - :type local-tn-bit-vector) - ;; - ;; A thread running through the global-conflicts structures for this block, - ;; sorted by TN number. - (global-tns nil :type (or global-conflicts null)) - ;; - ;; The assembler label that points to the beginning of the code for this - ;; block. Null when we haven't assigned a label yet. - (%label nil) - ;; - ;; List of Location-Info structures describing all the interesting (to the - ;; debugger) locations in this block. - (locations nil :type list)) - - -(defprinter ir2-block - (pushed :test pushed) - (popped :test popped) - (start-vop :test start-vop) - (last-vop :test last-vop) - (local-tn-count :test (not (zerop local-tn-count))) - (%label :test %label)) - - -;;; The IR2-Continuation structure is used to annotate continuations that are -;;; used as a function result continuation or that receive MVs. -;;; -(defstruct (ir2-continuation - (:constructor make-ir2-continuation (primitive-type)) - (:print-function %print-ir2-continuation)) - ;; - ;; If this is :Delayed, then this is a single value continuation for which - ;; the evaluation of the use is to be postponed until the evaluation of - ;; destination. This can be done for ref nodes or predicates whose - ;; destination is an IF. - ;; - ;; If this is :Fixed, then this continuation has a fixed number of values, - ;; with the TNs in Locs. - ;; - ;; If this is :Unknown, then this is an unknown-values continuation, using - ;; the passing locations in Locs. - ;; - ;; If this is :Unused, then this continuation should never actually be used - ;; as the destination of a value: it is only used tail-recursively. - (kind :fixed :type (member :delayed :fixed :unknown :unused)) - ;; - ;; The primitive-type of the first value of this continuation. This is - ;; primarily for internal use during LTN, but it also records the type - ;; restriction on delayed references. In multiple-value contexts, this is - ;; null to indicate that it is meaningless. - (primitive-type nil :type (or primitive-type null)) - ;; - ;; Locations used to hold the values of the continuation. If the number - ;; of values if fixed, then there is one TN per value. If the number of - ;; values is unknown, then this is a two-list of TNs holding the start of the - ;; values glob and the number of values. - (locs nil :type list)) - -(defprinter ir2-continuation - kind - primitive-type - locs) - - -;;; The IR2-Component serves mostly to accumulate non-code information about -;;; the component being compiled. -;;;; -(defstruct ir2-component - ;; - ;; The counter used to allocate global TN numbers. - (global-tn-counter 0 :type unsigned-byte) - ;; - ;; Normal-TNs is the head of the list of all the normal TNs that need to be - ;; packed, linked through the Next slot. We place TNs on this list when we - ;; allocate them so that Pack can find them. - ;; - ;; Restricted-TNs are TNs that must be packed within a finite SC. We pack - ;; these TNs first to ensure that the restrictions will be satisfied (if - ;; possible). - ;; - ;; Wired-TNs are TNs that must be packed at a specific location. The SC - ;; and Offset are already filled in. - ;; - ;; Constant-TNs are non-packed TNs that represent constants. :Constant TNs - ;; may eventually be converted to :Cached-Constant normal TNs. - (normal-tns nil :type (or tn null)) - (restricted-tns nil :type (or tn null)) - (wired-tns nil :type (or tn null)) - (constant-tns nil :type (or tn null)) - ;; - ;; A list of all the :COMPONENT TNs (live throughout the component.) These - ;; TNs will also appear in the {NORMAL,RESTRICTED,WIRED} TNs as appropriate - ;; to their kind. - (component-tns () :type list) - ;; - ;; If this component has a NFP, then this is it. - (nfp nil :type (or tn null)) - ;; - unused-slot - ;; - ;; Values-Receivers is a list of all the blocks whose ir2-block has a - ;; non-null value for Popped. This slot is initialized by LTN-Analyze as an - ;; input to Stack-Analyze. - (values-receivers nil :type list) - ;; - ;; An adjustable vector that records all the constants in the constant pool. - ;; A non-immediate :Constant TN with offset 0 refers to the constant in - ;; element 0, etc. Normal constants are represented by the placing the - ;; Constant leaf in this vector. A load-time constant is distinguished by - ;; being a cons (Kind . What). Kind is a keyword indicating how the constant - ;; is computed, and What is some context. - ;; - ;; These load-time constants are recognized: - ;; - ;; (:entry . <function>) - ;; Is replaced by the code pointer for the specified function. This is - ;; how compiled code (including DEFUN) gets its hands on a function. - ;; <function> is the XEP lambda for the called function; it's Leaf-Info - ;; should be an Entry-Info structure. - ;; - ;; (:label . <label>) - ;; Is replaced with the byte offset of that label from the start of the - ;; code vector (including the header length.) - ;; - ;; A null entry in this vector is a placeholder for implementation overhead - ;; that is eventually stuffed in somehow. - ;; - (constants (make-array 10 :fill-pointer 0 :adjustable t) :type vector) - ;; - ;; Some kind of info about the component's run-time representation. This is - ;; filled in by the VM supplied Select-Component-Format function. - format - ;; - ;; A list of the Entry-Info structures describing all of the entries into - ;; this component. Filled in by entry analysis. - (entries nil :type list)) - - -;;; The Entry-Info structure condenses all the information that the dumper -;;; needs to create each XEP's function entry data structure. -;;; -(defstruct entry-info - ;; - ;; True if this function has a non-null closure environment. - (closure-p nil :type boolean) - ;; - ;; A label pointing to the entry vector for this function. - (offset nil :type label) - ;; - ;; If this function was defined using DEFUN, then this is the name of the - ;; function, a symbol or (SETF <symbol>). Otherwise, this is some string - ;; that is intended to be informative. - (name nil :type (or simple-string list symbol)) - ;; - ;; A string representing the argument list that the function was defined - ;; with. - (arguments nil :type simple-string) - ;; - ;; A function type specifier representing the arguments and results of this - ;; function. - (type nil :type list)) - - -;;; The IR2-Environment is used to annotate non-let lambdas with their passing -;;; locations. It is stored in the Environment-Info. -;;; -(defstruct (ir2-environment - (:print-function %print-ir2-environment)) - ;; - ;; A list of the argument passing TNs. The explict arguments are first, - ;; followed by the implict environment arguments. In an XEP, there are no - ;; arg TNs corresponding to any environment TNs, since the environment is - ;; accessed from the closure. - (arg-locs nil :type list) - ;; - ;; The TNs that hold the passed environment within the function. This is an - ;; alist translating from the NLX-Info or lambda-var to the TN that holds - ;; the corresponding value within this function. This list is in the same - ;; order as the ENVIRONMENT-CLOSURE and environment passing locations in the - ;; ARG-LOCS. - (environment nil :type list) - ;; - ;; The TNs that hold the Old-Fp and Return-PC within the function. We - ;; always save these so that the debugger can do a backtrace, even if the - ;; function has no return (and thus never uses them). Null only temporarily. - (old-fp nil :type (or tn null)) - (return-pc nil :type (or tn null)) - ;; - ;; The passing locations for Old-Fp and Return-PC. - (old-fp-pass nil :type tn) - (return-pc-pass nil :type tn) - ;; - ;; True if this function has a frame on the number stack. This is set by - ;; representation selection whenever it is possible that some function in - ;; our tail set will make use of the number stack. - (number-stack-p nil :type boolean) - ;; - ;; A list of all the :Environment TNs live in this environment. - (live-tns nil :type list) - ;; - ;; A list of all the keep-around TNs live in this environment. - (keep-around-tns nil :type list) - ;; - ;; A label that marks the start of elsewhere code for this function. Null - ;; until this label is assigned by codegen. Used for maintaining the debug - ;; source map. - (elsewhere-start nil :type (or label null)) - ;; - ;; A label that marks the first location in this function at which the - ;; environment is properly initialized, i.e. arguments moved from their - ;; passing locations, etc. This is the start of the function as far as the - ;; debugger is concerned. - (environment-start nil :type (or label null))) - -(defprinter ir2-environment - arg-locs - environment - old-fp - old-fp-pass - return-pc - return-pc-pass) - - -;;; The Return-Info structure is used by GTN to represent the return strategy -;;; and locations for all the functions in a given Tail-Set. It is stored in -;;; the Tail-Set-Info. -;;; -(defstruct (return-info - (:print-function %print-return-info)) - ;; - ;; The return convention used: - ;; -- If :Unknown, we use the standard return convention. - ;; -- If :Fixed, we use the known-values convention. - (kind nil :type (member :fixed :unknown)) - ;; - ;; The number of values returned, or :Unknown if we don't know. Count may be - ;; known when Kind is :Unknown, since we may choose the standard return - ;; convention for other reasons. - (count nil :type (or unsigned-byte (member :unknown))) - ;; - ;; If count isn't :Unknown, then this is a list of the primitive-types of - ;; each value. - (types () :type list) - ;; - ;; If kind is :Fixed, then this is the list of the TNs that we return the - ;; values in. - (locations () :type list)) - - -(defprinter return-info - kind - count - types - locations) - - -(defstruct (ir2-nlx-info (:print-function %print-ir2-nlx-info)) - ;; - ;; If the kind is :Entry (a lexical exit), then in the home environment, this - ;; holds a Value-Cell object containing the unwind block pointer. In the - ;; other cases nobody directly references the unwind-block, so we leave this - ;; slot null. - (home nil :type (or tn null)) - ;; - ;; The saved control stack pointer. - (save-sp nil :type tn) - ;; - ;; The list of dynamic state save TNs. - (dynamic-state (make-dynamic-state-tns) :type list) - ;; - ;; The target label for NLX entry. - (target (gen-label) :type label)) - - -(defprinter ir2-nlx-info - home - save-sp - dynamic-state) - - -#| -;;; The Loop structure holds information about a loop. -;;; -(defstruct (cloop (:print-function %print-loop) - (:conc-name loop-) - (:predicate loop-p) - (:constructor make-loop) - (:copier copy-loop)) - ;; - ;; The kind of loop that this is. These values are legal: - ;; - ;; :Outer - ;; This is the outermost loop structure, and represents all the - ;; code in a component. - ;; - ;; :Natural - ;; A normal loop with only one entry. - ;; - ;; :Strange - ;; A segment of a "strange loop" in a non-reducible flow graph. - ;; - (kind nil :type (member :outer :natural :strange)) - ;; - ;; The first and last blocks in the loop. There may be more than one tail, - ;; since there may be multiple back branches to the same head. - (head nil :type (or cblock null)) - (tail nil :type list) - ;; - ;; A list of all the blocks in this loop or its inferiors that have a - ;; successor outside of the loop. - (exits nil :type list) - ;; - ;; The loop that this loop is nested within. This is null in the outermost - ;; loop structure. - (superior nil :type (or cloop null)) - ;; - ;; A list of the loops nested directly within this one. - (inferiors nil :type list) - ;; - ;; The head of the list of blocks directly within this loop. We must recurse - ;; on Inferiors to find all the blocks. - (blocks nil :type (or null cblock))) - -(defprinter loop - kind - head - tail - exits) -|# - - -;;;; VOPs and Templates: - -;;; A VOP is a Virtual Operation. It represents an operation and the operands -;;; to the operation. -;;; -(defstruct (vop (:print-function %print-vop) - (:constructor really-make-vop (block node info args results))) - ;; - ;; VOP-Info structure containing static info about the operation. - (info nil :type (or vop-info null)) - ;; - ;; The IR2-Block this VOP is in. - (block nil :type ir2-block) - ;; - ;; VOPs evaluated after and before this one. Null at the beginning/end of - ;; the block, and temporarily during IR2 translation. - (next nil :type (or vop null)) - (prev nil :type (or vop null)) - ;; - ;; Heads of the TN-Ref lists for operand TNs, linked using the Across slot. - (args nil :type (or tn-ref null)) - (results nil :type (or tn-ref null)) - ;; - ;; Head of the list of write refs for each explicitly allocated temporary, - ;; linked together using the Across slot. - (temps nil :type (or tn-ref null)) - ;; - ;; Head of the list of all TN-refs for references in this VOP, linked by the - ;; Next-Ref slot. There will be one entry for each operand and two (a read - ;; and a write) for each temporary. - (refs nil :type (or tn-ref null)) - ;; - ;; Stuff that is passed uninterpreted from IR2 conversion to codegen. The - ;; meaning of this slot is totally dependent on the VOP. - codegen-info - ;; - ;; Node that generated this VOP, for keeping track of debug info. - (node nil :type (or node null)) - ;; - ;; Local-TN bit vector representing the set of TNs live after args are read - ;; and before results are written. This is only filled in when - ;; VOP-INFO-SAVE-P is non-null. - (save-set nil :type (or local-tn-bit-vector null))) - -(defprinter vop - (info :prin1 (vop-info-name info)) - args - results - (codegen-info :test codegen-info)) - - -;;; The TN-Ref structure contains information about a particular reference to a -;;; TN. The information in the TN-Refs largely determines how TNs are packed. -;;; -(defstruct (tn-ref (:print-function %print-tn-ref) - (:constructor really-make-tn-ref (tn write-p))) - ;; - ;; The TN referenced. - (tn nil :type tn) - ;; - ;; True if this is a write reference, false if a read. - (write-p nil :type boolean) - ;; - ;; Thread running through all TN-Refs for this TN of the same kind (read or - ;; write). - (next nil :type (or tn-ref null)) - ;; - ;; The VOP where the reference happens. The this is null only temporarily. - (vop nil :type (or vop null)) - ;; - ;; Thread running through all TN-Refs in VOP, in reverse order of reference. - (next-ref nil :type (or tn-ref null)) - ;; - ;; Thread the TN-Refs in VOP of the same kind (argument, result, temp). - (across nil :type (or tn-ref null)) - ;; - ;; If true, this is a TN-Ref also in VOP whose TN we would like packed in the - ;; same location as our TN. Read and write refs are always paired: Target in - ;; the read points to the write, and vice-versa. - (target nil :type (or null tn-ref)) - ;; - ;; Load TN allocated for this operand, if any. - (load-tn nil :type (or tn null))) - - -(defprinter tn-ref - tn - write-p - (vop :test vop :prin1 (vop-info-name (vop-info vop)))) - - -;;; The Template represents a particular IR2 coding strategy for a known -;;; function. -;;; -(defstruct (template - (:print-function %print-template)) - ;; - ;; The symbol name of this VOP. This is used when printing the VOP and is - ;; also used to provide a handle for definition and translation. - (name nil :type symbol) - ;; - ;; A Function-Type describing the arg/result type restrictions. We compute - ;; this from the Primitive-Type restrictions to make life easier for IR1 - ;; phases that need to anticipate LTN's template selection. - (type nil :type function-type) - ;; - ;; Lists of restrictions on the argument and result types. A restriction may - ;; take several forms: - ;; -- The restriction * is no restriction at all. - ;; -- A restriction (:OR <primitive-type>*) means that the operand must have - ;; one of the specified primitive types. - ;; -- A restriction (:CONSTANT <predicate> <type-spec>) means that the - ;; argument (not a result) must be a compile-time constant that satisfies - ;; the specified predicate function. In this case, the constant value - ;; will be passed as an info argument rather than as a normal argument. - ;; <type-spec> is a Lisp type specifier for the type tested by the - ;; predicate, used when we want to represent the type constraint as a Lisp - ;; function type. - ;; - ;; If Result-Types is :Conditional, then this is an IF-xxx style conditional - ;; that yeilds its result as a control transfer. The emit function takes two - ;; info arguments: the target label and a boolean flag indicating whether to - ;; negate the sense of the test. - (arg-types nil :type list) - (result-types nil :type (or list (member :conditional))) - ;; - ;; The primitive type restriction applied to each extra argument or result - ;; following the fixed operands. If NIL, no extra args/results are allowed. - ;; Otherwise, either * or a (:OR ...) list as described for the - ;; {ARG,RESULT}-TYPES. - (more-args-type nil :type (or (member nil *) cons)) - (more-results-type nil :type (or (member nil *) cons)) - ;; - ;; If true, this is a function that is called with no arguments to see if - ;; this template can be emitted. This is used to conditionally compile for - ;; different target hardware configuarations (e.g. FP hardware.) - (guard nil :type (or function null)) - ;; - ;; The policy under which this template is the best translation. Note that - ;; LTN might use this template under other policies if it can't figure our - ;; anything better to do. - (policy nil :type policies) - ;; - ;; The base cost for this template, given optimistic assumptions such as no - ;; operand loading, etc. - (cost nil :type unsigned-byte) - ;; - ;; If true, then a short noun-like phrase describing what this VOP "does", - ;; i.e. the implementation strategy. This is for use in efficiency notes. - (note nil :type (or string null)) - ;; - ;; The number of trailing arguments to VOP or %Primitive that we bundle into - ;; a list and pass into the emit function. This provides a way to pass - ;; uninterpreted stuff directly to the code generator. - (info-arg-count 0 :type unsigned-byte) - ;; - ;; A function that emits the VOPs for this template. Arguments: - ;; 1] Node for source context. - ;; 2] IR2-Block that we place the VOP in. - ;; 3] This structure. - ;; 4] Head of argument TN-Ref list. - ;; 5] Head of result TN-Ref list. - ;; 6] If Info-Arg-Count is non-zero, then a list of the magic arguments. - ;; - ;; Two values are returned: the first and last VOP emitted. This vop - ;; sequence must be linked into the VOP Next/Prev chain for the block. At - ;; least one VOP is always emitted. - (emit-function nil :type function)) - -(defprinter template - name - arg-types - result-types - (more-args-type :test more-args-type :prin1 more-args-type) - (more-results-type :test more-results-type :prin1 more-results-type) - policy - cost - (note :test note) - (info-arg-count :test (not (zerop info-arg-count)))) - - -;;; The VOP-Info structure holds the constant information for a given virtual -;;; operation. We include Template so functions with a direct VOP equivalent -;;; can be translated easily. -;;; -(defstruct (vop-info - (:include template) - (:print-function %print-template)) - ;; - ;; Side-effects of this VOP and side-effects that affect the value of this - ;; VOP. - (effects nil :type attributes) - (affected nil :type attributes) - ;; - ;; If true, causes special casing of TNs live after this VOP that aren't - ;; results: - ;; -- If T, all such TNs that are allocated in a SC with a defined save-sc - ;; will be saved in a TN in the save SC before the VOP and restored after - ;; the VOP. This is used by call VOPs. A bit vector representing the - ;; live TNs is stored in the VOP-SAVE-SET. - ;; -- If :Force-To-Stack, all such TNs will made into :Environment TNs and - ;; forced to be allocated in SCs without any save-sc. This is used by NLX - ;; entry vops. - ;; -- If :Compute-Only, just compute the save set, don't do any saving. This - ;; is used to get the live variables for debug info. - ;; - (save-p nil :type (member t nil :force-to-stack :compute-only)) - ;; - ;; Info for automatic emission of move-arg VOPs by representation selection. - ;; If NIL, then do nothing special. If non-null, then there must be a more - ;; arg. Each more arg is moved to its passing location using the appropriate - ;; representation-specific move-argument VOP. The first (fixed) argument - ;; must be the control-stack frame pointer for the frame to move into. The - ;; first info arg is the list of passing locations. - ;; - ;; Additional constraints depend on the value: - ;; - ;; :FULL-CALL - ;; None. - ;; - ;; :LOCAL-CALL - ;; The second (fixed) arg is the NFP for the called function (from - ;; ALLOCATE-FRAME.) - ;; - ;; :KNOWN-RETURN - ;; If needed, the old NFP is computed using COMPUTE-OLD-NFP. - ;; - (move-args nil :type (member nil :full-call :local-call :known-return)) - ;; - ;; A list of sc-vectors representing the loading costs of each fixed argument - ;; and result. - (arg-costs nil :type list) - (result-costs nil :type list) - ;; - ;; If true, sc-vectors representing the loading costs for any more args and - ;; results. - (more-arg-costs nil :type (or sc-vector null)) - (more-result-costs nil :type (or sc-vector null)) - ;; - ;; Lists of sc-vectors holding the SC numbers mapping SCs to the SC that we - ;; load into. The entry is null if there is no load function which loads - ;; from that SC to an SC allowed by the operand SC restriction. If a SC is - ;; directly acceptable to the VOP, then the entry equals its index. - (arg-load-scs nil :type list) - (result-load-scs nil :type list) - ;; - ;; If true, a function that is called with the VOP to do operand targeting. - ;; This is done by modifiying the TN-Ref-Target slots in the TN-Refs so that - ;; they point to other TN-Refs in the same VOP. - (target-function nil :type (or null function)) - ;; - ;; A function that emits assembly code for a use of this VOP when it is - ;; called with the VOP structure. Null if this VOP has no specified - ;; generator (i.e. it exists only to be inherited by other VOPs.) - (generator-function nil :type (or function null)) - ;; - ;; A list of things that are used to parameterize an inherited generator. - ;; This allows the same generator function to be used for a group of VOPs - ;; with similar implementations. - (variant nil :type list)) - - -;;;; SBs and SCs: - -(eval-when (#-new-compiler compile load eval) - -;;; The SB structure represents the global information associated with a -;;; storage base. -;;; -(defstruct (sb (:print-function %print-sb)) - ;; - ;; Name, for printing and reference. - (name nil :type symbol) - ;; - ;; The kind of storage base (which determines the packing algorithm). - (kind :non-packed :type (member :finite :unbounded :non-packed)) - ;; - ;; The number of elements in the SB. If finite, this is the total size. If - ;; unbounded, this is the size that the SB is initially allocated at. - (size 0 :type unsigned-byte)) - -(defprinter sb - name) - - -;;; The Finite-SB structure holds information needed by the packing algorithm -;;; for finite SBs. -;;; -(defstruct (finite-sb (:include sb) - (:print-function %print-sb)) - ;; - ;; - ;; The number of locations currently allocated in this SB. - (current-size 0 :type unsigned-byte) - ;; - ;; The last location packed in, used by pack to scatter TNs to prevent a few - ;; locations from getting all the TNs, and thus getting overcrowded, reducing - ;; the possiblilities for targeting. - (last-offset 0 :type unsigned-byte) - ;; - ;; A vector containing, for each location in this SB, a vector indexed by IR2 - ;; block numbers, holding local conflict bit vectors. A TN must not be - ;; packed in a given location within a particular block if the LTN number for - ;; that TN in that block corresponds to a set bit in the bit-vector. - (conflicts '#() :type simple-vector) - ;; - ;; A vector containing, for each location in this SB, a bit-vector indexed by - ;; IR2 block numbers. If the bit corresponding to a block is set, then the - ;; location is in use somewhere in the block, and thus has a conflict for - ;; always-live TNs. - (always-live '#() :type simple-vector) - ;; - ;; A vector containing the TN currently live in each location in the SB, or - ;; NIL if the location is unused. This is used during load-tn pack. - (live-tns '#() :type simple-vector)) - - -;;; the SC structure holds the storage base that storage is allocated in and -;;; information used to select locations within the SB. -;;; -(defstruct (sc (:print-function %print-sc)) - ;; - ;; Name, for printing and reference. - (name nil :type symbol) - ;; - ;; The number used to index SC cost vectors. - (number 0 :type sc-number) - ;; - ;; The storage base that this SC allocates storage from. - (sb nil :type (or sb null)) - ;; - ;; The size of elements in this SC, in units of locations in the SB. - (element-size 0 :type unsigned-byte) - ;; - ;; If our SB is finite, a list of the locations in this SC. - (locations nil :type list) - ;; - ;; A list of the alternate (save) SCs for this SC. - (alternate-scs nil :type list) - ;; - ;; A list of the constant SCs that can me moved into this SC. - (constant-scs nil :type list) - ;; - ;; True if this values in this SC needs to be saved across calls. - (save-p nil :type boolean) - ;; - ;; Vectors mapping from SC numbers to information about how to load from the - ;; index SC to this one. Load-Functions holds the names of the functions - ;; used to do loading, and Load-Costs holds the cost of the corresponding - ;; Load-Functions. If loading is impossible, then the entries are NIL. - ;; Load-Costs is initialized to have a 0 for this SC. - (load-functions (make-array sc-number-limit :initial-element nil) - :type sc-vector) - (load-costs (make-array sc-number-limit :initial-element nil) - :type sc-vector) - ;; - ;; Vector mapping from SC numbers to representation move and coerce VOPs. If - ;; an entry is non-null, then it is the VOP-INFO for the VOP that coerces an - ;; object in the index SC's representation info this SC's representation. If - ;; null, no special VOP is necessary: just use MOVE. This vector is filled - ;; out with entries for all SCs that can somehow be coerced into this SC, not - ;; just those VOPs defined to directly move into this SC (i.e. it allows for - ;; operand loading on the move VOP's operands.) - ;; - ;; If there are special non-coercing moves (i.e. non-null entries for this SC - ;; or its alternates), then they should not use any wired temporaries. - (move-vops (make-array sc-number-limit :initial-element nil) - :type sc-vector) - ;; - ;; The costs corresponding to the MOVE-VOPS. Separate because this info is - ;; needed at meta-compile time, while the MOVE-VOPs don't exist till load - ;; time. If no move is defined, then the entry is NIL. - (move-costs (make-array sc-number-limit :initial-element nil) - :type sc-vector) - ;; - ;; Similar to Move-VOPs, except that we only ever use the entries for this SC - ;; and its alternates, since we never combine complex representation - ;; conversion with argument passing. - (move-arg-vops (make-array sc-number-limit :initial-element nil) - :type sc-vector) - ;; - ;; True if this SC or one of its alternates in in the NUMBER-STACK SB. - (number-stack-p nil :type boolean)) - -(defprinter sc - name) - -); eval-when (compile load eval) - - -;;;; TNs: - -(eval-when (#-new-compiler compile load eval) - -(defstruct (tn (:include sset-element) - (:constructor make-random-tn) - (:constructor really-make-tn (number kind primitive-type sc)) - (:print-function %print-tn)) - ;; - ;; The kind of TN this is: - ;; - ;; :Normal - ;; A normal, non-constant TN, representing a variable or temporary. - ;; Lifetime information is computed so that packing can be done. - ;; - ;; :Environment - ;; A TN that has hidden references (debugger or NLX), and thus must be - ;; allocated for the duration of the environment it is referenced in. - ;; All references must be in the environment that was specified to - ;; Make-Environment-TN. Conflicts are represented specially. These - ;; TNs never appear in the IR2-Block-XXX-TNs. Environment TNs never - ;; have Local or Local-Number. - ;; - ;; :Component - ;; Implicit conflict info like :Environment, but allocated over the - ;; entire component. No restriction on referencing environments. - ;; - ;; :Save - ;; :Save-Once - ;; A TN used for saving a :Normal TN across function calls. The - ;; lifetime information slots are unitialized: get the original TN our - ;; of the SAVE-TN slot and use it for conflicts. Save-Once is like - ;; :Save, except that it is only save once at the single writer of the - ;; original TN. - ;; - ;; :Load - ;; A load-TN used to compute an argument or result that is restricted - ;; to some finite SB. Load TNs don't have any conflict information. - ;; Load TN pack uses a special local conflict determination method. - ;; - ;; :Constant - ;; Represents a constant, with TN-Leaf a Constant leaf. Lifetime - ;; information isn't computed, since the value isn't allocated by - ;; pack, but is instead generated as a load at each use. Since - ;; lifetime analysis isn't done on :Constant TNs, they don't have - ;; Local-Numbers and similar stuff. - ;; - ;; :Cached-Constant - ;; Represents a constant for which caching in a register would be - ;; desirable. Lifetime information is computed so that the cached - ;; copies can be allocated. - ;; - (kind nil :type (member :normal :environment :save :save-once :load :constant - :component)) - ;; - ;; The primitive-type for this TN's value. Null in restricted or wired TNs. - (primitive-type nil :type (or primitive-type null)) - ;; - ;; If this TN represents a variable or constant, then this is the - ;; corresponding Leaf. - (leaf nil :type (or leaf null)) - ;; - ;; Thread that links TNs together so that we can find them. - (next nil :type (or tn null)) - ;; - ;; Head of TN-Ref lists for reads and writes of this TN. - (reads nil :type (or tn-ref null)) - (writes nil :type (or tn-ref null)) - ;; - ;; A link we use when building various temporary TN lists. - (next* nil :type (or tn null)) - ;; - ;; Some block that contains a reference to this TN, or Nil if we haven't seen - ;; any reference yet. If the TN is local, then this is the block it is local - ;; to. - (local nil :type (or ir2-block null)) - ;; - ;; If a local TN, the block relative number for this TN. Global TNs whose - ;; liveness changes within a block are also assigned a local number during - ;; the conflicts analysis of that block. If the TN has no local number - ;; within the block, then this is Nil. - (local-number nil :type (or local-tn-number null)) - ;; - ;; If a local TN, a bit-vector with 1 for the local-number of every TN that - ;; we conflict with. - (local-conflicts (make-array local-tn-limit :element-type 'bit - :initial-element 0) - :type local-tn-bit-vector) - ;; - ;; Head of the list of Global-Conflicts structures for a global TN. This - ;; list is sorted by block number (i.e. reverse DFO), allowing the - ;; intersection between the lifetimes for two global TNs to be easily found. - ;; If null, then this TN is a local TN. - (global-conflicts nil :type (or global-conflicts null)) - ;; - ;; During lifetime analysis, this is used as a pointer into the conflicts - ;; chain, for scanning through blocks in reverse DFO. - (current-conflict nil) - ;; - ;; In a :Save TN, this is the TN saved. In a :Normal or :Environment TN, - ;; this is the associated save TN. In TNs with no save TN, this is null. - (save-tn nil :type (or tn null)) - ;; - ;; After pack, the SC we packed into. Beforehand, the SC we want to pack - ;; into, or null if we don't know. - (sc nil :type (or sc null)) - ;; - ;; The offset within the SB that this TN is packed into. This is what - ;; indicates that the TN is packed. - (offset nil :type (or unsigned-byte null))) - -); Eval-When (Compile Load Eval) - -(defun %print-tn (s stream d) - (declare (ignore d)) - (write-string "#<TN " stream) - (print-tn s stream) - (write-char #\> stream)) - -#| -(defprinter tn - (number :test (/= number 0) :prin1 (tn-id structure)) - kind - (primitive-type :test primitive-type - :prin1 (primitive-type-name primitive-type)) - (leaf :test leaf) - (sc :test sc :prin1 (sc-name sc)) - (offset :test offset)) -|# - -;;; The Global-Conflicts structure represents the conflicts for global TNs. -;;; Each global TN has a list of these structures, one for each block that it -;;; is live in. In addition to repsenting the result of lifetime analysis, the -;;; global conflicts structure is used during lifetime analysis to represent -;;; the set of TNs live at the start of the IR2 block. -;;; -(defstruct (global-conflicts - (:constructor really-make-global-conflicts (kind tn block number)) - (:print-function %print-global-conflicts)) - - ;; - ;; The IR2-Block that this structure represents the conflicts for. - (block nil :type ir2-block) - ;; - ;; Thread running through all the Global-Conflict for Block. This - ;; thread is sorted by TN number. - (next nil :type (or global-conflicts null)) - ;; - ;; The way that TN is used by Block: - ;; - ;; :Read - ;; The TN is read before it is written. It starts the block live, but - ;; is written within the block. - ;; - ;; :Write - ;; The TN is written before any read. It starts the block dead, and - ;; need not have a read within the block. - ;; - ;; :Read-Only - ;; The TN is read, but never written. It starts the block live, and - ;; is not killed by the block. Lifetime analysis will promote - ;; :Read-Only TNs to :Live if they are live at the block end. - ;; - ;; :Live - ;; The TN is not referenced. It is live everywhere in the block. - ;; - (kind :read-only :type (member :read :write :read-only :live)) - ;; - ;; A local conflicts vector representing conflicts with TNs live in Block. - ;; The index for the local TN number of each TN we conflict with in this - ;; block is 1. To find the full conflict set, the :Live TNs for Block must - ;; also be included. This slot is not meaningful when Kind is :Live. - (conflicts (make-array local-tn-limit - :element-type 'bit - :initial-element 0) - :type local-tn-bit-vector) - ;; - ;; The TN we are recording conflicts for. - (tn nil :type tn) - ;; - ;; Thread through all the Global-Conflicts for TN. - (tn-next nil :type (or global-conflicts null)) - ;; - ;; TN's local TN number in Block. :Live TNs don't have local numbers. - (number nil :type (or local-tn-number null))) - -(defprinter global-conflicts - tn - block - kind - (number :test number)) diff --git a/hemlock/abbrev.lisp b/hemlock/abbrev.lisp deleted file mode 100644 index a314b76b605400e55fa0f37cbd4344f5a6f16bb5..0000000000000000000000000000000000000000 --- a/hemlock/abbrev.lisp +++ /dev/null @@ -1,682 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock Word Abbreviation Mode -;;; by Jamie W. Zawinski -;;; 24 September 1985 -;;; -(in-package "HEMLOCK") - -;;;; These Things are Here: - -;;; C-X C-A Add Mode Word Abbrev -;;; Define a mode abbrev for the word before point. -;;; C-X + Add Global Word Abbrev -;;; Define a global abbrev for the word before point. -;;; C-X C-H Inverse Add Mode Word Abbrev -;;; Define expansion for mode abbrev before point. -;;; C-X - Inverse Add Global Word Abbrev -;;; Define expansion for global abbrev before point. -;;; Alt Space Abbrev Expand Only -;;; Expand abbrev without inserting anything. -;;; M-' Word Abbrev Prefix Mark -;;; Mark a prefix to be glued to an abbrev following. -;;; C-X U Unexpand Last Word -;;; Unexpands last abbrev or undoes C-X U. - -;;; List Word Abbrevs Shows definitions of all word abbrevs. -;;; Edit Word Abbrevs Lets you edit the definition list directly. -;;; Read Word Abbrev File <filename> Define word abbrevs from a definition file. -;;; Write Word Abbrev File Make a definition file from current abbrevs. - -;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc. -;;; Delete All Word Abbrevs Wipes them all. -;;; Delete Mode Word Abbrev Kills all Mode abbrev. -;;; Delete Global Word Abbrev Kills all Global abbrev. - -;;; Insert Word Abbrevs Inserts a list of current definitions in the -;;; format that Define Word Abbrevs uses. -;;; Define Word Abbrevs Defines set of abbrevs from a definition list in -;;; the buffer. -;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev, -;;; definition, or mode. - -;;; Append Incremental Word Abbrev File Appends to a file changed abbrev -;;; definitions since last dumping. - -(defmode "Abbrev" :major-p nil :transparent-p t :precedence 2.0) - - -(defvar *Global-Abbrev-Table* (make-hash-table :test #'equal) - "Hash table holding global abbrev definitions.") - -(defhvar "Abbrev Pathname Defaults" - "Holds the name of the last Abbrev-file written." - :value (pathname "abbrev.defns")) - -(defvar *new-abbrevs* () - "holds a list of abbrevs (and their definitions and modes) changed since saving.") - - -;;; C-X C-H Inverse Add Mode Word Abbrev -;;; Define a mode expansion for the word before point. - -(defcommand "Inverse Add Mode Word Abbrev" (p) - "Defines a mode word abbrev expansion for the word before the point." - "Defines a mode word abbrev expansion for the word before the point." - (declare (ignore p)) - (let ((word (prev-word 1 (current-point))) - (mode (buffer-major-mode (current-buffer)))) - (make-word-abbrev-command nil word nil mode))) - - -;;; C-X C-A Add Mode Word Abbrev -;;; Define mode abbrev for word before point. - -(defcommand "Add Mode Word Abbrev" (p) - "Defines a mode word abbrev for the word before the point. - With a positive argument, uses that many preceding words as the expansion. - With a zero argument, uses the region as the expansion. With a negative - argument, prompts for a word abbrev to delete in the current mode." - "Defines or deletes a mode word abbrev." - (if (and p (minusp p)) - (delete-mode-word-abbrev-command nil) - (let* ((val (if (eql p 0) - (region-to-string (current-region nil)) - (prev-word (or p 1) (current-point)))) - (mode (buffer-major-mode (current-buffer)))) - (make-word-abbrev-command nil nil val mode)))) - - - -;;; C-X - Inverse Add Global Word Abbrev -;;; Define global expansion for word before point. - -(defcommand "Inverse Add Global Word Abbrev" (p) - "Defines a Global expansion for the word before point." - "Defines a Global expansion for the word before point." - (declare (ignore p)) - (let ((word (prev-word 1 (current-point)))) - (make-word-abbrev-command nil word nil "Global"))) - - - -;;; C-X + Add Global Word Abbrev -;;; Define global Abbrev for word before point. - -(defcommand "Add Global Word Abbrev" (p) - "Defines a global word abbrev for the word before the point. - With a positive argument, uses that many preceding words as the expansion. - With a zero argument, uses the region as the expansion. With a negative - argument, prompts for a global word abbrev to delete." - "Defines or deletes a global word abbrev." - (if (and p (minusp p)) - (delete-global-word-abbrev-command nil) - (let ((val (if (eql p 0) - (region-to-string (current-region nil)) - (prev-word (or p 1) (current-point))))) - (make-word-abbrev-command nil nil val "Global")))) - - -;;;; Defining Abbrevs - -;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc. - -(defvar *global-abbrev-string-table* - (make-string-table :initial-contents '(("Global" . nil)))) - -(defcommand "Make Word Abbrev" (p &optional abbrev expansion mode) - "Defines an arbitrary word abbreviation. - Prompts for abbrev, expansion, and mode." - "Makes Abbrev be a word abbreviation for Expansion when in Mode. If - mode is \"Global\" then make a global abbrev." - (declare (ignore p)) - (unless mode - (setq mode - (prompt-for-keyword - (list *mode-names* *global-abbrev-string-table*) - :prompt "Mode of abbrev to add: " - :default "Global" - :help - "Type the mode of the Abbrev you want to add, or confirm for Global."))) - (let ((globalp (string-equal mode "Global"))) - (unless (or globalp (mode-major-p mode)) - (editor-error "~A is not a major mode." mode)) - (unless abbrev - (setq abbrev - (prompt-for-string - :trim t - :prompt - (list "~A abbreviation~@[ of ~S~]: " mode expansion) - :help - (list "Define a ~A word abbrev." mode)))) - (when (zerop (length abbrev)) - (editor-error "Abbreviation must be at least one character long.")) - (unless (every #'(lambda (ch) - (zerop (character-attribute :word-delimiter ch))) - (the simple-string abbrev)) - (editor-error "Word Abbrevs must be a single word.")) - (unless expansion - (setq expansion - (prompt-for-string - :prompt (list "~A expansion for ~S: " mode abbrev) - :help (list "Define the ~A expansion of ~S." mode abbrev)))) - (setq abbrev (string-downcase abbrev)) - (let* ((table (cond (globalp *global-abbrev-table*) - ((hemlock-bound-p 'Mode-Abbrev-Table :mode mode) - (variable-value 'Mode-Abbrev-Table :mode mode)) - (t - (let ((new (make-hash-table :test #'equal))) - (defhvar "Mode Abbrev Table" - "Hash Table of Mode Abbrevs" - :value new :mode mode) - new)))) - (old (gethash abbrev table))) - (when (or (not old) - (prompt-for-y-or-n - :prompt - (list "Current ~A definition of ~S is ~S.~%Redefine?" - mode abbrev old) - :default t - :help (list "Redefine the expansion of ~S." abbrev))) - (setf (gethash abbrev table) expansion) - (push (list abbrev expansion (if globalp nil mode)) - *new-abbrevs*))))) - - -;;; Alt Space Abbrev Expand Only -;;; Expand abbrev without inserting anything. - -(defcommand "Abbrev Expand Only" (p) - "This command expands the word before point into its abbrev definition - (if indeed it has one)." - "This command expands the word before point into its abbrev definition - (if indeed it has one)." - (declare (ignore p)) - (let* ((word (prev-word 1 (current-point))) - (glob (gethash (string-downcase word) *global-abbrev-table*)) - (mode (if (hemlock-bound-p 'Mode-Abbrev-Table) - (gethash (string-downcase word) - (value Mode-Abbrev-Table)))) - (end-word (reverse-find-attribute (copy-mark (current-point) - :right-inserting) - :word-delimiter #'zerop)) - (result (if mode mode glob))) - (when (or mode glob) - (delete-characters end-word (- (length word))) - (cond ((equal word (string-capitalize word)) - (setq result (string-capitalize result))) - ((equal word (string-upcase word)) - (setq result (string-upcase result)))) - (insert-string end-word result) - (unless (hemlock-bound-p 'last-expanded) - (defhvar "last expanded" - "Holds a mark, the last expanded abbrev, and its expansion in a list." - :buffer (current-buffer))) - (setf (value last-expanded) - (list (copy-mark (current-point) :right-inserting) - word result))) - (delete-mark end-word)) - (when (and (hemlock-bound-p 'prefix-mark) - (value prefix-mark)) - (delete-characters (value prefix-mark) 1) - (delete-mark (value prefix-mark)) - (setf (value prefix-mark) nil))) - - - -;;; This function returns the n words immediately before the mark supplied. - -(defun prev-word (n mark) - (let* ((mark-1 (reverse-find-attribute (copy-mark mark :temporary) - :word-delimiter #'zerop)) - (mark-2 (copy-mark mark-1))) - (dotimes (x n (region-to-string (region mark-2 mark-1))) - (reverse-find-attribute (mark-before mark-2) :word-delimiter)))) - - - -;;; M-' Word Abbrev Prefix Mark -;;; Mark a prefix to be glued to an abbrev following. - -;;; When "Abbrev Expand Only" expands the abbrev (because #\- is an expander) -;;; it will see that prefix-mark is non-nil, and will delete the #\- immediately -;;; after prefix-mark. - -(defcommand "Word Abbrev Prefix Mark" (p) - "Marks a prefix to be glued to an abbrev following." - "Marks a prefix to be glued to an abbrev following." - (declare (ignore p)) - (unless (hemlock-bound-p 'prefix-mark) - (defhvar "prefix mark" - "Holds a mark (or not) pointing to the current Prefix Mark." - :buffer (current-buffer))) - (when (value prefix-mark) - (delete-mark (value prefix-mark))) - (setf (value prefix-mark) (copy-mark (current-point) :right-inserting)) - (insert-character (value prefix-mark) #\-)) - - -;;; C-X U Unexpand Last Word -;;; Unexpands last abbrev or undoes last C-X U. - -(defcommand "Unexpand Last Word" (p) - "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\". - Only one abbrev may be undone." - "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\"." - (declare (ignore p)) - (unless (or (not (hemlock-bound-p 'last-expanded)) - (value last-expanded)) - (editor-error "Nothing to Undo.")) - (let ((mark (car (value last-expanded))) - (word1 (second (value last-expanded))) - (word2 (third (value last-expanded)))) - (unless (string= word2 - (region-to-string - (region (character-offset (copy-mark mark :temporary) - (- (length word2))) - mark))) - (editor-error "The last expanded Abbrev has been altered in the text.")) - (delete-characters mark (- (length word2))) - (insert-string mark word1) - (character-offset mark (length word1)) - (setf (value last-expanded) (list mark word2 word1)))) - - - -;;; Delete Mode Word Abbrev Kills some Mode abbrevs. - -(defcommand "Delete Mode Word Abbrev" - (p &optional abbrev - (mode (buffer-major-mode (current-buffer)))) - "Prompts for a word abbrev and deletes the mode expansion in the current mode. - If called with a prefix argument, deletes all word abbrevs define in the - current mode." - "Deletes Abbrev in Mode, or all abbrevs in Mode if P is true." - (let ((boundp (hemlock-bound-p 'Mode-Abbrev-Table :mode mode))) - (if p - (when boundp - (delete-variable 'Mode-Abbrev-Table :mode mode)) - (let ((down - (string-downcase - (or abbrev - (prompt-for-string - :prompt (list "~A abbrev to delete: " mode) - :help - (list "Give the name of a ~A mode word abbrev to delete." mode) - :trim t)))) - (table (and boundp (variable-value 'mode-abbrev-table :mode mode)))) - (unless (and table (gethash down table)) - (editor-error "~S is not the name of an abbrev in ~A mode." - down mode)) - (remhash down table))))) - - -;;; Delete Global Word Abbrevs Kills some Global abbrevs. - -(defcommand "Delete Global Word Abbrev" (p &optional abbrev) - "Prompts for a word abbrev and delete the global expansion. - If called with a prefix argument, deletes all global abbrevs." - "Deletes the global word abbreviation named Abbrev. If P is true, - deletes all global abbrevs." - (declare (ignore p)) - (if p - (setq *global-abbrev-table* (make-hash-table :test #'equal)) - (let ((down - (string-downcase - (or abbrev - (prompt-for-string - :prompt "Global abbrev to delete: " - :help "Give the name of a global word abbrev to delete." - :trim t))))) - (unless (gethash down *global-abbrev-table*) - (editor-error "~S is not the name of a global word abbrev." down)) - (remhash down *global-abbrev-table*)))) - -;;; Delete All Word Abbrevs Wipes them all. - -(defcommand "Delete All Word Abbrevs" (p) - "Deletes all currently defined Word Abbrevs" - "Deletes all currently defined Word Abbrevs" - (declare (ignore p)) - (Delete-Global-Word-Abbrev-Command 1) - (Delete-Mode-Word-Abbrev-Command 1)) - - -;;;; Abbrev I/O - -;;; List Word Abbrevs Shows definitions of all word abbrevs. - -(defcommand "List Word Abbrevs" (p) - "Lists all of the currently defined Word Abbrevs." - "Lists all of the currently defined Word Abbrevs." - (word-abbrev-apropos-command p "")) - - -;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev, -;;; definition, or mode. - -(defcommand "Word Abbrev Apropos" (p &optional search-string) - "Lists all of the currently defined Word Abbrevs which contain a given string - in their abbrev. definition, or mode." - "Lists all of the currently defined Word Abbrevs which contain a given string - in their abbrev. definition, or mode." - (declare (ignore p)) - (unless search-string - (setq search-string - (string-downcase - (prompt-for-string - :prompt "Apropos string: " - :help "The string to search word abbrevs and definitions for.")))) - (multiple-value-bind (count mode-tables) (count-abbrevs) - (with-pop-up-display (s :height (min (1+ count) 30)) - (unless (zerop (hash-table-count *global-abbrev-table*)) - (maphash #'(lambda (key val) - (when (or (search search-string (string-downcase key)) - (search search-string (string-downcase val))) - (write-abbrev key val nil s t))) - *global-abbrev-table*)) - (dolist (modename mode-tables) - (let ((table (variable-value 'Mode-Abbrev-Table :mode modename))) - (if (search search-string (string-downcase modename)) - (maphash #'(lambda (key val) - (write-abbrev key val modename s t)) - table) - (maphash #'(lambda (key val) - (when (or (search search-string (string-downcase key)) - (search search-string (string-downcase val))) - (write-abbrev key val modename s t))) - table)))) - (terpri s)))) - - - -(defun count-abbrevs () - (let* ((count (hash-table-count *global-abbrev-table*)) - (mode-tables nil)) - (do-strings (which x *mode-names*) - (declare (ignore x)) - (when (hemlock-bound-p 'Mode-Abbrev-Table :mode which) - (let ((table-count (hash-table-count (variable-value 'Mode-Abbrev-Table - :mode which)))) - (unless (zerop table-count) - (incf count table-count) - (push which mode-tables))))) - (values count mode-tables))) - - -;;; Edit Word Abbrevs Lets you edit the definition list directly. - -(defcommand "Edit Word Abbrevs" (p) - "Allows direct editing of currently defined Word Abbrevs." - "Allows direct editing of currently defined Word Abbrevs." - (declare (ignore p)) - (when (getstring "Edit Word Abbrevs" *buffer-names*) - (delete-buffer (getstring "Edit Word Abbrevs" *buffer-names*))) - (let ((old-buf (current-buffer)) - (new-buf (make-buffer "Edit Word Abbrevs"))) - (change-to-buffer new-buf) - (unwind-protect - (progn - (insert-word-abbrevs-command nil) - (do-recursive-edit) - (unless (equal #\newline (previous-character (buffer-end (current-point)))) - (insert-character (current-point) #\newline)) - (delete-all-word-abbrevs-command nil) - (define-word-abbrevs-command nil)) - (progn - (change-to-buffer old-buf) - (delete-buffer new-buf))))) - - - -;;; Insert Word Abbrevs Inserts a list of current definitions in the -;;; format that Define Word Abbrevs uses. - -(defcommand "Insert Word Abbrevs" (p) - "Inserts into the current buffer a list of all currently defined abbrevs in the - format used by \"Define Word Abbrevs\"." - "Inserts into the current buffer a list of all currently defined abbrevs in the - format used by \"Define Word Abbrevs\"." - - (declare (ignore p)) - (multiple-value-bind (x mode-tables) - (count-abbrevs) - (declare (ignore x)) - (with-output-to-mark (stream (current-point) :full) - (maphash #'(lambda (key val) - (write-abbrev key val nil stream)) - *global-abbrev-table*) - - (dolist (mode mode-tables) - (let ((modename (if (listp mode) (car mode) mode))) - (maphash #'(lambda (key val) - (write-abbrev key val modename stream)) - (variable-value 'Mode-Abbrev-Table :mode modename))))))) - - - -;;; Define Word Abbrevs Defines set of abbrevs from a definition list in -;;; the buffer. - -(defcommand "Define Word Abbrevs" (p) - "Defines Word Abbrevs from the definition list in the current buffer. The - definition list must be in the format produced by \"Insert Word Abbrevs\"." - "Defines Word Abbrevs from the definition list in the current buffer. The - definition list must be in the format produced by \"Insert Word Abbrevs\"." - - (declare (ignore p)) - (with-input-from-region (file (buffer-region (current-buffer))) - (read-abbrevs file))) - - -;;; Read Word Abbrev file <filename> Define word abbrevs from a definition file. - -;;; Ignores all lines less than 4 characters, i.e. blankspace or errors. That is -;;; the minimum number of characters possible to define an abbrev. It thinks the -;;; current abbrev "wraps" if there is no #\" at the end of the line or there are -;;; two #\"s at the end of the line (unless that is the entire definition string, -;;; i.e, a null-abbrev). - -;;; The format of the Abbrev files is -;;; -;;; ABBREV<tab><tab>"ABBREV DEFINITION" -;;; -;;; for Global Abbrevs, and -;;; -;;; ABBREV<tab>(MODE)<tab>"ABBREV DEFINITION" -;;; -;;; for Modal Abbrevs. -;;; Double-quotes contained within the abbrev definition are doubled. If the first -;;; line of an abbrev definition is not closed by a single double-quote, then -;;; the subsequent lines are read in until a single double-quote is found. - -(defcommand "Read Word Abbrev File" (p &optional filename) - "Reads in a file of previously defined abbrev definitions." - "Reads in a file of previously defined abbrev definitions." - (declare (ignore p)) - (setf (value abbrev-pathname-defaults) - (if filename - filename - (prompt-for-file - :prompt "Name of abbrev file: " - :help "The name of the abbrev file to load." - :default (value abbrev-pathname-defaults) - :must-exist nil))) - (with-open-file (file (value abbrev-pathname-defaults) :direction :input - :element-type 'string-char :if-does-not-exist :error) - (read-abbrevs file))) - - -;;; Does the actual defining of abbrevs from a given stream, expecting tabs and -;;; doubled double-quotes. - -(defun read-abbrevs (file) - (do ((line (read-line file nil nil) - (read-line file nil nil))) - ((null line)) - (unless (< (length line) 4) - (let* ((tab (position #\tab line)) - (tab2 (position #\tab line :start (1+ tab))) - (abbrev (subseq line 0 tab)) - (modename (subseq line (1+ tab) tab2)) - (expansion (do* ((last (1+ (position #\" line)) - (if found (min len (1+ found)) 0)) - (len (length line)) - (found (if (position #\" line :start last) - (1+ (position #\" line :start last))) - (if (position #\" line :start last) - (1+ (position #\" line :start last)))) - (expansion (subseq line last (if found found len)) - (concatenate 'simple-string expansion - (subseq line last - (if found found - len))))) - ((and (or (null found) (= found len)) - (equal #\" (char line (1- len))) - (or (not (equal #\" (char line (- len 2)))) - (= (- len 3) tab2))) - (subseq expansion 0 (1- (length expansion)))) - - (when (null found) - (setq line (read-line file nil nil) - last 0 - len (length line) - found (if (position #\" line) - (1+ (position #\" line))) - expansion (format nil "~A~%~A" expansion - (subseq line 0 (if found - found - 0)))))))) - - (cond ((equal modename "") - (setf (gethash abbrev *global-abbrev-table*) - expansion)) - (t (setq modename (subseq modename 1 (1- (length modename)))) - (unless (hemlock-bound-p 'Mode-Abbrev-Table - :mode modename) - (defhvar "Mode Abbrev Table" - "Hash Table of Mode Abbrevs" - :value (make-hash-table :test #'equal) - :mode modename)) - (setf (gethash abbrev (variable-value - 'Mode-Abbrev-Table :mode modename)) - expansion))))))) - - -;;; Write Word Abbrev File Make a definition file from current abbrevs. - -(defcommand "Write Word Abbrev File" (p &optional filename) - "Saves the currently defined Abbrevs to a file." - "Saves the currently defined Abbrevs to a file." - (declare (ignore p)) - (unless filename - (setq filename - (prompt-for-file - :prompt "Write abbrevs to file: " - :default (value abbrev-pathname-defaults) - :help "Name of the file to write current abbrevs to." - :must-exist nil))) - (with-open-file (file filename :direction :output - :element-type 'string-char :if-exists :supersede - :if-does-not-exist :create) - (multiple-value-bind (x mode-tables) (count-abbrevs) - (declare (ignore x)) - (maphash #'(lambda (key val) - (write-abbrev key val nil file)) - *global-abbrev-table*) - - (dolist (modename mode-tables) - (let ((mode (if (listp modename) (car modename) modename))) - (maphash #'(lambda (key val) - (write-abbrev key val mode file)) - (variable-value 'Mode-Abbrev-Table :mode mode)))))) - (let ((tn (truename filename))) - (setf (value abbrev-pathname-defaults) tn) - (message "~A written." (namestring tn)))) - - - -;;; Append to Word Abbrev File Appends to a file changed abbrev -;;; definitions since last dumping. - -(defcommand "Append to Word Abbrev File" (p &optional filename) - "Appends Abbrevs defined or redefined since the last save to a file." - "Appends Abbrevs defined or redefined since the last save to a file." - (declare (ignore p)) - (cond - (*new-abbrevs* - (unless filename - (setq filename - (prompt-for-file - :prompt - "Append incremental abbrevs to file: " - :default (value abbrev-pathname-defaults) - :must-exist nil - :help "Filename to append recently defined Abbrevs to."))) - (write-incremental :append filename)) - (t - (message "No Abbrev definitions have been changed since the last write.")))) - - -(defun write-incremental (mode filename) - (with-open-file (file filename :direction :output :element-type 'string-char - :if-exists mode :if-does-not-exist :create) - (dolist (def *new-abbrevs*) - (let ((abb (car def)) - (val (second def)) - (mode (third def))) - (write-abbrev abb val mode file)))) - (let ((tn (truename filename))) - (setq *new-abbrevs* nil) - (setf (value abbrev-pathname-defaults) tn) - (message "~A written." (namestring tn)))) - - -;;; Given an Abbrev, expansion, mode (nil for Global), and stream, this function -;;; writes to the stream with doubled double-quotes and stuff. -;;; If the flag is true, then the output is in a pretty format (like "List Word -;;; Abbrevs" uses), otherwise output is in tabbed format (like "Write Word -;;; Abbrev File" uses). - -(defun write-abbrev (abbrev expansion modename file &optional flag) - (if flag - (if modename - (format file "~5t~A~20t(~A)~35t\"" abbrev modename); pretty format - (format file "~5t~A~35t\"" abbrev)) ; pretty format - (cond (modename - (write-string abbrev file) - (write-char #\tab file) - (format file "(~A)" modename) ; "~A<tab>(~A)<tab>\"" - (write-char #\tab file) - (write-char #\" file)) - (t - (write-string abbrev file) - (write-char #\tab file) ; "~A<tab><tab>\"" - (write-char #\tab file) - (write-char #\" file)))) - (do* ((prev 0 found) - (found (position #\" expansion) - (position #\" expansion :start found))) - ((not found) - (write-string expansion file :start prev) - (write-char #\" file) - (terpri file)) - (incf found) - (write-string expansion file :start prev :end found) - (write-char #\" file))) - - -(defcommand "Abbrev Mode" (p) - "Put current buffer in Abbrev mode." - "Put current buffer in Abbrev mode." - (declare (ignore p)) - (setf (buffer-minor-mode (current-buffer) "Abbrev") - (not (buffer-minor-mode (current-buffer) "Abbrev")))) diff --git a/hemlock/auto-save.lisp b/hemlock/auto-save.lisp deleted file mode 100644 index b7d731f7189865a7a56293b565482702ff0342e2..0000000000000000000000000000000000000000 --- a/hemlock/auto-save.lisp +++ /dev/null @@ -1,393 +0,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.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. -;;; you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CS.CMU.EDU). -;;; ********************************************************************** -;;; -;;; Auto-Save Mode -;;; Written by Christopher Hoover -;;; - -(in-package 'hemlock) - - -;;;; Per Buffer State Information - -;;; -;;; The auto-save-state structure is used to store the state information for -;;; a particular buffer in "Save" mode, namely the buffer-signature at the last -;;; key stroke, the buffer-signature at the time of the last checkpoint, a count -;;; of the number of destructive keystrokes which have occured since the time of -;;; the last checkpoint, and the pathname used to write the last checkpoint. It -;;; is generally kept in a buffer-local hvar called "Auto Save State". -;;; -(defstruct (auto-save-state - (:conc-name save-state-) - (:print-function print-auto-save-state)) - "Per buffer state for auto-save" - (buffer nil) ; buffer this state is for; for printing - (key-signature :type fixnum) ; buffer-signature at last keystroke - (last-ckp-signature 0 :type fixnum) ; buffer-signature at last checkpoint - (key-count 0 :type fixnum) ; # destructive keystrokes since ckp - (pathname nil)) ; pathname used to write last ckp file - -(defun print-auto-save-state (auto-save-state stream depth) - (declare (ignore depth)) - (format stream "#<Auto Save Buffer State for buffer ~A>" - (buffer-name (save-state-buffer auto-save-state)))) - - -;;; GET-AUTO-SAVE-STATE tries to get the auto-save-state for the buffer. If -;;; the buffer is not in "Save" mode then this function returns NIL. -;;; -(defun get-auto-save-state (buffer) - (if (hemlock-bound-p 'auto-save-state :buffer buffer) - (variable-value 'auto-save-state :buffer buffer))) - -;;; RESET-AUTO-SAVE-STATE resets the auto-save-state of the buffer making it -;;; look as if the buffer was just checkpointed. This is in fact how -;;; checkpoint-buffer updates the state. If the buffer is not in "Save" mode -;;; this function punts the attempt and does nothing. -;;; -(defun reset-auto-save-state (buffer) - (let ((state (get-auto-save-state buffer))) - (when state - (let ((signature (buffer-signature buffer))) - (setf (save-state-key-signature state) - signature) - (setf (save-state-last-ckp-signature state) - signature) - (setf (save-state-key-count state) - 0))))) - - - -;;;; Checkpoint Pathname Interface/Internal Routines - -;;; GET-CHECKPOINT-PATHNAME -- Interface -;;; -;;; Returns the pathname of the checkpoint file for the specified -;;; buffer; Returns NIL if no checkpoints have been written thus -;;; far or if the buffer isn't in "Save" mode. -;;; -(defun get-checkpoint-pathname (buffer) - "Returns the pathname of the checkpoint file for the specified buffer. - If no checkpoints have been written thus far, or if the buffer is not in - \"Save\" mode, return nil." - (let ((state (get-auto-save-state buffer))) - (if state - (save-state-pathname state)))) - -;;; MAKE-UNIQUE-SAVE-PATHNAME is used as the default value for "Auto Save -;;; Pathname Hook" and is mentioned in the User's manual, so it gets a doc -;;; doc string. -;;; -(defun make-unique-save-pathname (buffer) - "Returns a pathname for a non-existing file in DEFAULT-DIRECTORY. Uses - GENSYM to for a file name: save-GENSYM.CKP." - (declare (ignore buffer)) - (let ((def-dir (default-directory))) - (loop - (let* ((sym (gensym)) - (f (merge-pathnames (format nil "save-~A.CKP" sym) def-dir))) - (unless (probe-file f) - (return f)))))) - -(defhvar "Auto Save Pathname Hook" - "This hook is called by Auto Save to get a checkpoint pathname when there - is no pathname associated with a buffer. If this value is NIL, then - \"Save\" mode is turned off in the buffer. Otherwise, the function - will be called. It should take a buffer as its argument and return either - NIL or a pathname. If NIL is returned, then \"Save\" mode is turned off - in the buffer; else the pathname returned is used as the checkpoint - pathname for the buffer." - :value #'make-unique-save-pathname) - - -;;; MAKE-BUFFER-CKP-PATHNAME attempts to form a pathname by using the buffer's -;;; associated pathname (from buffer-pathname). If there isn't a pathname -;;; associated with the buffer, the function returns nil. Otherwise, it uses -;;; the "Auto Save Filename Pattern" and FORMAT to make the checkpoint -;;; pathname. -;;; -(defun make-buffer-ckp-pathname (buffer) - (let ((buffer-pn (buffer-pathname buffer))) - (if buffer-pn - (pathname (format nil - (value auto-save-filename-pattern) - (directory-namestring buffer-pn) - (file-namestring buffer-pn)))))) - - - -;;;; Buffer-level Checkpoint Routines - -;;; -;;; write-checkpoint-file -- Internal -;;; -;;; Does the low-level write of the checkpoint. Returns T if it succeeds -;;; and NIL if it fails. Echoes winnage or lossage to the luser. -;;; -(defun write-checkpoint-file (pathname buffer) - (let ((ns (namestring pathname))) - (cond ((file-writable pathname) - (message "Saving ~A" ns) - (handler-case (progn - (write-file (buffer-region buffer) pathname - :keep-backup nil - :access #o600) ;read/write by owner. - t) - (error (condition) - (loud-message "Auto Save failure: ~A" condition) - nil))) - (t - (message "Can't write ~A" ns) - nil)))) - - -;;; -;;; To save, or not to save... and to save as what? -;;; -;;; First, make-buffer-ckp-pathname is called. It will return either NIL or -;;; a pathname formed by using buffer-pathname in conjunction with the hvar -;;; "Auto Save Filename Pattern". If there isn't an associated pathname or -;;; make-buffer-ckp-pathname returns NIL, then we use the pathname we used -;;; the last time we checkpointed the buffer. If we've never checkpointed -;;; the buffer, then we check "Auto Save Pathname Hook". If it is NIL then -;;; we turn Save mode off for the buffer, else we funcall the function on -;;; the hook with the buffer as an argument. The function on the hook should -;;; return either NIL or a pathname. If it returns NIL, we toggle Save mode -;;; off for the buffer; otherwise, we use the pathname it returned. -;;; - -;;; -;;; checkpoint-buffer -- Internal -;;; -;;; This functions takes a buffer as its argument and attempts to write a -;;; checkpoint for that buffer. See the notes at the beginning of this page -;;; for how it determines what pathname to use as the checkpoint pathname. -;;; Note that a checkpoint is not necessarily written -- instead "Save" -;;; mode may be turned off for the buffer. -;;; -(defun checkpoint-buffer (buffer) - (let* ((state (get-auto-save-state buffer)) - (buffer-ckp-pn (make-buffer-ckp-pathname buffer)) - (last-pathname (save-state-pathname state))) - (cond (buffer-ckp-pn - (when (write-checkpoint-file buffer-ckp-pn buffer) - (reset-auto-save-state buffer) - (setf (save-state-pathname state) buffer-ckp-pn) - (when (and last-pathname - (not (equal last-pathname buffer-ckp-pn)) - (probe-file last-pathname)) - (delete-file last-pathname)))) - (last-pathname - (when (write-checkpoint-file last-pathname buffer) - (reset-auto-save-state buffer))) - (t - (let* ((save-pn-hook (value auto-save-pathname-hook)) - (new-pn (if save-pn-hook - (funcall save-pn-hook buffer)))) - (cond ((or (not new-pn) - (zerop (length - (the simple-string (namestring new-pn))))) - (setf (buffer-minor-mode buffer "Save") nil)) - (t - (when (write-checkpoint-file new-pn buffer) - (reset-auto-save-state buffer) - (setf (save-state-pathname state) new-pn))))))))) - -;;; -;;; checkpoint-all-buffers -- Internal -;;; -;;; This function looks through the buffer list and checkpoints -;;; each buffer that is in "Save" mode that has been modified since -;;; its last checkpoint. -;;; -(defun checkpoint-all-buffers (elapsed-time) - (declare (ignore elapsed-time)) - (dolist (buffer *buffer-list*) - (let ((state (get-auto-save-state buffer))) - (when (and state - (buffer-modified buffer) - (not (eql - (save-state-last-ckp-signature state) - (buffer-signature buffer)))) - (checkpoint-buffer buffer))))) - - -;;;; Random Hooks: cleanup, buffer-modified, change-save-freq. - -;;; -;;; cleanup-checkpoint -- Internal -;;; -;;; Cleans up checkpoint file for a given buffer if Auto Save Cleanup -;;; Checkpoints is non-NIL. This is called via "Write File Hook" -;;; -(defun cleanup-checkpoint (buffer) - (let ((ckp-pathname (get-checkpoint-pathname buffer))) - (when (and (value auto-save-cleanup-checkpoints) - ckp-pathname - (probe-file ckp-pathname)) - (delete-file ckp-pathname)))) - -(add-hook write-file-hook 'cleanup-checkpoint) - -;;; -;;; notice-buffer-modified -- Internal -;;; -;;; This function is called on "Buffer Modified Hook" to reset -;;; the Auto Save state. It makes the buffer look like it has just -;;; been checkpointed. -;;; -(defun notice-buffer-modified (buffer flag) - ;; we care only when the flag has gone to false - (when (not flag) - (reset-auto-save-state buffer))) - -(add-hook buffer-modified-hook 'notice-buffer-modified) - -;;; -;;; change-save-frequency -- Internal -;;; -;;; This keeps us scheduled at the proper interval. It is stuck on -;;; the hook list for the hvar "Auto Save Checkpoint Frequency" and -;;; is therefore called whenever this value is set. -;;; -(defun change-save-frequency (name kind where new-value) - (declare (ignore name kind where)) - (setq new-value (truncate new-value)) - (remove-scheduled-event 'checkpoint-all-buffers) - (when (and new-value - (plusp new-value)) - (schedule-event new-value 'checkpoint-all-buffers t))) - - -;;; "Save" mode is in "Default Modes", so turn it off in these modes. -;;; - -(defun interactive-modes (buffer on) - (when on (setf (buffer-minor-mode buffer "Save") nil))) - -(add-hook typescript-mode-hook 'interactive-modes) -(add-hook eval-mode-hook 'interactive-modes) - - - -;;;; Key Count Routine for Input Hook - -;;; -;;; auto-save-count-keys -- Internal -;;; -;;; This function sits on the Input Hook to eat cycles. If the current -;;; buffer is not in Save mode or if the current buffer is the echo area -;;; buffer, it does nothing. Otherwise, we check to see if we have exceeded -;;; the key count threshold (and write a checkpoint if we have) and we -;;; increment the key count for the buffer. -;;; -(defun auto-save-count-keys () - (declare (optimize speed)) - (let ((buffer (current-buffer))) - (unless (eq buffer *echo-area-buffer*) - (let ((state (value auto-save-state)) - (threshold (value auto-save-key-count-threshold))) - (when (and state threshold) - (let ((signature (buffer-signature buffer))) - (declare (fixnum signature)) - (when (not (eql signature - (save-state-key-signature state))) - ;; see if we exceeded threshold last time... - (when (>= (save-state-key-count state) - (the fixnum threshold)) - (checkpoint-buffer buffer)) - ;; update state - (setf (save-state-key-signature state) signature) - (incf (save-state-key-count state))))))))) - -(add-hook input-hook 'auto-save-count-keys) - - -;;;; Save Mode Hemlock Variables - -;;; -;;; Hemlock variables/parameters for Auto-Save Mode -;;; - -(defhvar "Auto Save Filename Pattern" - "This control-string is used with format to make the filename of the - checkpoint file. Format is called with two arguments, the first - being the directory namestring and the second being the file - namestring of the default buffer pathname." - :value "~A~A.CKP") - -(defhvar "Auto Save Key Count Threshold" - "This value is the number of destructive/modifying keystrokes that will - automatically trigger an checkpoint. This value may be NIL to turn this - feature off." - :value 256) - -(defhvar "Auto Save Cleanup Checkpoints" - "This variable controls whether or not \"Save\" mode will delete the - checkpoint file for a buffer after it is saved. If this value is - non-NIL then cleanup will occur." - :value t) - -(defhvar "Auto Save Checkpoint Frequency" - "All modified buffers (in \"Save\" mode) will be checkpointed after this - amount of time (in seconds). This value may be NIL (or non-positive) - to turn this feature off." - :value (* 2 60) - :hooks '(change-save-frequency)) - -(defhvar "Auto Save State" - "Shadow magic. This variable is seen when in buffers that are not - in \"Save\" mode. Do not change this value or you will lose." - :value nil) - - -;;;; "Save" mode - -(defcommand "Auto Save Mode" (p) - "If the argument is zero or negative, turn \"Save\" mode off. If it - is positive turn \"Save\" mode on. If there is no argument, toggle - \"Save\" mode in the current buffer. When in \"Save\" mode, files - are automatically checkpointed every \"Auto Save Checkpoint Frequency\" - seconds or every \"Auto Save Key Count Threshold\" destructive - keystrokes. If there is a pathname associated with the buffer, the - filename used for the checkpoint file is controlled by the hvar \"Auto - Save Filename Pattern\". Otherwise, the hook \"Auto Save Pathname Hook\" - is used to generate a checkpoint pathname. If the buffer's pathname - changes between checkpoints, the checkpoint file will be written under - the new name and the old checkpoint file will be deleted if it exists. - When a buffer is written out, the checkpoint will be deleted if the - hvar \"Auto Save Cleanup Checkpoints\" is non-NIL." - "Turn on, turn off, or toggle \"Save\" mode in the current buffer." - (setf (buffer-minor-mode (current-buffer) "Save") - (if p - (plusp p) - (not (buffer-minor-mode (current-buffer) "Save"))))) - -(defun setup-auto-save-mode (buffer) - (let* ((signature (buffer-signature buffer)) - (state (make-auto-save-state - :buffer buffer - :key-signature (the fixnum signature) - :last-ckp-signature (the fixnum signature)))) - ;; shadow the global value with a variable which will - ;; contain our per buffer state information - (defhvar "Auto Save State" - "This is the \"Save\" mode state information for this buffer." - :buffer buffer - :value state))) - -(defun cleanup-auto-save-mode (buffer) - (delete-variable 'auto-save-state - :buffer buffer)) - -(defmode "Save" - :setup-function 'setup-auto-save-mode - :cleanup-function 'cleanup-auto-save-mode) diff --git a/hemlock/bindings.lisp b/hemlock/bindings.lisp deleted file mode 100644 index 4a0e723009ccec5a3243a9aa3d9df5e560ac1074..0000000000000000000000000000000000000000 --- a/hemlock/bindings.lisp +++ /dev/null @@ -1,849 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Some bindings: -;;; -(in-package 'hemlock) - - - -;;;; Default key translations: - -;;; This page first maps all uppercase characters with all modifier bit -;;; combinations to the equivalent lowercase letter. This saves many -;;; duplicated BIND-KEY forms and tends to support what users expect out of a -;;; BIND-KEY call. -;;; -;;; Secondly, this page defines prefix characters that set specified modifier -;;; bits on the next character typed. -;;; - -;;; Case insensitivize: -;;; -(defun case-insensitivize (bits) - "Make key translations from all the lowercase characters with specified bits - to the corresponding uppercase characters." - (do-alpha-chars (lower :lower) - (setf (key-translation (make-char (char-upcase lower) bits)) - (make-char lower bits)))) - -(case-insensitivize 0) -(case-insensitivize 1) -(case-insensitivize 2) -(case-insensitivize 3) - -(case-insensitivize 8) -(case-insensitivize 9) -(case-insensitivize 10) -(case-insensitivize 11) - - -;;; Prefix characters: -;;; -(setf (key-translation #\escape) '(:bits :meta)) -(setf (key-translation #\control-z) '(:bits :control :meta)) -(setf (key-translation #\control-\z) '(:bits :control :meta)) -(setf (key-translation #\control-^) '(:bits :control)) -(setf (key-translation #\control-c) '(:bits :hyper)) -(setf (key-translation #\control-\c) '(:bits :hyper)) - - - -;;;; Void some key translations. - -;;; This page kills some key translations so we can make use of case sensitive -;;; bindings. These translations must be voided for each modifier bit -;;; combination we are interested in. Characters with nil translations, used -;;; in bindings for which the translation is desired, must be bound to both the -;;; lower and upper case characters separately. For examples, see "Delete Next -;;; Character" and "Previous Undeleted Message". -;;; - -(setf (key-translation #\control-meta-s) nil) -(setf (key-translation #\control-meta-a) nil) -(setf (key-translation #\control-meta-v) nil) -(setf (key-translation #\control-meta-f) nil) -(setf (key-translation #\control-meta-l) nil) -(setf (key-translation #\control-meta-c) nil) - -(setf (key-translation #\control-d) nil) -(setf (key-translation #\control-m) nil) - -(setf (key-translation #\meta-p) nil) - -(setf (key-translation #\D) nil) -(setf (key-translation #\U) nil) -(setf (key-translation #\R) nil) -(setf (key-translation #\C) nil) - - - -;;;; Most every binding. - -;;; Self insert letters: -;;; -(do-alpha-chars (upper :upper) - (bind-key "Self Insert" upper)) - -;;; Add these lowercase letters since we killed the uppercase translations -;;; on the previous page. -;;; -(bind-key "Self Insert" #\d) -(bind-key "Self Insert" #\u) -(bind-key "Self Insert" #\r) -(bind-key "Self Insert" #\c) - - -(bind-key "Beginning of Line" #\control-a) -(bind-key "Delete Next Character" #\control-\d) -(bind-key "Delete Next Character" #\control-d) -(bind-key "End of Line" #\control-e) -(bind-key "Forward Character" #\control-f) -(bind-key "Forward Character" #\rightarrow) -(bind-key "Backward Character" #\control-b) -(bind-key "Backward Character" #\leftarrow) -(bind-key "Kill Line" #\control-k) -(bind-key "Refresh Screen" #\control-l) -(bind-key "Next Line" #\control-n) -(bind-key "Next Line" #\downarrow) -(bind-key "Previous Line" #\control-p) -(bind-key "Previous Line" #\uparrow) -(bind-key "Query Replace" #\meta-%) -(bind-key "Reverse Incremental Search" #\control-r) -(bind-key "Incremental Search" #\control-s) -(bind-key "Forward Search" #\meta-s) -(bind-key "Reverse Search" #\meta-r) -(bind-key "Transpose Characters" #\control-t) -(bind-key "Universal Argument" #\control-u) -(bind-key "Scroll Window Down" #\control-v) -(bind-key "Scroll Window Up" #\meta-v) -(bind-key "Scroll Next Window Down" #\control-meta-\v) - -(bind-key "Scroll Next Window Up" #\control-meta-V) - -(bind-key "Help" #\home) -(bind-key "Help" #\control-_) -(bind-key "Describe Key" #\meta-?) - - -(bind-key "Here to Top of Window" #\leftdown) -(bind-key "Do Nothing" #\leftup) -(bind-key "Top Line to Here" #\rightdown) -(bind-key "Do Nothing" #\rightup) -(bind-key "Point to Here" #\middledown) -(bind-key "Point to Here" #\super-leftdown) -(bind-key "Generic Pointer Up" #\middleup) -(bind-key "Generic Pointer Up" #\super-leftup) -(bind-key "Do Nothing" #\super-rightup) -(bind-key "Insert Kill Buffer" #\super-rightdown) - - -(bind-key "Insert File" '#(#\control-x #\control-r)) -(bind-key "Save File" '#(#\control-x #\control-s)) -(bind-key "Visit File" '#(#\control-x #\control-v)) -(bind-key "Write File" '#(#\control-x #\control-w)) -(bind-key "Find File" '#(#\control-x #\control-f)) -(bind-key "Backup File" '#(#\control-x #\meta-b)) -(bind-key "Save All Files" '#(#\control-x #\control-\m)) -(bind-key "Save All Files" '#(#\control-x #\control-m)) -(bind-key "Save All Files" '#(#\control-x #\return)) -(bind-key "Save All Files and Exit" '#(#\control-x #\meta-z)) - -(bind-key "List Buffers" '#(#\control-x #\control-b)) -(bind-key "Buffer Not Modified" #\meta-~) -(bind-key "Check Buffer Modified" '#(#\control-x #\~)) -(bind-key "Select Buffer" '#(#\control-x #\b)) -(bind-key "Select Previous Buffer" #\control-meta-\l) -(bind-key "Circulate Buffers" #\control-meta-l) -(bind-key "Create Buffer" '#(#\control-x #\meta-b)) -(bind-key "Kill Buffer" '#(#\control-x #\k)) -(bind-key "Select Random Typeout Buffer" #\hyper-t) - -(bind-key "Next Window" '#(#\control-x #\n)) -(bind-key "Next Window" '#(#\control-x #\o)) -(bind-key "Previous Window" '#(#\control-x #\p)) -(bind-key "Split Window" '#(#\control-x #\2)) -(bind-key "New Window" '#(#\control-x #\control-n)) -(bind-key "Delete Window" '#(#\control-x #\d)) -(bind-key "Delete Window" '#(#\control-x #\D)) -(bind-key "Delete Next Window" '#(#\control-x #\1)) -(bind-key "Line to Top of Window" #\meta-!) -(bind-key "Line to Center of Window" #\meta-\#) -(bind-key "Top of Window" #\meta-\,) -(bind-key "Bottom of Window" #\meta-\.) - -(bind-key "Exit Hemlock" '#(#\control-x #\control-z)) -(bind-key "Exit Hemlock" '#(#\control-x #\control-\z)) -(bind-key "Exit Recursive Edit" #\control-meta-z) -(bind-key "Abort Recursive Edit" #\control-]) - -(bind-key "Delete Previous Character" #\Delete) -(bind-key "Delete Previous Character" #\Backspace) -(bind-key "Kill Next Word" #\meta-d) -(bind-key "Kill Previous Word" #\meta-delete) -(bind-key "Kill Previous Word" #\meta-backspace) -(bind-key "Exchange Point and Mark" '#(#\control-x #\control-x)) -(bind-key "Mark Whole Buffer" '#(#\control-x #\h)) -(bind-key "Set/Pop Mark" #\control-@) -(bind-key "Set/Pop Mark" #\control-space) -(bind-key "Pop and Goto Mark" #\meta-space) -(bind-key "Pop and Goto Mark" #\meta-@) -(bind-key "Pop Mark" #\control-meta-space) ;#\c-m-@ is "Mark Form". -(bind-key "Kill Region" #\control-w) -(bind-key "Save Region" #\meta-w) -(bind-key "Un-Kill" #\control-y) -(bind-key "Rotate Kill Ring" #\meta-y) - -(bind-key "Forward Word" #\meta-f) -(bind-key "Backward Word" #\meta-b) - -(bind-key "Forward Paragraph" #\meta-]) -(bind-key "Forward Sentence" #\meta-e) -(bind-key "Backward Paragraph" #\meta-[) -(bind-key "Backward Sentence" #\meta-a) - -(bind-key "Mark Paragraph" #\meta-h) - -(bind-key "Forward Kill Sentence" #\meta-k) -(bind-key "Backward Kill Sentence" '#(#\control-x #\delete)) -(bind-key "Backward Kill Sentence" '#(#\control-x #\backspace)) - -(bind-key "Beginning of Buffer" #\meta-<) -(bind-key "End of Buffer" #\meta->) -(bind-key "Mark to Beginning of Buffer" #\control-<) -(bind-key "Mark to End of Buffer" #\control->) - -(bind-key "Extended Command" #\meta-x) - -(bind-key "Uppercase Word" '#\meta-u) -(bind-key "Lowercase Word" '#\meta-l) -(bind-key "Capitalize Word" '#\meta-c) - -(bind-key "Previous Page" '#(#\control-x #\[)) -(bind-key "Next Page" '#(#\control-x #\])) -(bind-key "Mark Page" '#(#\control-x #\control-p)) -(bind-key "Count Lines Page" '#(#\control-x #\l)) - - - -;;;; Argument Digit and Negative Argument. - -(bind-key "Negative Argument" #\meta--) -(bind-key "Argument Digit" #\meta-0) -(bind-key "Argument Digit" #\meta-1) -(bind-key "Argument Digit" #\meta-2) -(bind-key "Argument Digit" #\meta-3) -(bind-key "Argument Digit" #\meta-4) -(bind-key "Argument Digit" #\meta-5) -(bind-key "Argument Digit" #\meta-6) -(bind-key "Argument Digit" #\meta-7) -(bind-key "Argument Digit" #\meta-8) -(bind-key "Argument Digit" #\meta-9) -(bind-key "Negative Argument" #\control--) -(bind-key "Argument Digit" #\control-0) -(bind-key "Argument Digit" #\control-1) -(bind-key "Argument Digit" #\control-2) -(bind-key "Argument Digit" #\control-3) -(bind-key "Argument Digit" #\control-4) -(bind-key "Argument Digit" #\control-5) -(bind-key "Argument Digit" #\control-6) -(bind-key "Argument Digit" #\control-7) -(bind-key "Argument Digit" #\control-8) -(bind-key "Argument Digit" #\control-9) -(bind-key "Negative Argument" #\control-meta--) -(bind-key "Argument Digit" #\control-meta-0) -(bind-key "Argument Digit" #\control-meta-1) -(bind-key "Argument Digit" #\control-meta-2) -(bind-key "Argument Digit" #\control-meta-3) -(bind-key "Argument Digit" #\control-meta-4) -(bind-key "Argument Digit" #\control-meta-5) -(bind-key "Argument Digit" #\control-meta-6) -(bind-key "Argument Digit" #\control-meta-7) -(bind-key "Argument Digit" #\control-meta-8) -(bind-key "Argument Digit" #\control-meta-9) - - -;;;; Self Insert and Quoted Insert. - -(bind-key "Quoted Insert" #\control-q) - -(bind-key "Self Insert" " ") -(bind-key "Self Insert" "!") -(bind-key "Self Insert" "@") -(bind-key "Self Insert" "#") -(bind-key "Self Insert" "$") -(bind-key "Self Insert" "%") -(bind-key "Self Insert" "^") -(bind-key "Self Insert" "&") -(bind-key "Self Insert" "*") -(bind-key "Self Insert" "(") -(bind-key "Self Insert" ")") -(bind-key "Self Insert" "_") -(bind-key "Self Insert" "+") -(bind-key "Self Insert" "~") -(bind-key "Self Insert" "1") -(bind-key "Self Insert" "2") -(bind-key "Self Insert" "3") -(bind-key "Self Insert" "4") -(bind-key "Self Insert" "5") -(bind-key "Self Insert" "6") -(bind-key "Self Insert" "7") -(bind-key "Self Insert" "8") -(bind-key "Self Insert" "9") -(bind-key "Self Insert" "0") -(bind-key "Self Insert" "[") -(bind-key "Self Insert" "]") -(bind-key "Self Insert" "\\") -(bind-key "Self Insert" "|") -(bind-key "Self Insert" ":") -(bind-key "Self Insert" ";") -(bind-key "Self Insert" "\"") -(bind-key "Self Insert" "'") -(bind-key "Self Insert" "-") -(bind-key "Self Insert" "=") -(bind-key "Self Insert" "`") -(bind-key "Self Insert" "<") -(bind-key "Self Insert" ">") -(bind-key "Self Insert" ",") -(bind-key "Self Insert" ".") -(bind-key "Self Insert" "?") -(bind-key "Self Insert" "/") -(bind-key "Self Insert" "{") -(bind-key "Self Insert" "}") - - - -;;;; Echo Area. - -;;; Basic echo-area commands. -;;; -(bind-key "Help on Parse" #\home :mode "Echo Area") -(bind-key "Help on Parse" #\control-_ :mode "Echo Area") - -(bind-key "Complete Keyword" #\escape :mode "Echo Area") -(bind-key "Complete Field" #\space :mode "Echo Area") -(bind-key "Confirm Parse" #\return :mode "Echo Area") - -;;; Rebind some standard commands to behave better. -;;; -(bind-key "Kill Parse" #\control-u :mode "Echo Area") -(bind-key "Insert Parse Default" #\control-i :mode "Echo Area") -(bind-key "Insert Parse Default" #\tab :mode "Echo Area") -(bind-key "Echo Area Delete Previous Character" #\delete :mode "Echo Area") -(bind-key "Echo Area Delete Previous Character" #\backspace :mode "Echo Area") -(bind-key "Echo Area Kill Previous Word" #\meta-h :mode "Echo Area") -(bind-key "Echo Area Kill Previous Word" #\meta-delete :mode "Echo Area") -(bind-key "Echo Area Kill Previous Word" #\meta-backspace :mode "Echo Area") -(bind-key "Echo Area Kill Previous Word" #\control-w :mode "Echo Area") -(bind-key "Beginning of Parse" #\control-a :mode "Echo Area") -(bind-key "Beginning of Parse" #\meta-< :mode "Echo Area") -(bind-key "Echo Area Backward Character" #\control-b :mode "Echo Area") -(bind-key "Echo Area Backward Word" #\meta-b :mode "Echo Area") -(bind-key "Next Parse" #\control-n :mode "Echo Area") -(bind-key "Previous Parse" #\control-p :mode "Echo Area") - -;;; Nuke some dangerous standard bindings. -;;; -(bind-key "Illegal" #\control-x :mode "Echo Area") -(bind-key "Illegal" #\control-meta-c :mode "Echo Area") -(bind-key "Illegal" #\control-meta-\c :mode "Echo Area") -(bind-key "Illegal" #\control-meta-l :mode "Echo Area") -(bind-key "Illegal" #\control-meta-\l :mode "Echo Area") -(bind-key "Illegal" #\meta-x :mode "Echo Area") -(bind-key "Illegal" #\control-s :mode "Echo Area") -(bind-key "Illegal" #\control-r :mode "Echo Area") -(bind-key "Illegal" #\middledown :mode "Echo Area") -(bind-key "Do Nothing" #\middleup :mode "Echo Area") -(bind-key "Illegal" #\super-leftdown :mode "Echo Area") -(bind-key "Do Nothing" #\super-leftup :mode "Echo Area") -(bind-key "Illegal" #\super-rightdown :mode "Echo Area") -(bind-key "Do Nothing" #\super-rightup :mode "Echo Area") - - - -;;;; Eval and Editor Modes. - -(bind-key "Confirm Eval Input" #\return :mode "Eval") -(bind-key "Previous Interactive Input" #\meta-\p :mode "Eval") -(bind-key "Search Previous Interactive Input" #\meta-p :mode "Eval") -(bind-key "Next Interactive Input" #\meta-n :mode "Eval") -(bind-key "Kill Interactive Input" #\meta-i :mode "Eval") -(bind-key "Abort Eval Input" #\control-meta-i :mode "Eval") -(bind-key "Interactive Beginning of Line" #\control-a :mode "Eval") -(bind-key "Reenter Interactive Input" #\control-return :mode "Eval") - -(bind-key "Editor Evaluate Expression" #\control-meta-escape) -(bind-key "Editor Evaluate Expression" #\meta-escape :mode "Editor") -(bind-key "Editor Evaluate Defun" '#(#\control-x #\control-e) :mode "Editor") -(bind-key "Editor Compile Defun" '#(#\control-x #\control-c) :mode "Editor") -(bind-key "Editor Compile Defun" '#(#\control-x #\control-\c) :mode "Editor") -(bind-key "Editor Macroexpand Expression" #\control-M :mode "Editor") -(bind-key "Editor Describe Function Call" #\control-meta-A :mode "Editor") -(bind-key "Editor Describe Symbol" #\control-meta-S :mode "Editor") - - - -;;;; Typescript. - -(bind-key "Confirm Typescript Input" #\return :mode "Typescript") -(bind-key "Interactive Beginning of Line" #\control-a :mode "Typescript") -(bind-key "Kill Interactive Input" #\meta-i :mode "Typescript") -;(bind-key "Abort Typescript Input" #\control-meta-i :mode "Typescript") -(bind-key "Previous Interactive Input" #\meta-\p :mode "Typescript") -(bind-key "Search Previous Interactive Input" #\meta-p :mode "Typescript") -(bind-key "Next Interactive Input" #\meta-n :mode "Typescript") -(bind-key "Reenter Interactive Input" #\control-return :mode "Typescript") -(bind-key "Typescript Slave Break" #\hyper-b :mode "Typescript") -(bind-key "Typescript Slave to Top Level" #\hyper-g :mode "Typescript") -(bind-key "Select Slave" #\control-meta-\c) -(bind-key "Select Background" #\control-meta-C) - -(bind-key "Abort Operations" #\hyper-a) -(bind-key "List Operations" #\hyper-l) - -(bind-key "Next Compiler Error" #\hyper-n) -(bind-key "Previous Compiler Error" #\hyper-p) - - - -;;;; Lisp (some). - -(bind-key "Indent Form" #\control-meta-q) -(bind-key "Defindent" #\control-meta-\#) -(bind-key "Beginning of Defun" #\control-meta-[) -(bind-key "End of Defun" #\control-meta-]) -(bind-key "Beginning of Defun" #\control-meta-\a) -(bind-key "End of Defun" #\control-meta-e) -(bind-key "Forward Form" #\control-meta-\f) -(bind-key "Backward Form" #\control-meta-b) -(bind-key "Forward List" #\control-meta-n) -(bind-key "Backward List" #\control-meta-p) -(bind-key "Transpose Forms" #\control-meta-t) -(bind-key "Forward Kill Form" #\control-meta-k) -(bind-key "Backward Kill Form" #\control-meta-backspace) -(bind-key "Backward Kill Form" #\control-meta-delete) -(bind-key "Mark Form" #\control-meta-@) -(bind-key "Mark Defun" #\control-meta-h) -(bind-key "Insert ()" #\meta-\() -(bind-key "Move over )" #\meta-\)) -(bind-key "Backward Up List" #\control-meta-\() -(bind-key "Backward Up List" #\control-meta-u) -(bind-key "Forward Up List" #\control-meta-\)) -(bind-key "Down List" #\control-meta-d) -(bind-key "Extract List" #\control-meta-x) -(bind-key "Lisp Insert )" #\) :mode "Lisp") -(bind-key "Delete Previous Character Expanding Tabs" #\backspace :mode "Lisp") -(bind-key "Delete Previous Character Expanding Tabs" #\delete :mode "Lisp") - -(bind-key "Evaluate Expression" #\meta-escape) -(bind-key "Evaluate Defun" '#(#\control-x #\control-e)) -(bind-key "Compile Defun" '#(#\control-x #\control-c)) -(bind-key "Compile Defun" '#(#\control-x #\control-\c)) -(bind-key "Compile Buffer File" '#(#\control-x #\c)) -(bind-key "Compile Buffer File" '#(#\control-x #\C)) -(bind-key "Macroexpand Expression" #\control-M) - -(bind-key "Describe Function Call" #\control-meta-A) -(bind-key "Describe Symbol" #\control-meta-S) - -(bind-key "Goto Definition" #\control-meta-F) - - - -;;;; More Miscellaneous bindings. - -(bind-key "Open Line" #\Control-O) -(bind-key "New Line" #\return) - -(bind-key "Transpose Words" #\meta-t) -(bind-key "Transpose Lines" '#(#\control-x #\control-t)) -(bind-key "Transpose Regions" '#(#\control-x #\t)) - -(bind-key "Uppercase Region" '#(#\control-x #\control-u)) -(bind-key "Lowercase Region" '#(#\control-x #\control-l)) - -(bind-key "Delete Indentation" #\meta-^) -(bind-key "Delete Indentation" #\control-meta-^) -(bind-key "Delete Horizontal Space" #\meta-\\) -(bind-key "Delete Blank Lines" '#(#\control-x #\control-o) :global) -(bind-key "Just One Space" #\meta-\|) -(bind-key "Back to Indentation" #\meta-m) -(bind-key "Back to Indentation" #\control-meta-m) -(bind-key "Indent Rigidly" '#(#\control-x #\tab)) -(bind-key "Indent Rigidly" '#(#\control-x #\control-i)) - -(bind-key "Indent New Line" #\linefeed) -(bind-key "Indent" #\tab) -(bind-key "Indent" #\control-i) -(bind-key "Indent Region" #\control-meta-\\) -(bind-key "Quote Tab" #\meta-tab) - -(bind-key "Directory" '#(#\control-x #\control-\d)) -(bind-key "Verbose Directory" '#(#\control-x #\control-D)) - -(bind-key "Activate Region" '#(#\control-x #\control-@)) -(bind-key "Activate Region" '#(#\control-x #\control-space)) - -(bind-key "Save Position" '#(#\control-x #\s)) -(bind-key "Jump to Saved Position" '#(#\control-x #\j)) -(bind-key "Put Register" '#(#\control-x #\x)) -(bind-key "Get Register" '#(#\control-x #\g)) - -(bind-key "Delete Previous Character Expanding Tabs" #\backspace :mode "Pascal") -(bind-key "Delete Previous Character Expanding Tabs" #\delete :mode "Pascal") -(bind-key "Scribe Insert Bracket" #\) :mode "Pascal") -(bind-key "Scribe Insert Bracket" #\] :mode "Pascal") -(bind-key "Scribe Insert Bracket" #\} :mode "Pascal") - - -;;;; Auto Fill Mode. - -(bind-key "Fill Paragraph" #\meta-q) -(bind-key "Fill Region" #\meta-g) -(bind-key "Set Fill Prefix" '#(#\control-x #\.)) -(bind-key "Set Fill Column" '#(#\control-x #\f)) -(bind-key "Auto Fill Return" #\return :mode "Fill") -(bind-key "Auto Fill Space" #\space :mode "Fill") -(bind-key "Auto Fill Linefeed" #\linefeed :mode "Fill") - - - -;;;; Keyboard macro bindings. - -(bind-key "Define Keyboard Macro" '#(#\control-x #\()) -(bind-key "Define Keyboard Macro Key" '#(#\control-x #\meta-\()) -(bind-key "End Keyboard Macro" '#(#\control-x #\))) -(bind-key "End Keyboard Macro" '#(#\control-x #\hyper-\))) -(bind-key "Last Keyboard Macro" '#(#\control-x #\e)) -(bind-key "Keyboard Macro Query" '#(#\control-x #\q)) - - - -;;;; Spell bindings. - -(bind-key "Check Word Spelling" #\meta-$) -(bind-key "Add Word to Spelling Dictionary" '#(#\control-x #\$)) - -(dolist (c (command-bindings (getstring "Self Insert" *command-names*))) - (let ((ch (svref (car c) 0))) - (unless (or (alpha-char-p ch) (char= ch #\')) - (bind-key "Auto Check Word Spelling" (car c) :mode "Spell")))) -(bind-key "Auto Check Word Spelling" #\return :mode "Spell") -(bind-key "Auto Check Word Spelling" #\tab :mode "Spell") -(bind-key "Auto Check Word Spelling" #\linefeed :mode "Spell") -(bind-key "Correct Last Misspelled Word" #\meta-\:) -(bind-key "Undo Last Spelling Correction" '#(#\control-x #\a)) - - - -;;;; Overwrite Mode. - -(bind-key "Overwrite Delete Previous Character" #\delete :mode "Overwrite") -(bind-key "Overwrite Delete Previous Character" #\backspace :mode "Overwrite") - -;;; do up the printing characters ... -(do* ((i 33 (1+ i)) - (char (code-char i) (code-char i))) - ((= i 126)) - (bind-key "Self Overwrite" char :mode "Overwrite")) - -(bind-key "Self Overwrite" #\space :mode "Overwrite") - - - -;;;; Comment bindings. - -(bind-key "Indent for Comment" #\meta-\;) -(bind-key "Set Comment Column" '#(#\control-x #\;)) -(bind-key "Kill Comment" #\control-meta-\;) -(bind-key "Down Comment Line" #\meta-n) -(bind-key "Up Comment Line" #\meta-p) -(bind-key "Up Comment Line" #\meta-\p) -(bind-key "Indent New Comment Line" #\meta-j) -(bind-key "Indent New Comment Line" #\meta-linefeed) - - -;;;; Word Abbrev Mode. - -(bind-key "Add Mode Word Abbrev" '#(#\Control-X #\Control-A)) -(bind-key "Add Global Word Abbrev" '#(#\Control-X #\+)) -(bind-key "Inverse Add Mode Word Abbrev" '#(#\Control-X #\Control-H)) -(bind-key "Inverse Add Global Word Abbrev" '#(#\Control-X #\-)) -;; Removed in lieu of "Pop and Goto Mark". -;;(bind-key "Abbrev Expand Only" #\meta-space) -(bind-key "Word Abbrev Prefix Mark" #\meta-\") -(bind-key "Unexpand Last Word" '#(#\Control-X #\u)) -(bind-key "Unexpand Last Word" '#(#\Control-X #\U)) - -(dolist (x '(#\! #\~ #\@ #\# #\; #\$ #\% #\^ #\& #\* #\- #\_ #\= #\+ #\[ #\] - #\( #\) #\/ #\| #\: #\' #\" #\{ #\} #\, #\< #\. #\> #\` #\\ #\? - #\return #\newline #\tab #\space)) - (bind-key "Abbrev Expand Only" x :mode "Abbrev")) - - - -;;;; Scribe Mode. - -(dolist (ch '(#\] #\) #\} #\>)) - (bind-key "Scribe Insert Bracket" ch :mode "Scribe")) - -(bind-key "Scribe Buffer File" '#(#\control-x #\c) :mode "Scribe") -(bind-key "Scribe Buffer File" '#(#\control-x #\C) :mode "Scribe") -(bind-key "Select Scribe Warnings" #\control-meta-C :mode "Scribe") - -(bind-key "Insert Scribe Directive" #\hyper-i :mode "Scribe") - - - -;;;; X commands: - -(bind-key "Insert Cut Buffer" #\insert) -(bind-key "Region to Cut Buffer" #\meta-insert) - - - -;;;; Mailer commands. - -(do-alpha-chars (c :both) - (bind-key "Illegal" c :mode "Headers") - (bind-key "Illegal" c :mode "Message")) - - -;;; Global. - -(bind-key "Incorporate and Read New Mail" '#(#\control-x #\i)) -(bind-key "Send Message" '#(#\control-x #\m)) -(bind-key "Message Headers" '#(#\control-x #\r)) -(bind-key "Message Headers" '#(#\control-x #\R)) - - -;;; Both Headers and Message modes. -;;; -;;; The bindings in these two blocks should be the same, one for "Message" mode -;;; and one for "Headers" mode. -;;; - -(bind-key "Next Message" #\meta-n :mode "Message") -(bind-key "Previous Message" #\meta-p :mode "Message") -(bind-key "Previous Message" #\meta-\p :mode "Message") -(bind-key "Next Undeleted Message" #\n :mode "Message") -(bind-key "Previous Undeleted Message" #\p :mode "Message") -(bind-key "Send Message" #\s :mode "Message") -(bind-key "Send Message" #\m :mode "Message") -(bind-key "Forward Message" #\f :mode "Message") -(bind-key "Headers Delete Message" #\k :mode "Message") -(bind-key "Headers Undelete Message" #\u :mode "Message") -(bind-key "Headers Undelete Message" #\U :mode "Message") -(bind-key "Headers Refile Message" #\o :mode "Message") -(bind-key "List Mail Buffers" #\l :mode "Message") -(bind-key "Quit Headers" #\q :mode "Message") -(bind-key "Incorporate and Read New Mail" #\i :mode "Message") -(bind-key "Beginning of Buffer" #\< :mode "Message") -(bind-key "End of Buffer" #\> :mode "Message") - -(bind-key "Next Message" #\meta-n :mode "Headers") -(bind-key "Previous Message" #\meta-p :mode "Headers") -(bind-key "Previous Message" #\meta-\p :mode "Headers") -(bind-key "Next Undeleted Message" #\n :mode "Headers") -(bind-key "Previous Undeleted Message" #\p :mode "Headers") -(bind-key "Send Message" #\s :mode "Headers") -(bind-key "Send Message" #\m :mode "Headers") -(bind-key "Forward Message" #\f :mode "Headers") -(bind-key "Headers Delete Message" #\k :mode "Headers") -(bind-key "Headers Undelete Message" #\u :mode "Headers") -(bind-key "Headers Undelete Message" #\U :mode "Headers") -(bind-key "Headers Refile Message" #\o :mode "Headers") -(bind-key "List Mail Buffers" #\l :mode "Headers") -(bind-key "Quit Headers" #\q :mode "Headers") -(bind-key "Incorporate and Read New Mail" #\i :mode "Headers") -(bind-key "Beginning of Buffer" #\< :mode "Headers") -(bind-key "End of Buffer" #\> :mode "Headers") - - -;;; Headers mode. - -(bind-key "Delete Message and Down Line" #\d :mode "Headers") -(bind-key "Delete Message and Down Line" #\D :mode "Headers") -(bind-key "Pick Headers" #\h :mode "Headers") -(bind-key "Show Message" #\space :mode "Headers") -(bind-key "Show Message" #\. :mode "Headers") -(bind-key "Reply to Message" #\r :mode "Headers") -(bind-key "Reply to Message" #\R :mode "Headers") -(bind-key "Expunge Messages" #\! :mode "Headers") -(bind-key "Headers Help" #\? :mode "Headers") - - -;;; Message mode. - -(bind-key "Delete Message and Show Next" #\d :mode "Message") -(bind-key "Delete Message and Show Next" #\D :mode "Message") -(bind-key "Goto Headers Buffer" #\^ :mode "Message") -(bind-key "Scroll Message" #\space :mode "Message") -(bind-key "Scroll Message" #\control-v :mode "Message") -(bind-key "Scroll Window Up" #\backspace :mode "Message") -(bind-key "Scroll Window Up" #\delete :mode "Message") -(bind-key "Reply to Message in Other Window" #\r :mode "Message") -(bind-key "Reply to Message in Other Window" #\R :mode "Message") -(bind-key "Edit Message Buffer" #\e :mode "Message") -(bind-key "Insert Message Region" #\hyper-y :mode "Message") -(bind-key "Message Help" #\? :mode "Message") - - -;;; Draft mode. - -(bind-key "Goto Headers Buffer" #\hyper-^ :mode "Draft") -(bind-key "Goto Message Buffer" #\hyper-m :mode "Draft") -(bind-key "Deliver Message" #\hyper-s :mode "Draft") -(bind-key "Deliver Message" #\hyper-c :mode "Draft") -(bind-key "Insert Message Buffer" #\hyper-y :mode "Draft") -(bind-key "Delete Draft and Buffer" #\hyper-q :mode "Draft") -(bind-key "List Mail Buffers" #\hyper-l :mode "Draft") -(bind-key "Draft Help" #\hyper-? :mode "Draft") - - - -;;;; Process (Shell). - -(bind-key "Confirm Process Input" #\return :mode "Process") -(bind-key "Shell" #\control-meta-\s) -(bind-key "Interrupt Buffer Subprocess" #\hyper-c :mode "Process") -(bind-key "Stop Buffer Subprocess" #\hyper-z :mode "Process") -(bind-key "Quit Buffer Subprocess" #\hyper-\\) -(bind-key "Send EOF to Process" #\hyper-d) - -(bind-key "Previous Interactive Input" #\meta-\p :mode "Process") -(bind-key "Search Previous Interactive Input" #\meta-P :mode "Process") -(bind-key "Interactive Beginning of Line" #\control-a :mode "Process") -(bind-key "Kill Interactive Input" #\meta-i :mode "Process") -(bind-key "Next Interactive Input" #\meta-n :mode "Process") -(bind-key "Reenter Interactive Input" #\control-return :mode "Process") - - - -;;;; Bufed. - -(bind-key "Bufed" '#(#\control-x #\control-meta-b)) -(bind-key "Bufed Delete" #\d :mode "Bufed") -(bind-key "Bufed Delete" #\D :mode "Bufed") -(bind-key "Bufed Delete" #\control-d :mode "Bufed") -(bind-key "Bufed Delete" #\control-\d :mode "Bufed") -(bind-key "Bufed Undelete" #\u :mode "Bufed") -(bind-key "Bufed Undelete" #\U :mode "Bufed") -(bind-key "Bufed Expunge" #\! :mode "Bufed") -(bind-key "Bufed Quit" #\q :mode "Bufed") -(bind-key "Bufed Goto" #\space :mode "Bufed") -(bind-key "Bufed Goto and Quit" #\super-leftdown :mode "Bufed") -(bind-key "Bufed Save File" #\s :mode "Bufed") -(bind-key "Next Line" #\n :mode "Bufed") -(bind-key "Previous Line" #\p :mode "Bufed") - - -(bind-key "Bufed Help" #\? :mode "Bufed") - - - -;;;; Dired. - -(bind-key "Dired" '#(#\control-x #\control-meta-\d)) - -(bind-key "Dired Delete File and Down Line" #\d :Mode "Dired") -(bind-key "Dired Delete File with Pattern" #\D :Mode "Dired") -(bind-key "Dired Delete File" #\control-\d :Mode "Dired") -(bind-key "Dired Delete File" #\control-d :Mode "Dired") -(bind-key "Dired Delete File" #\k :Mode "Dired") - -(bind-key "Dired Undelete File and Down Line" #\u :Mode "Dired") -(bind-key "Dired Undelete File with Pattern" #\U :Mode "Dired") -(bind-key "Dired Undelete File" #\control-u :Mode "Dired") - -(bind-key "Dired Expunge Files" #\! :Mode "Dired") -(bind-key "Dired Update Buffer" #\hyper-u :Mode "Dired") -(bind-key "Dired View File" #\space :Mode "Dired") -(bind-key "Dired Edit File" #\e :Mode "Dired") -(bind-key "Dired Quit" #\q :Mode "Dired") -(bind-key "Dired Help" #\? :Mode "Dired") - -(bind-key "Dired Copy File" #\c :Mode "Dired") -(bind-key "Dired Copy with Wildcard" #\C :Mode "Dired") -(bind-key "Dired Rename File" #\r :Mode "Dired") -(bind-key "Dired Rename with Wildcard" #\R :Mode "Dired") - -(bind-key "Next Line" #\n :mode "Dired") -(bind-key "Previous Line" #\p :mode "Dired") - - - -;;;; View Mode. - -(bind-key "View Scroll Down" #\space :mode "View") -(bind-key "Scroll Window Up" #\b :mode "View") -(bind-key "Scroll Window Up" #\backspace :Mode "View") -(bind-key "Scroll Window Up" #\delete :Mode "View") -(bind-key "View Return" #\^ :mode "View") -(bind-key "View Quit" #\q :mode "View") -(bind-key "View Edit File" #\e :mode "View") -(bind-key "View Help" #\? :mode "View") -(bind-key "Beginning of Buffer" #\< :Mode "View") -(bind-key "End of Buffer" #\> :Mode "View") - - - -;;;; Lisp Library. - - -(bind-key "Describe Pointer Library Entry" #\leftdown :Mode "Lisp-Lib") -(bind-key "Load Pointer Library Entry" #\rightdown :Mode "Lisp-Lib") -(bind-key "Describe Library Entry" #\space :Mode "Lisp-Lib") -(bind-key "Load Library Entry" #\l :Mode "Lisp-Lib") -(bind-key "Exit Lisp Library" #\q :Mode "Lisp-Lib") -(bind-key "Lisp Library Help" #\? :Mode "Lisp-Lib") - - - -;;;; Completion mode. - -(dolist (c (command-bindings (getstring "Self Insert" *command-names*))) - (bind-key "Completion Self Insert" (car c) :mode "Completion")) - -(bind-key "Completion Self Insert" #\Space :mode "Completion") -(bind-key "Completion Self Insert" #\Tab :mode "Completion") -(bind-key "Completion Self Insert" #\Return :mode "Completion") -(bind-key "Completion Self Insert" #\Linefeed :mode "Completion") - -(bind-key "Completion Complete Word" #\End) -(bind-key "Completion Rotate Completions" #\Meta-End) - - - -;;;; Logical characters. - -(setf (logical-char= #\control-s :forward-search) t) -(setf (logical-char= #\control-r :backward-search) t) -(setf (logical-char= #\control-r :recursive-edit) t) -(setf (logical-char= #\delete :cancel) t) -(setf (logical-char= #\backspace :cancel) t) -(setf (logical-char= #\control-g :abort) t) -(setf (logical-char= #\escape :exit) t) -(setf (logical-char= #\Y :yes) t) -(setf (logical-char= #\space :yes) t) -(setf (logical-char= #\N :no) t) -(setf (logical-char= #\backspace :no) t) -(setf (logical-char= #\delete :no) t) -(setf (logical-char= #\! :do-all) t) -(setf (logical-char= #\. :do-once) t) -(setf (logical-char= #\home :help) t) -(setf (logical-char= #\H :help) t) -(setf (logical-char= #\? :help) t) -(setf (logical-char= #\control-_ :help) t) -(setf (logical-char= #\return :confirm) t) -(setf (logical-char= #\control-q :quote) t) -(setf (logical-char= #\K :keep) t) - - diff --git a/hemlock/bit-display.lisp b/hemlock/bit-display.lisp deleted file mode 100644 index d17fe12b96f369dc5597c5cf55b884ec89ad1f0b..0000000000000000000000000000000000000000 --- a/hemlock/bit-display.lisp +++ /dev/null @@ -1,290 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; Modified by Bill Chiles to run under X on IBM RT's. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(redisplay redisplay-all)) - - - -;;; prepare-window-for-redisplay -- Internal -;;; -;;; Called by make-window to do whatever redisplay wants to set up -;;; a new window. -;;; -(defun prepare-window-for-redisplay (window) - (setf (window-old-lines window) 0)) - - - -;;;; Dumb window redisplay. - -;;; DUMB-WINDOW-REDISPLAY redraws an entire window using dumb-line-redisplay. -;;; This assumes the cursor has been lifted if necessary. -;;; -(defun dumb-window-redisplay (window) - (let* ((hunk (window-hunk window)) - (first (window-first-line window))) - (hunk-reset hunk) - (do ((i 0 (1+ i)) - (dl (cdr first) (cdr dl))) - ((eq dl the-sentinel) - (setf (window-old-lines window) (1- i))) - (dumb-line-redisplay hunk (car dl))) - (setf (window-first-changed window) the-sentinel - (window-last-changed window) first) - (when (window-modeline-buffer window) - (hunk-replace-modeline hunk) - (setf (dis-line-flags (window-modeline-dis-line window)) - unaltered-bits)) - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))))) - - -;;; DUMB-LINE-REDISPLAY is used when the line is known to be cleared already. -;;; -(defun dumb-line-redisplay (hunk dl) - (hunk-write-line hunk dl) - (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) - - - -;;;; Smart window redisplay. - -;;; We scan through the changed dis-lines, and condense the information -;;; obtained into five categories: Unchanged lines moved down, unchanged -;;; lines moved up, lines that need to be cleared, lines that are in the -;;; same place (but changed), and new or moved-and-changed lines to write. -;;; Each such instance of a thing that needs to be done is remembered be -;;; throwing needed information on a stack specific to the thing to be -;;; done. We cannot do any of these things right away because each may -;;; confict with the previous. -;;; -;;; Each stack is represented by a simple-vector big enough to hold the -;;; worst-case number of entries and a pointer to the next free entry. The -;;; pointers are local variables returned from COMPUTE-CHANGES and used by -;;; SMART-WINDOW-REDISPLAY. Note that the order specified in these tuples -;;; is the order in which they were pushed. -;;; -(defvar *display-down-move-stack* (make-array (* hunk-height-limit 2)) - "This is the vector that we stash info about which lines moved down in - as (Start, End, Count) triples.") -(defvar *display-up-move-stack* (make-array (* hunk-height-limit 2)) - "This is the vector that we stash info about which lines moved up in - as (Start, End, Count) triples.") -(defvar *display-erase-stack* (make-array hunk-height-limit) - "This is the vector that we stash info about which lines need to be erased - as (Start, Count) pairs.") -(defvar *display-write-stack* (make-array hunk-height-limit) - "This is the vector that we stash dis-lines in that need to be written.") -(defvar *display-rewrite-stack* (make-array hunk-height-limit) - "This is the vector that we stash dis-lines in that need to be written. - with clear-to-end.") - -;;; Accessor macros to push and pop on the stacks: -;;; -(eval-when (compile eval) - -(defmacro spush (thing stack stack-pointer) - `(progn - (setf (svref ,stack ,stack-pointer) ,thing) - (incf ,stack-pointer))) - -(defmacro spop (stack stack-pointer) - `(svref ,stack (decf ,stack-pointer))) - -(defmacro snext (stack stack-pointer) - `(prog1 (svref ,stack ,stack-pointer) (incf ,stack-pointer))) - -); eval-when (compile eval) - - -;;; SMART-WINDOW-REDISPLAY only re-writes lines which may have been changed, -;;; and updates them with smart-line-redisplay if not very much has changed. -;;; Lines which have moved are copied. We must be careful not to redisplay -;;; the window with the cursor down since it is not guaranteed to be out of -;;; the way just because we are in redisplay; LIFT-CURSOR is called just before -;;; the screen may be altered, and it takes care to know whether the cursor -;;; is lifted already or not. At the end, if the cursor had been down, -;;; DROP-CURSOR puts it back; it doesn't matter if LIFT-CURSOR was never called -;;; since it does nothing if the cursor is already down. -;;; -(defun smart-window-redisplay (window) - (let* ((hunk (window-hunk window)) - (liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))) - (when (bitmap-hunk-trashed hunk) - (when liftp (lift-cursor)) - (dumb-window-redisplay window) - (when liftp (drop-cursor)) - (return-from smart-window-redisplay nil)) - (let ((first-changed (window-first-changed window)) - (last-changed (window-last-changed window))) - ;; Is there anything to do? - (unless (eq first-changed the-sentinel) - (when liftp (lift-cursor)) - (if (and (eq first-changed last-changed) - (zerop (dis-line-delta (car first-changed)))) - ;; One line changed. - (smart-line-redisplay hunk (car first-changed)) - ;; More than one line changed. - (multiple-value-bind (up down erase write rewrite) - (compute-changes first-changed last-changed) - (do-down-moves hunk down) - (do-up-moves hunk up) - (do-erases hunk erase) - (do-writes hunk write) - (do-rewrites hunk rewrite))) - ;; Set the bounds so we know we displayed... - (setf (window-first-changed window) the-sentinel - (window-last-changed window) (window-first-line window)))) - ;; - ;; Clear any extra lines at the end of the window. - (let ((pos (dis-line-position (car (window-last-line window))))) - (when (< pos (window-old-lines window)) - (when liftp (lift-cursor)) - (hunk-clear-lines hunk (1+ pos) (- (window-height window) pos 1))) - (setf (window-old-lines window) pos)) - ;; - ;; Update the modeline if needed. - (when (window-modeline-buffer window) - (when (/= (dis-line-flags (window-modeline-dis-line window)) - unaltered-bits) - (hunk-replace-modeline hunk) - (setf (dis-line-flags (window-modeline-dis-line window)) - unaltered-bits))) - ;; - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) - (when liftp (drop-cursor)))) - -;;; COMPUTE-CHANGES is used once in smart-window-redisplay, and it scans -;;; through the changed dis-lines in a window, computes the changes needed -;;; to bring the screen into corespondence, and throws the information -;;; needed to do the change onto the apropriate stack. The pointers into -;;; the stacks (up, down, erase, write, and rewrite) are returned. -;;; -;;; The algorithm is as follows: -;;; 1] If the line is moved-and-changed or new then throw the line on -;;; the write stack and increment the clear count. Repeat until no more -;;; such lines are found. -;;; 2] If the line is moved then flush any pending clear, find how many -;;; consecutive lines are moved the same amount, and put the numbers -;;; on the correct move stack. -;;; 3] If the line is changed and unmoved throw it on a write stack. -;;; If a clear is pending throw it in the write stack and bump the clear -;;; count, otherwise throw it on the rewrite stack. -;;; 4] The line is unchanged, do nothing. -;;; -(defun compute-changes (first-changed last-changed) - (let* ((dl first-changed) - (flags (dis-line-flags (car dl))) - (up 0) (down 0) (erase 0) (write 0) (rewrite 0) ;return values. - (clear-count 0) - prev clear-start) - (declare (fixnum up down erase write rewrite clear-count)) - (loop - (cond - ;; Line moved-and-changed or new. - ((> flags moved-bit) - (when (zerop clear-count) - (setq clear-start (dis-line-position (car dl)))) - (loop - (setf (dis-line-delta (car dl)) 0) - (spush (car dl) *display-write-stack* write) - (incf clear-count) - (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))) - (when (<= flags moved-bit) (return nil)))) - ;; Line moved, unchanged. - ((= flags moved-bit) - (unless (zerop clear-count) - (spush clear-count *display-erase-stack* erase) - (spush clear-start *display-erase-stack* erase) - (setq clear-count 0)) - (do ((delta (dis-line-delta (car dl))) - (end (dis-line-position (car dl))) - (count 1 (1+ count))) - (()) - (setf (dis-line-delta (car dl)) 0 - (dis-line-flags (car dl)) unaltered-bits) - (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))) - (when (or (/= (dis-line-delta (car dl)) delta) (/= flags moved-bit)) - ;; We push in different order because we pop in different order. - (cond - ((minusp delta) - (spush (- end delta) *display-up-move-stack* up) - (spush end *display-up-move-stack* up) - (spush count *display-up-move-stack* up)) - (t - (spush count *display-down-move-stack* down) - (spush end *display-down-move-stack* down) - (spush (- end delta) *display-down-move-stack* down))) - (return nil)))) - ;; Line changed, unmoved. - ((= flags changed-bit) - (cond ((zerop clear-count) - (spush (car dl) *display-rewrite-stack* rewrite)) - (t - (spush (car dl) *display-write-stack* write) - (incf clear-count))) - (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl)))) - ;; Line unmoved, unchanged. - (t - (unless (zerop clear-count) - (spush clear-count *display-erase-stack* erase) - (spush clear-start *display-erase-stack* erase) - (setq clear-count 0)) - (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))))) - - (when (eq prev last-changed) - ;; If done flush any pending clear. - (unless (zerop clear-count) - (spush clear-count *display-erase-stack* erase) - (spush clear-start *display-erase-stack* erase)) - (return (values up down erase write rewrite)))))) - -(defun do-up-moves (hunk up) - (do ((i 0)) - ((= i up)) - (hunk-copy-lines hunk (snext *display-up-move-stack* i) - (snext *display-up-move-stack* i) - (snext *display-up-move-stack* i)))) - -(defun do-down-moves (hunk down) - (do () - ((zerop down)) - (hunk-copy-lines hunk (spop *display-down-move-stack* down) - (spop *display-down-move-stack* down) - (spop *display-down-move-stack* down)))) - -(defun do-erases (hunk erase) - (do () - ((zerop erase)) - (hunk-clear-lines hunk (spop *display-erase-stack* erase) - (spop *display-erase-stack* erase)))) - -(defun do-writes (hunk write) - (do ((i 0)) - ((= i write)) - (dumb-line-redisplay hunk (snext *display-write-stack* i)))) - -(defun do-rewrites (hunk rewrite) - (do () - ((zerop rewrite)) - (smart-line-redisplay hunk (spop *display-rewrite-stack* rewrite)))) - - -;;; SMART-LINE-REDISPLAY is called when the screen is mostly the same, -;;; clear to eol after we write it to avoid annoying flicker. -;;; -(defun smart-line-redisplay (hunk dl) - (hunk-replace-line hunk dl) - (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) diff --git a/hemlock/bit-screen.lisp b/hemlock/bit-screen.lisp deleted file mode 100644 index 715a39c603bc9e3a311b25bd3d1f27a9b0cb0bc3..0000000000000000000000000000000000000000 --- a/hemlock/bit-screen.lisp +++ /dev/null @@ -1,1667 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Screen allocation functions. -;;; -;;; This is the screen management and event handlers for Hemlock under X. -;;; -;;; Written by Bill Chiles, Rob MacLachlan, and Blaine Burks. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(make-window delete-window next-window previous-window - make-xwindow-like-hwindow *create-window-hook* *delete-window-hook* - *random-typeout-hook* *create-initial-windows-hook*)) - - -(proclaim '(special *echo-area-window*)) - -;;; This is the object set for Hemlock windows. All types of incoming -;;; X events on standard editing windows have the same handlers via this set. -;;; -(defvar *hemlock-windows* - (system:make-object-set "Hemlock Windows" #'ext:default-clx-event-handler)) - - - -;;;; Some window making parameters. - -;;; These could be parameters, but they have to be set after the display is -;;; opened. These are set in INIT-BITMAP-SCREEN-MANAGER. - -(defvar *default-background-pixel* nil - "Default background color. It defaults to white.") - -(defvar *default-foreground-pixel* nil - "Default foreground color. It defaults to black.") - -(defvar *foreground-background-xor* nil - "The LOGXOR of *default-background-pixel* and *default-foreground-pixel*.") - -(defvar *default-border-pixmap* nil - "This is the default color of X window borders. It defaults to a - grey pattern.") - -(defvar *highlight-border-pixmap* nil - "This is the color of the border of the current window when the mouse - cursor is over any Hemlock window.") - - - -;;;; Exposed region handling. - -;;; :exposure events are sent because we selected them. :graphics-exposure -;;; events are generated because of a slot in our graphics contexts. These are -;;; generated from using XLIB:COPY-AREA when the source could not be generated. -;;; Also, :no-exposure events are sent when a :graphics-exposure event could -;;; have been sent but wasn't. -;;; -#| -;;; This is an old handler that doesn't do anything clever about multiple -;;; exposures. -(defun hunk-exposed-region (hunk &key y height &allow-other-keys) - (if (bitmap-hunk-lock hunk) - (setf (bitmap-hunk-trashed hunk) t) - (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))) - (when liftp (lift-cursor)) - ;; (hunk-draw-top-border hunk) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-height (font-family-height font-family)) - (co (font-family-cursor-y-offset font-family)) - (start (truncate (- y hunk-top-border) font-height)) - (end (ceiling (- (+ y height) hunk-top-border) font-height)) - (start-bit (+ (* start font-height) co hunk-top-border)) - (nheight (- (* (- end start) font-height) co)) - (end-line (bitmap-hunk-end hunk))) - (declare (fixnum font-height co start end start-bit nheight)) - (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit - :width (bitmap-hunk-width hunk) :height nheight) - (do ((dl (bitmap-hunk-start hunk) (cdr dl)) - (i 0 (1+ i))) - ((or (eq dl end-line) (= i start)) - (do ((i i (1+ i)) - (dl dl (cdr dl))) - ((or (eq dl end-line) (= i end))) - (declare (fixnum i)) - (hunk-write-line hunk (car dl) i))) - (declare (fixnum i))) - (when (and (bitmap-hunk-modeline-pos hunk) - (>= (the fixnum (+ nheight start-bit)) - (the fixnum (bitmap-hunk-modeline-pos hunk)))) - (hunk-replace-modeline hunk))) - (when liftp (drop-cursor))))) -|# - -;;; HUNK-EXPOSED-REGION redisplays the appropriate rectangle from the hunk -;;; dis-lines. Don't do anything if the hunk is trashed since redisplay is -;;; probably about to fix everything; specifically, this keeps new windows -;;; from getting drawn twice (once for the exposure and once for being trashed). -;;; -;;; Exposure and graphics-exposure events pass in a different number of -;;; arguments, with some the same but in a different order, so we just bind -;;; and ignore foo, bar, baz, and quux. -;;; -(defun hunk-exposed-region (hunk event-key event-window x y width height - foo bar &optional baz quux) - (declare (ignore event-key event-window x width foo bar baz quux)) - (unless (bitmap-hunk-trashed hunk) - (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)) - (display (bitmap-device-display (device-hunk-device hunk)))) - (when liftp (lift-cursor)) - (multiple-value-bind (y-peek height-peek) - (exposed-region-peek-event display - (bitmap-hunk-xwindow hunk)) - (if y-peek - (let ((n (coelesce-exposed-regions hunk display - y height y-peek height-peek))) - (write-n-exposed-regions hunk n)) - (write-one-exposed-region hunk y height))) - (xlib:display-force-output display) - (when liftp (drop-cursor))))) -;;; -(ext:serve-exposure *hemlock-windows* #'hunk-exposed-region) -(ext:serve-graphics-exposure *hemlock-windows* #'hunk-exposed-region) - - -;;; HUNK-NO-EXPOSURE handles this bullshit event that gets sent without its -;;; being requested. -;;; -(defun hunk-no-exposure (hunk event-key event-window major minor send-event-p) - (declare (ignore hunk event-key event-window major minor send-event-p)) - t) -;;; -(ext:serve-no-exposure *hemlock-windows* #'hunk-no-exposure) - - -;;; EXPOSED-REGION-PEEK-EVENT returns the position and height of an :exposure -;;; or :graphics-exposure event on win if one exists. If there are none, then -;;; nil and nil are returned. -;;; -(defun exposed-region-peek-event (display win) - (xlib:display-finish-output display) - (let ((result-y nil) - (result-height nil)) - (xlib:process-event - display :timeout 0 - :handler #'(lambda (&key event-key event-window window y height - &allow-other-keys) - (cond ((and (or (eq event-key :exposure) - (eq event-key :graphics-exposure)) - (or (eq event-window win) (eq window win))) - (setf result-y y) - (setf result-height height) - t) - (t nil)))) - (values result-y result-height))) - -;;; COELESCE-EXPOSED-REGIONS insert sorts exposed region events from the X -;;; input queue into *coelesce-buffer*. Then the regions are merged into the -;;; same number or fewer regions that are vertically distinct -;;; (non-overlapping). When this function is called, one event has already -;;; been popped from the queue, the first event that caused HUNK-EXPOSED-REGION -;;; to be called. That information is passed in as y1 and height1. There is -;;; a second event that also has already been popped from the queue, the -;;; event resulting from peeking for multiple "exposure" events. That info -;;; is passed in as y2 and height2. -;;; -(defun coelesce-exposed-regions (hunk display y1 height1 y2 height2) - (let ((len 0)) - (declare (fixnum len)) - ;; - ;; Insert sort the exposeevents as we pick them off the event queue. - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-height (font-family-height font-family)) - (co (font-family-cursor-y-offset font-family)) - (xwindow (bitmap-hunk-xwindow hunk))) - ;; - ;; Insert the region the exposedregion handler was called on. - (multiple-value-bind (start-line start-bit end-line expanded-height) - (exposed-region-bounds y1 height1 co font-height) - (setf len - (coelesce-buffer-insert start-bit start-line - expanded-height end-line len))) - ;; - ;; Peek for exposedregion events on xwindow, inserting them into - ;; the buffer. - (let ((y y2) - (height height2)) - (loop - (multiple-value-bind (start-line start-bit end-line expanded-height) - (exposed-region-bounds y height co font-height) - (setf len - (coelesce-buffer-insert start-bit start-line - expanded-height end-line len))) - (multiple-value-setq (y height) - (exposed-region-peek-event display xwindow)) - (unless y (return))))) - (coelesce-exposed-regions-merge len))) - -;;; *coelesce-buffer* is a vector of records used to sort exposure events on a -;;; single hunk, so we can merge them into fewer, larger regions of exposure. -;;; COELESCE-BUFFER-INSERT places elements in this buffer, and each element -;;; is referenced with COELESCE-BUFFER-ELT. Each element of the coelescing -;;; buffer has the following accessors defined: -;;; COELESCE-BUFFER-ELT-START in pixels. -;;; COELESCE-BUFFER-ELT-START-LINE in dis-lines. -;;; COELESCE-BUFFER-ELT-HEIGHT in pixels. -;;; COELESCE-BUFFER-ELT-END-LINE in dis-lines. -;;; These are used by COELESCE-BUFFER-INSERT, COELESCE-EXPOSED-REGIONS-MERGE, -;;; and WRITE-N-EXPOSED-REGIONS. - -(defvar *coelesce-buffer-fill-ptr* 25) -(defvar *coelesce-buffer* (make-array *coelesce-buffer-fill-ptr*)) -(dotimes (i *coelesce-buffer-fill-ptr*) - (setf (svref *coelesce-buffer* i) (make-array 4))) - -(defmacro coelesce-buffer-elt-start (elt) - `(svref ,elt 0)) -(defmacro coelesce-buffer-elt-start-line (elt) - `(svref ,elt 1)) -(defmacro coelesce-buffer-elt-height (elt) - `(svref ,elt 2)) -(defmacro coelesce-buffer-elt-end-line (elt) - `(svref ,elt 3)) -(defmacro coelesce-buffer-elt (i) - `(svref *coelesce-buffer* ,i)) - -;;; COELESCE-BUFFER-INSERT inserts an exposed region record into -;;; *coelesce-buffer* such that start is less than all successive -;;; elements. Returns the new length of the buffer. -;;; -(defun coelesce-buffer-insert (start start-line height end-line len) - (declare (fixnum start start-line height end-line len)) - ;; - ;; Add element if len is to fill pointer. If fill pointer is to buffer - ;; length, then grow buffer. - (when (= len (the fixnum *coelesce-buffer-fill-ptr*)) - (when (= (the fixnum *coelesce-buffer-fill-ptr*) - (the fixnum (length (the simple-vector *coelesce-buffer*)))) - (let ((new (make-array (ash (length (the simple-vector *coelesce-buffer*)) - 1)))) - (replace (the simple-vector new) (the simple-vector *coelesce-buffer*) - :end1 *coelesce-buffer-fill-ptr* - :end2 *coelesce-buffer-fill-ptr*) - (setf *coelesce-buffer* new))) - (setf (coelesce-buffer-elt len) (make-array 4)) - (incf *coelesce-buffer-fill-ptr*)) - ;; - ;; Find point to insert record: start, start-line, height, and end-line. - (do ((i 0 (1+ i))) - ((= i len) - ;; Start is greater than all previous starts. Add it to the end. - (let ((region (coelesce-buffer-elt len))) - (setf (coelesce-buffer-elt-start region) start) - (setf (coelesce-buffer-elt-start-line region) start-line) - (setf (coelesce-buffer-elt-height region) height) - (setf (coelesce-buffer-elt-end-line region) end-line))) - (declare (fixnum i)) - (when (< start (the fixnum - (coelesce-buffer-elt-start (coelesce-buffer-elt i)))) - ;; - ;; Insert new element at i, using storage allocated at element len. - (let ((last (coelesce-buffer-elt len))) - (setf (coelesce-buffer-elt-start last) start) - (setf (coelesce-buffer-elt-start-line last) start-line) - (setf (coelesce-buffer-elt-height last) height) - (setf (coelesce-buffer-elt-end-line last) end-line) - ;; - ;; Shift elements after i (inclusively) to the right. - (do ((j (1- len) (1- j)) - (k len j) - (terminus (1- i))) - ((= j terminus)) - (declare (fixnum j k terminus)) - (setf (coelesce-buffer-elt k) (coelesce-buffer-elt j))) - ;; - ;; Stash element to insert at i. - (setf (coelesce-buffer-elt i) last)) - (return))) - (1+ len)) - - -;;; COELESCE-EXPOSED-REGIONS-MERGE merges/coelesces the regions in -;;; *coelesce-buffer*. It takes the number of elements and returns the new -;;; number of elements. The regions are examined one at a time relative to -;;; the current one. The current region remains so, with next advancing -;;; through the buffer, until a next region is found that does not overlap -;;; and is not adjacent. When this happens, the current values are stored -;;; in the current region, and the buffer's element after the current element -;;; becomes current. The next element that was found not to be in contact -;;; the old current element is stored in the new current element by copying -;;; its values there. The buffer's elements always stay in place, and their -;;; storage is re-used. After this process which makes the next region be -;;; the current region, the next pointer is incremented. -;;; -(defun coelesce-exposed-regions-merge (len) - (let* ((current 0) - (next 1) - (current-region (coelesce-buffer-elt 0)) - (current-height (coelesce-buffer-elt-height current-region)) - (current-end-line (coelesce-buffer-elt-end-line current-region)) - (current-end-bit (+ (the fixnum - (coelesce-buffer-elt-start current-region)) - current-height))) - (declare (fixnum current next current-height - current-end-line current-end-bit)) - (loop - (let* ((next-region (coelesce-buffer-elt next)) - (next-start (coelesce-buffer-elt-start next-region)) - (next-height (coelesce-buffer-elt-height next-region)) - (next-end-bit (+ next-start next-height))) - (declare (fixnum next-start next-height next-end-bit)) - (cond ((<= next-start current-end-bit) - (let ((extra-height (- next-end-bit current-end-bit))) - (declare (fixnum extra-height)) - ;; Maybe the next region is contained in the current. - (when (plusp extra-height) - (incf current-height extra-height) - (setf current-end-bit next-end-bit) - (setf current-end-line - (coelesce-buffer-elt-end-line next-region))))) - (t - ;; - ;; Update current record since next does not overlap - ;; with current. - (setf (coelesce-buffer-elt-height current-region) - current-height) - (setf (coelesce-buffer-elt-end-line current-region) - current-end-line) - ;; - ;; Move to new distinct region, copying data from next region. - (incf current) - (setf current-region (coelesce-buffer-elt current)) - (setf (coelesce-buffer-elt-start current-region) next-start) - (setf (coelesce-buffer-elt-start-line current-region) - (coelesce-buffer-elt-start-line next-region)) - (setf current-height next-height) - (setf current-end-bit next-end-bit) - (setf current-end-line - (coelesce-buffer-elt-end-line next-region))))) - (incf next) - (when (= next len) - (setf (coelesce-buffer-elt-height current-region) current-height) - (setf (coelesce-buffer-elt-end-line current-region) current-end-line) - (return))) - (1+ current))) - -;;; EXPOSED-REGION-BOUNDS returns as multiple values the first line affected, -;;; the first possible bit affected (accounting for the cursor), the end line -;;; affected, and the height of the region. -;;; -(defun exposed-region-bounds (y height cursor-offset font-height) - (declare (fixnum y height cursor-offset font-height)) - (let* ((start (truncate (the fixnum (- y hunk-top-border)) - font-height)) - (end (ceiling (the fixnum (- (the fixnum (+ y height)) - hunk-top-border)) - font-height))) - (values - start - (+ (the fixnum (* start font-height)) cursor-offset hunk-top-border) - end - (- (the fixnum (* (the fixnum (- end start)) font-height)) - cursor-offset)))) - - -(defun write-n-exposed-regions (hunk n) - (declare (fixnum n)) - (let* (;; Loop constants. - (end-dl (bitmap-hunk-end hunk)) - (xwindow (bitmap-hunk-xwindow hunk)) - (hunk-width (bitmap-hunk-width hunk)) - ;; Loop variables. - (dl (bitmap-hunk-start hunk)) - (i 0) - (region (coelesce-buffer-elt 0)) - (start-line (coelesce-buffer-elt-start-line region)) - (start (coelesce-buffer-elt-start region)) - (height (coelesce-buffer-elt-height region)) - (end-line (coelesce-buffer-elt-end-line region)) - (region-idx 0)) - (declare (fixnum i start start-line height end-line region-idx)) - (loop - (xlib:clear-area xwindow :x 0 :y start :width hunk-width :height height) - ;; Find this regions first line. - (loop - (when (or (eq dl end-dl) (= i start-line)) - (return)) - (incf i) - (setf dl (cdr dl))) - ;; Write this region's lines. - (loop - (when (or (eq dl end-dl) (= i end-line)) - (return)) - (hunk-write-line hunk (car dl) i) - (incf i) - (setf dl (cdr dl))) - ;; Get next region unless we're done. - (when (= (incf region-idx) n) (return)) - (setf region (coelesce-buffer-elt region-idx)) - (setf start (coelesce-buffer-elt-start region)) - (setf start-line (coelesce-buffer-elt-start-line region)) - (setf height (coelesce-buffer-elt-height region)) - (setf end-line (coelesce-buffer-elt-end-line region))) - ;; - ;; Check for modeline exposure. - (setf region (coelesce-buffer-elt (1- n))) - (setf start (coelesce-buffer-elt-start region)) - (setf height (coelesce-buffer-elt-height region)) - (when (and (bitmap-hunk-modeline-pos hunk) - (> (+ start height) - (- (bitmap-hunk-modeline-pos hunk) - (bitmap-hunk-bottom-border hunk)))) - (hunk-replace-modeline hunk) - (hunk-draw-bottom-border hunk)))) - -(defun write-one-exposed-region (hunk y height) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-height (font-family-height font-family)) - (co (font-family-cursor-y-offset font-family)) - (start-line (truncate (- y hunk-top-border) font-height)) - (end-line (ceiling (- (+ y height) hunk-top-border) font-height)) - (start-bit (+ (* start-line font-height) co hunk-top-border)) - (nheight (- (* (- end-line start-line) font-height) co)) - (hunk-end-line (bitmap-hunk-end hunk))) - (declare (fixnum font-height co start-line end-line start-bit nheight)) - (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit - :width (bitmap-hunk-width hunk) :height nheight) - (do ((dl (bitmap-hunk-start hunk) (cdr dl)) - (i 0 (1+ i))) - ((or (eq dl hunk-end-line) (= i start-line)) - (do ((i i (1+ i)) - (dl dl (cdr dl))) - ((or (eq dl hunk-end-line) (= i end-line))) - (declare (fixnum i)) - (hunk-write-line hunk (car dl) i))) - (declare (fixnum i))) - (when (and (bitmap-hunk-modeline-pos hunk) - (> (+ start-bit nheight) - (- (bitmap-hunk-modeline-pos hunk) - (bitmap-hunk-bottom-border hunk)))) - (hunk-replace-modeline hunk) - (hunk-draw-bottom-border hunk)))) - - - -;;;; Resized window handling. - -;;; :configure-notify events are sent because we select :structure-notify. -;;; This buys us a lot of events we have to write dummy handlers to ignore. -;;; - -;;; HUNK-RECONFIGURED must note that the hunk changed to prevent certain -;;; redisplay problems with recentering the window that caused bogus lines -;;; to be drawn after the actual visible text in the window. We must also -;;; indicate the hunk is trashed to eliminate exposure event handling that -;;; comes after resizing. This also causes a full redisplay on the window -;;; which is the easiest and generall best looking thing. -;;; -(defun hunk-reconfigured (hunk event-key event-window window x y width height - border-width above-sibling override-redirect-p - send-event-p) - (declare (ignore event-key event-window window x y border-width - above-sibling override-redirect-p send-event-p)) - (when (or (/= width (bitmap-hunk-width hunk)) - (/= height (bitmap-hunk-height hunk))) - ;; Under X11, don't redisplay since an exposure event is coming next. - (hunk-changed hunk width height nil) ; :redisplay) - (setf (bitmap-hunk-trashed hunk) t))) -;;; -(ext:serve-configure-notify *hemlock-windows* #'hunk-reconfigured) - - -;;; HUNK-IGNORE-EVENT ignores the following unrequested events. They all take -;;; at least five arguments, but then there are up to four more optional. -;;; -(defun hunk-ignore-event (hunk event-key event-window window one - &optional two three four five) - (declare (ignore hunk event-key event-window window one two three four five)) - t) -;;; -(ext:serve-destroy-notify *hemlock-windows* #'hunk-ignore-event) -(ext:serve-unmap-notify *hemlock-windows* #'hunk-ignore-event) -(ext:serve-map-notify *hemlock-windows* #'hunk-ignore-event) -(ext:serve-reparent-notify *hemlock-windows* #'hunk-ignore-event) -(ext:serve-gravity-notify *hemlock-windows* #'hunk-ignore-event) -(ext:serve-circulate-notify *hemlock-windows* #'hunk-ignore-event) - - - -;;;; Interface to X input events. - -;;; HUNK-KEY-INPUT and HUNK-MOUSE-INPUT. -;;; Each key and mouse event is turned into a character via -;;; EXT:TRANSLATE-CHARACTER or EXT:TRANSLATE-MOUSE-CHARACTER, either of which -;;; may return nil. Nil is returned for input that is considered uninteresting -;;; input; for example, shift and control. -;;; - -(defun hunk-key-input (hunk event-key event-window root child same-screen-p x y - root-x root-y modifiers time key-code send-event-p) - (declare (ignore event-key event-window root child same-screen-p root-x - root-y time send-event-p)) - (hunk-process-input hunk - (ext:translate-character - (bitmap-device-display (device-hunk-device hunk)) - key-code modifiers) - x y)) -;;; -(ext:serve-key-press *hemlock-windows* #'hunk-key-input) - -(defun hunk-mouse-input (hunk event-key event-window root child same-screen-p x y - root-x root-y modifiers time key-code send-event-p) - (declare (ignore event-window root child same-screen-p root-x root-y - time send-event-p)) - (hunk-process-input hunk - (ext:translate-mouse-character key-code modifiers - event-key) - x y)) -;;; -(ext:serve-button-press *hemlock-windows* #'hunk-mouse-input) -(ext:serve-button-release *hemlock-windows* #'hunk-mouse-input) - -(defun hunk-process-input (hunk char x y) - (when char - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-width (font-family-width font-family)) - (font-height (font-family-height font-family)) - (ml-pos (bitmap-hunk-modeline-pos hunk)) - (height (bitmap-hunk-height hunk)) - (width (bitmap-hunk-width hunk)) - (handler (bitmap-hunk-input-handler hunk)) - (char-width (bitmap-hunk-char-width hunk))) - (cond ((not (and (< -1 x width) (< -1 y height))) - (funcall handler hunk char nil nil)) - ((and ml-pos (> y (- ml-pos (bitmap-hunk-bottom-border hunk)))) - (funcall handler hunk char - ;; (/ width x) doesn't handle ends of thumb bar - ;; and eob right, so do a bunch of truncating. - (min (truncate x (truncate width char-width)) - (1- char-width)) - nil)) - (t - (let* ((cx (truncate (- x hunk-left-border) font-width)) - (temp (truncate (- y hunk-top-border) font-height)) - (char-height (bitmap-hunk-char-height hunk)) - ;; Extra bits below bottom line and above modeline and - ;; thumb bar are considered part of the bottom line since - ;; we have already picked off the y=nil case. - (cy (if (< temp char-height) temp (1- char-height)))) - (if (and (< -1 cx char-width) - (< -1 cy)) - (funcall handler hunk char cx cy) - (funcall handler hunk char nil nil)))))))) - - - -;;;; Handling boundary crossing events. - -;;; Entering and leaving a window are handled basically the same except -;;; that it is possible to get an entering event under X without getting -;;; an exiting event; specifically, when the mouse is in a Hemlock window -;;; that is over another window, and the top window is buried, Hemlock -;;; only gets an entering event on the lower window (no exiting event -;;; for the buried window). -;;; -;;; :enter-notify and :leave-notify events are sent because we select -;;; :enter-window and :leave-window events. -;;; - -(defun hunk-mouse-entered (hunk event-key event-window root child same-screen-p - x y root-x root-y state time mode kind - send-event-p) - (declare (ignore event-key event-window root child same-screen-p - x y root-x root-y state time mode kind focus-p - send-event-p)) - (when (and *cursor-dropped* (not *hemlock-listener*)) - (cursor-invert-center)) - (setf *hemlock-listener* t) - (let ((current-hunk (window-hunk (current-window)))) - (unless (and *current-highlighted-border* - (eq *current-highlighted-border* current-hunk)) - (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk)) - *highlight-border-pixmap*) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device current-hunk))) - (setf *current-highlighted-border* current-hunk))) - (let ((window (device-hunk-window hunk))) - ;; Why was I ever doing this? - ;; -- (find hunk *window-list* :key #'window-hunk))) - ;; - ;; The random typeout hunk does not have a window. - (when window (invoke-hook ed::enter-window-hook window)))) -;;; -(ext:serve-enter-notify *hemlock-windows* #'hunk-mouse-entered) - -(defun hunk-mouse-left (hunk event-key event-window root child same-screen-p - x y root-x root-y state time mode kind - send-event-p) - (declare (ignore event-key event-window root child same-screen-p - x y root-x root-y state time mode kind focus-p - send-event-p)) - (setf *hemlock-listener* nil) - (when *cursor-dropped* (cursor-invert-center)) - (when *current-highlighted-border* - (setf (xlib:window-border (bitmap-hunk-xwindow *current-highlighted-border*)) - *default-border-pixmap*) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *current-highlighted-border*))) - (setf *current-highlighted-border* nil)) - (let ((window (device-hunk-window hunk))) - ;; Why was I ever doing this? - ;; -- (find hunk *window-list* :key #'window-hunk))) - ;; - ;; The random typeout hunk does not have a window. - (when window (invoke-hook ed::exit-window-hook window)))) -;;; -(ext:serve-leave-notify *hemlock-windows* #'hunk-mouse-left) - - - -;;;; Making a Window. - -(defparameter minimum-window-height 100 - "If the window created by splitting a window would be shorter than this, - then we create an overlapped window the same size instead.") - -(defparameter window-y-offset 20 - "When we create an overlapped window, it is positioned this many pixels - farther down the screen than the current window.") - -(defparameter minimum-y-above-root-bottom 10 - "When we create an overlapped window, if the top of the window is within - this many pixels from the bottom of the root window, then nil is returned - to MAKE-WINDOW.") - -;;; These constants are used in DEFAULT-CREATE-WINDOW-HOOK and SET-HUNK-SIZE. -;;; The width must be that of a tab for the screen image builder, and the -;;; height must be one line (two with a modeline). -;;; -(defconstant minimum-window-lines 1 - "Windows must have at least this many lines.") -(defconstant minimum-window-columns 8 - "Windows must be at least this many characters wide.") - -(defconstant xwindow-border-width 2 "X border around X windows") -(defconstant xwindow-border-width*2 (* xwindow-border-width 2)) - -;;; We must name windows (set the "name" property) to get around a bug in -;;; awm and twm. They will not handle menu clicks without a window having -;;; a name. We set the name to this silly thing. -;;; -(defvar *hemlock-window-count* 0) -;;; -(defun new-hemlock-window-name () - (let ((*print-base* 10)) - (format nil "Hemlock ~S" (incf *hemlock-window-count*)))) - - -;;; DEFAULT-CREATE-WINDOW-HOOK is the default value for *create-window-hook*. -;;; It makes an X window on the given display. Start is a mark into a buffer -;;; for which some Hemlock window is being made for which this X window will -;;; be used. When ask-user is non-nil, we supply x, y, width, and height as -;;; standard properties for the X window which guides the window manager in -;;; prompting the user for a window. When ask-user is nil, and there is a -;;; current window, use it to guide making the new one. As a last resort, -;;; which is only used for creating the initial Hemlock window, create a window -;;; according to some variables, prompting the user when all the variables -;;; aren't there. -;;; -(defun default-create-window-hook (display start ask-user x y width height - &optional modelinep thumb-bar-p) - (let ((name (buffer-name (line-buffer (mark-line start)))) - (root (xlib:screen-root (xlib:display-default-screen display)))) - (cond (ask-user - (maybe-prompt-user-for-window root x y width height - modelinep thumb-bar-p name)) - (*current-window* - (default-create-window-from-current root name)) - (t - (maybe-prompt-user-for-window - root - (value ed::default-initial-window-x) - (value ed::default-initial-window-y) - (value ed::default-initial-window-width) - (value ed::default-initial-window-height) - modelinep thumb-bar-p name))))) - -;;; MAYBE-PROMPT-USER-FOR-WINDOW makes an X window and sets its standard -;;; properties according to supplied values. When some of these are nil, the -;;; window manager should prompt the user for those missing values when the -;;; window gets mapped. Returns the window without mapping it. -;;; -(defun maybe-prompt-user-for-window (parent x y width height - modelinep thumb-bar-p icon-name) - (let* ((extra-y (+ hunk-top-border (if thumb-bar-p - hunk-thumb-bar-bottom-border - hunk-bottom-border))) - (font-height (font-family-height *default-font-family*)) - (font-width (font-family-width *default-font-family*)) - (extra-y-w/-modeline (+ extra-y hunk-modeline-top - hunk-modeline-bottom))) - (create-window-with-properties - parent x y - (if width (+ (* width font-width) hunk-left-border)) - (if height - (if modelinep - (+ (* (1+ height) font-height) extra-y-w/-modeline) - (+ (* height font-height) extra-y))) - font-width font-height icon-name - (+ (* minimum-window-columns font-width) hunk-left-border) - (if modelinep - (+ (* (1+ minimum-window-lines) font-height) extra-y-w/-modeline) - (+ (* minimum-window-lines font-height) extra-y))))) - - -;;; DEFAULT-CREATE-WINDOW-FROM-CURRENT makes a window on the given parent window -;;; according to the current window. We split the current window unless the -;;; result would be too small, in which case we create an overlapped window. -;;; When setting standard properties, we set x, y, width, and height to tell -;;; window managers to put the window where we intend without querying the user. -;;; The window name is set to get around an awm and twm bug that inhibits -;;; menu clicks unless the window has a name; this could be used better. -;;; -(defun default-create-window-from-current (parent icon-name) - (let ((cwin (bitmap-hunk-xwindow (window-hunk *current-window*)))) - (xlib:with-state (cwin) - (let ((cw (xlib:drawable-width cwin)) - (ch (xlib:drawable-height cwin))) - (declare (fixnum cw ch)) - (multiple-value-bind (cx cy) - (window-root-xy cwin (xlib:drawable-x cwin) - (xlib:drawable-y cwin)) - (declare (fixnum cx cy)) - (multiple-value-bind (ch/2 rem) (truncate ch 2) - (declare (fixnum ch/2 rem)) - (let ((newh (- ch/2 xwindow-border-width)) - (font-height (font-family-height *default-font-family*)) - (font-width (font-family-width *default-font-family*))) - (declare (fixnum newh)) - (cond - ((>= newh minimum-window-height) - (let ((win (create-window-with-properties - parent cx (+ cy ch/2 rem xwindow-border-width) - cw newh font-width font-height - icon-name))) - ;; No need to reshape current Hemlock window structure - ;; here since this call will send an appropriate event. - (setf (xlib:drawable-height cwin) (+ newh rem)) - win)) - ((> (+ cy window-y-offset) - (- (xlib:drawable-height parent) minimum-y-above-root-bottom)) - nil) - (t - (create-window-with-properties parent cx (+ cy window-y-offset) - cw ch font-width font-height - icon-name)))))))))) - -(defvar *create-window-hook* #'default-create-window-hook - "This function is called by MAKE-WINDOW when it wants to make a new - X window. Hemlock passes as arguments the starting mark, ask-user, default, - and modelinep arguments given to MAKE-WINDOW. The function should return a - window.") - -(defun bitmap-make-window (device start modelinep window font-family - ask-user x y width-arg height-arg) - (let* ((display (bitmap-device-display device)) - (thumb-bar-p (value ed::thumb-bar-meter)) - (hunk (make-bitmap-hunk - :font-family font-family - :end the-sentinel :trashed t - :input-handler #'window-input-handler - :device device - :thumb-bar-p (and modelinep thumb-bar-p)))) - (multiple-value-bind (window width height) - (maybe-make-x-window window display start ask-user - x y width-arg height-arg - modelinep thumb-bar-p) - (unless window (return-from bitmap-make-window nil)) - (setf (bitmap-hunk-xwindow hunk) window) - (setf (bitmap-hunk-gcontext hunk) - (default-gcontext window font-family)) - ;; - ;; Select input and enable event service before showing the window. - (setf (xlib:window-event-mask window) interesting-xevents-mask) - (add-xwindow-object window hunk *hemlock-windows*) - (xlib:map-window window) - (xlib:display-finish-output display) - ;; A window is not really mapped until it is viewable (not visible). - ;; It is said to be mapped if a map request has been sent whether it - ;; is handled or not. - (loop (when (eq (xlib:window-map-state window) :viewable) - (return))) - ;; - ;; Find out how big it is... - (if width - (set-hunk-size hunk width height modelinep) - (xlib:with-state (window) - (set-hunk-size hunk (xlib:drawable-width window) - (xlib:drawable-height window) modelinep))) - (setf (bitmap-hunk-window hunk) - (window-for-hunk hunk start modelinep)) - ;; - ;; If there is a current window, link this in after it, otherwise - ;; make this circularly linked, and set *current-window* to it. - (cond (*current-window* - (let ((h (window-hunk *current-window*))) - (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk) - (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk) - (setf (bitmap-hunk-previous hunk) h))) - (t - (setq *current-window* (bitmap-hunk-window hunk)) - (setf (bitmap-hunk-previous hunk) hunk) - (setf (bitmap-hunk-next hunk) hunk))) - (push hunk (device-hunks device)) - (bitmap-hunk-window hunk)))) - -;;; MAYBE-MAKE-X-WINDOW is called by BITMAP-MAKE-WINDOW. If window is an X -;;; window, we clear it and return the window with its width and height. -;;; Otherwise, we call *create-window-hook* on the other arguments passed in, -;;; returning the created window and nil for the width and height. When a -;;; window is created, it may not be mapped, and, therefore, it's width and -;;; height would not be known. -;;; -(defun maybe-make-x-window (window display start ask-user x y width height - modelinep thumb-bar-p) - (cond (window - (check-type window xlib:window) - (xlib:with-state (window) - (let ((width (xlib:drawable-width window)) - (height (xlib:drawable-height window))) - (xlib:clear-area window :width width :height height) - (values window width height)))) - (t - (let ((window (funcall *create-window-hook* - display start ask-user x y width height - modelinep thumb-bar-p))) - (values window nil nil))))) - -;;; MAKE-XWINDOW-LIKE-HWINDOW makes a new X window that overlays the supplied -;;; Hemlock window. When setting standard properties, we set x, y, width, and -;;; height to tell window managers to put the window where we intend without -;;; querying the user. The window name is set to get around an awm and twm bug -;;; that inhibits menu clicks unless the window has a name; this could be used -;;; better. -;;; -(defun make-xwindow-like-hwindow (window) - (let* ((hunk (window-hunk window)) - (xwin (bitmap-hunk-xwindow hunk))) - (multiple-value-bind (x y) - (window-root-xy xwin) - (create-window-with-properties - (xlib:screen-root (xlib:display-default-screen - (bitmap-device-display (device-hunk-device hunk)))) - x y (bitmap-hunk-width hunk) (bitmap-hunk-height hunk) - (font-family-width *default-font-family*) - (font-family-height *default-font-family*) - (buffer-name (window-buffer window)))))) - - - -;;;; Deleting a window. - -;;; DEFAULT-DELETE-WINDOW-HOOK destroys the X window after obtaining its -;;; necessary state information. If the previous or next window (in that -;;; order) is "stacked" over or under the target window, then it is grown to -;;; fill in the newly opened space. We fetch all the necessary configuration -;;; data up front, so we don't have to call XLIB:DESTROY-WINDOW while in the -;;; XLIB:WITH-STATE. -;;; -(defun default-delete-window-hook (xwin hwin) - (multiple-value-bind (h x y) - (xlib:with-state (xwin) - (multiple-value-bind - (x y) - (window-root-xy xwin (xlib:drawable-x xwin) - (xlib:drawable-y xwin)) - (values (xlib:drawable-height xwin) x y))) - (xlib:destroy-window xwin) - (let ((hunk (window-hunk hwin))) - (xlib:free-gcontext (bitmap-hunk-gcontext hunk)) - (unless (default-delete-window-hook-prev-merge hunk x y h) - (default-delete-window-hook-next-merge hunk x y h))))) -;;; -(defvar *delete-window-hook* #'default-delete-window-hook - "This function is called by DELETE-WINDOW when it wants to delete an X - window. It is passed the X window and the Hemlock window as arguments.") - -;;; DEFAULT-DELETE-WINDOW-HOOK-PREV-MERGE returns non-nil when the previous -;;; hunk to hunk is grown to take up hunk's space on the screen. -;;; -(defun default-delete-window-hook-prev-merge (hunk x y h) - (declare (fixnum x y h)) - (let* ((prev (bitmap-hunk-previous hunk)) - (prev-xwin (bitmap-hunk-xwindow prev))) - (xlib:with-state (prev-xwin) - (let ((ph (xlib:drawable-height prev-xwin))) - (declare (fixnum ph)) - (multiple-value-bind (px py) - (window-root-xy prev-xwin - (xlib:drawable-x prev-xwin) - (xlib:drawable-y prev-xwin)) - (declare (fixnum px py)) - (if (and (= x px) - (= y (the fixnum (+ py ph xwindow-border-width*2)))) - (setf (xlib:drawable-height prev-xwin) - (the fixnum (+ ph xwindow-border-width*2 h))))))))) - -;;; DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE trys to grow the next hunk's window -;;; to make use of the space created by deleting hunk's window. If this is -;;; possible, then we must also move the next window up to where hunk's window -;;; was. -;;; -;;; When we reconfigure the window, we must set the hunk trashed. This is a -;;; hack since twm is broken again and is sending exposure events before -;;; reconfigure notifications. Hemlock relies on the protocol's statement that -;;; reconfigures come before exposures to set the hunk trashed before getting -;;; the exposure. For now, we'll do it here too. -;;; -(defun default-delete-window-hook-next-merge (hunk x y h) - (declare (fixnum x y h)) - (let* ((next (bitmap-hunk-next hunk)) - (next-xwin (bitmap-hunk-xwindow next)) - (newy - (xlib:with-state (next-xwin) - (multiple-value-bind (nx ny) - (window-root-xy next-xwin - (xlib:drawable-x next-xwin) - (xlib:drawable-y next-xwin)) - (declare (fixnum nx ny)) - (when (and (= x nx) - (= ny (the fixnum (+ y h xwindow-border-width*2)))) - ;; Fetch height before setting y to save one extra round trip to - ;; the X server. - (let ((nh (xlib:drawable-height next-xwin))) - (declare (fixnum nh)) - (setf (xlib:drawable-y next-xwin) y) - (setf (xlib:drawable-height next-xwin) - (the fixnum (+ h xwindow-border-width*2 nh)))) - y))))) - (when newy - (setf (bitmap-hunk-trashed next) t) - (let ((hints (xlib:wm-normal-hints next-xwin))) - (setf (xlib:wm-size-hints-y hints) newy) - (setf (xlib:wm-normal-hints next-xwin) hints))))) - -#| -;;; DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE ... Hack! -;;; -;;; This version works when window managers refuse to allow clients to -;;; reposition windows. What we do instead is to delete the next hunk's X -;;; window, making a new one in the place of hunk's window that fills the empty -;;; space created by deleting both windows. Some code from the default window -;;; creation hook and BITMAP-MAKE-WINDOW is duplicated here. Also, there is -;;; is a funny issue over whether to invoke the "Make Window Hook" even though -;;; we didn't really make a new Hemlock window. -;;; -(defun default-delete-window-hook-next-merge (hunk x y h) - (let* ((next (bitmap-hunk-next hunk)) - (next-hwin (device-hunk-window next)) - (next-xwin (bitmap-hunk-xwindow next))) - (multiple-value-bind - (nx ny nh) - (xlib:with-state (next-xwin) - (multiple-value-bind (nx ny) - (window-root-xy next-xwin - (xlib:drawable-x next-xwin) - (xlib:drawable-y next-xwin)) - (declare (fixnum nx ny)) - (when (and (= x nx) - (= ny (the fixnum (+ y h xwindow-border-width*2)))) - (values x y (the fixnum (+ h xwindow-border-width*2 - (xlib:drawable-height next-xwin))))))) - (when nx - (let* ((font-family (bitmap-hunk-font-family next)) - (display (bitmap-device-display (device-hunk-device next))) - (nwin (create-window-with-properties - (xlib:screen-root (xlib:display-default-screen display)) - nx ny (bitmap-hunk-width next) nh - (font-family-width font-family) - (font-family-height font-family) - (buffer-name (window-buffer next-hwin))))) - ;; - ;; Delete next's X window. - (remove-xwindow-object next-xwin) - (when (eq *current-highlighted-border* next) - (setf *current-highlighted-border* nil)) - (when (and (eq *cursor-hunk* next) *cursor-dropped*) (lift-cursor)) - (xlib:display-force-output display) - (xlib:destroy-window next-xwin) - (xlib:free-gcontext (bitmap-hunk-gcontext next)) - (loop (unless (deleting-window-drop-event display next-xwin) - (return))) - ;; - ;; Install new X window. - (setf (bitmap-hunk-xwindow next) nwin) - (setf (xlib:window-event-mask nwin) interesting-xevents-mask) - (add-xwindow-object nwin next *hemlock-windows*) - (xlib:map-window nwin) - (xlib:display-finish-output display) - (loop (when (eq (xlib:window-map-state nwin) :viewable) - (return))) - (xlib:with-state (nwin) - (hunk-changed next (xlib:drawable-width nwin) - (xlib:drawable-height nwin) nil)) - ;; This normally occurs as a result of "Make Window Hook". Other - ;; problems may occur if users are using this hook to do things to - ;; their X windows. Invoking this hook here could be bad too since - ;; we didn't really create a new Hemlock window. - (define-window-cursor next-hwin)))))) -|# - -;;; DELETING-WINDOW-DROP-EVENT checks for any events on win. If there is one, -;;; it is removed from the queue, and t is returned. Otherwise, returns nil. -;;; -(defun deleting-window-drop-event (display win) - (xlib:display-finish-output display) - (let ((result nil)) - (xlib:process-event - display :timeout 0 - :handler #'(lambda (&key event-window window &allow-other-keys) - (if (or (eq event-window win) (eq window win)) - (setf result t) - nil))) - result)) - - -;;; BITMAP-DELETE-WINDOW -- Internal -;;; -;;; -(defun bitmap-delete-window (window) - (let* ((hunk (window-hunk window)) - (xwindow (bitmap-hunk-xwindow hunk)) - (display (bitmap-device-display (device-hunk-device hunk)))) - (remove-xwindow-object xwindow) - (setq *window-list* (delete window *window-list*)) - (when (eq *current-highlighted-border* hunk) - (setf *current-highlighted-border* nil)) - (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor)) - (xlib:display-force-output display) - (funcall *delete-window-hook* xwindow window) - (loop (unless (deleting-window-drop-event display xwindow) (return))) - (let ((device (device-hunk-device hunk))) - (setf (device-hunks device) (delete hunk (device-hunks device)))) - (let ((next (bitmap-hunk-next hunk)) - (prev (bitmap-hunk-previous hunk))) - (setf (bitmap-hunk-next prev) next) - (setf (bitmap-hunk-previous next) prev) - (let ((buffer (window-buffer window))) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))))) - nil) - - - -;;;; Next and Previous windows. - -(defun bitmap-next-window (window) - "Return the next window after Window, wrapping around if Window is the - bottom window." - (check-type window window) - (bitmap-hunk-window (bitmap-hunk-next (window-hunk window)))) - -(defun bitmap-previous-window (window) - "Return the previous window after Window, wrapping around if Window is the - top window." - (check-type window window) - (bitmap-hunk-window (bitmap-hunk-previous (window-hunk window)))) - - - -;;;; Setting window width and height. - -;;; %SET-WINDOW-WIDTH -- Internal -;;; -;;; Since we don't support non-full-width windows, this does nothing. -;;; -(defun %set-window-width (window new-value) - (declare (ignore window)) - new-value) - -;;; %SET-WINDOW-HEIGHT -- Internal -;;; -;;; Can't change window height either. -;;; -(defun %set-window-height (window new-value) - (declare (ignore window)) - new-value) - - - -;;;; Random Typeout - -;;; Random typeout is done to a bitmap-hunk-output-stream -;;; (Bitmap-Hunk-Stream.Lisp). These streams have an associated hunk -;;; that is used for its font-family, foreground and background color, -;;; and X window pointer. The hunk is not associated with any Hemlock -;;; window, and the low level painting routines that use hunk dimensions -;;; are not used for output. The X window is resized as necessary with -;;; each use, but the hunk is only registered for input and boundary -;;; crossing event service; therefore, it never gets exposure or changed -;;; notifications. - -;;; These are set in INIT-BITMAP-SCREEN-MANAGER. -;;; -(defvar *random-typeout-start-x* 0 - "Where we put the the random typeout window.") -(defvar *random-typeout-start-y* 0 - "Where we put the the random typeout window.") -(defvar *random-typeout-start-width* 0 - "How wide the random typeout window is.") - - -;;; DEFAULT-RANDOM-TYPEOUT-HOOK -- Internal -;;; -;;; The default hook-function for random typeout. Nothing very fancy -;;; for now. If not given a window, makes one on top of the initial -;;; Hemlock window using specials set in INIT-BITMAP-SCREEN-MANAGER. If -;;; given a window, we will change the height subject to the constraint -;;; that the bottom won't be off the screen. Any resulting window has -;;; input and boundary crossing events selected, a hemlock cursor defined, -;;; and is mapped. -;;; -(defun default-random-typeout-hook (device window height) - (declare (fixnum height)) - (let* ((display (bitmap-device-display device)) - (root (xlib:screen-root (xlib:display-default-screen display))) - (full-height (xlib:drawable-height root)) - (actual-height (if window - (multiple-value-bind (x y) (window-root-xy window) - (declare (ignore x) (fixnum y)) - (min (- full-height y xwindow-border-width*2) - height)) - (min (- full-height *random-typeout-start-y* - xwindow-border-width*2) - height))) - (win (cond (window - (setf (xlib:drawable-height window) actual-height) - window) - ((xlib:create-window - :parent root - :x *random-typeout-start-x* - :y *random-typeout-start-y* - :width *random-typeout-start-width* - :height actual-height - :background *default-background-pixel* - :border-width xwindow-border-width - :border *default-border-pixmap* - :event-mask random-typeout-xevents-mask - :override-redirect :on :class :input-output)))) - (gcontext (if (not window) (default-gcontext win)))) - (unless window - (xlib:with-state (win) - (setf (xlib:window-event-mask win) random-typeout-xevents-mask) - (setf (xlib:window-cursor win) *hemlock-cursor*))) - (values win gcontext))) - -(defvar *random-typeout-hook* #'default-random-typeout-hook - "This function is called when a window is needed to display random typeout. - It is called with the Hemlock device, a pre-existing window or NIL, and the - number of pixels needed to display the number of lines requested in - WITH-RANDOM-TYPEOUT. It should return a window, and if a new window was - created, then a gcontext must be returned as the second value.") - -;;; BITMAP-RANDOM-TYPEOUT-SETUP -- Internal -;;; -;;; This function is called by the with-random-typeout macro to -;;; to set things up. It calls the *Random-Typeout-Hook* to get a window -;;; to work with, and then adjusts the random typeout stream's data-structures -;;; to match. -;;; -(defun bitmap-random-typeout-setup (device stream height) - (let* ((*more-prompt-action* :empty) - (hwin-exists-p (random-typeout-stream-window stream)) - (hwindow (if hwin-exists-p - (change-bitmap-random-typeout-window hwin-exists-p height) - (setf (random-typeout-stream-window stream) - (make-bitmap-random-typeout-window - device - (buffer-start-mark - (line-buffer - (mark-line (random-typeout-stream-mark stream)))) - height))))) - (let ((xwindow (bitmap-hunk-xwindow (window-hunk hwindow))) - (display (bitmap-device-display device))) - (xlib:display-finish-output display) - (loop - (unless (xlib:event-case (display :timeout 0) - (:exposure (event-window) - (eq event-window xwindow)) - (t () nil)) - (return)))))) - -(defun change-bitmap-random-typeout-window (hwindow height) - (update-modeline-field (window-buffer hwindow) hwindow :more-prompt) - (let* ((hunk (window-hunk hwindow)) - (xwin (bitmap-hunk-xwindow hunk))) - ;; - ;; *random-typeout-hook* sets the window's height to the right value. - (funcall *random-typeout-hook* (device-hunk-device hunk) xwin - (+ (* height (font-family-height (bitmap-hunk-font-family hunk))) - hunk-top-border (bitmap-hunk-bottom-border hunk) - hunk-modeline-top hunk-modeline-bottom)) - (xlib:with-state (xwin) - (hunk-changed hunk (xlib:drawable-width xwin) (xlib:drawable-height xwin) - nil)) - ;; - ;; We push this on here because we took it out the last time we cleaned up. - (push hwindow (buffer-windows (window-buffer hwindow))) - (setf (bitmap-hunk-trashed hunk) t) - (xlib:map-window xwin) - (setf (xlib:window-priority xwin) :above)) - hwindow) - -(defun make-bitmap-random-typeout-window (device mark height) - (let* ((display (bitmap-device-display device)) - (hunk (make-bitmap-hunk - :font-family *default-font-family* - :end the-sentinel :trashed t - :input-handler #'window-input-handler - :device device :thumb-bar-p nil))) - (multiple-value-bind - (xwindow gcontext) - (funcall *random-typeout-hook* - device (bitmap-hunk-xwindow hunk) - (+ (* height (font-family-height *default-font-family*)) - hunk-top-border (bitmap-hunk-bottom-border hunk) - hunk-modeline-top hunk-modeline-bottom)) - ;; - ;; When gcontext, we just made the window, so tie some stuff together. - (when gcontext - (setf (xlib:gcontext-font gcontext) - (svref (font-family-map *default-font-family*) 0)) - (setf (bitmap-hunk-xwindow hunk) xwindow) - (setf (bitmap-hunk-gcontext hunk) gcontext) - ;; - ;; Select input and enable event service before showing the window. - (setf (xlib:window-event-mask xwindow) random-typeout-xevents-mask) - (add-xwindow-object xwindow hunk *hemlock-windows*)) - ;; - ;; Put the window on the screen so it's visible and we can know the size. - (xlib:map-window xwindow) - (xlib:display-finish-output display) - ;; A window is not really mapped until it is viewable (not visible). - ;; It is said to be mapped if a map request has been sent whether it - ;; is handled or not. - (loop (when (eq (xlib:window-map-state xwindow) :viewable) - (return))) - (xlib:with-state (xwindow) - (set-hunk-size hunk (xlib:drawable-width xwindow) - (xlib:drawable-height xwindow) t)) - ;; - ;; Get a Hemlock window and hide it from the rest of Hemlock. - (let ((hwin (window-for-hunk hunk mark *random-typeout-ml-fields*))) - (update-modeline-field (window-buffer hwin) hwin :more-prompt) - (setf (bitmap-hunk-window hunk) hwin) - (setf *window-list* (delete hwin *window-list*)) - hwin)))) - - -;;; RANDOM-TYPEOUT-CLEANUP -- Internal -;;; -;;; Clean up after random typeout. This just removes the window from -;;; the screen and sets the more-prompt action back to normal. -;;; -(defun bitmap-random-typeout-cleanup (stream degree) - (when degree - (xlib:unmap-window (bitmap-hunk-xwindow - (window-hunk (random-typeout-stream-window stream)))))) - - - -;;;; Initialization. - -;;; DEFAULT-CREATE-INITIAL-WINDOWS-HOOK makes the initial windows, main and -;;; echo. The main window is made according to "Default Initial Window X", -;;; "Default Initial Window Y", "Default Initial Window Width", and "Default -;;; Initial Window Height", prompting the user for any unspecified components. -;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO is called to return the location and -;;; size of the echo area including how big its font is, and the main xwindow -;;; is potentially modified by this function. The window name is set to get -;;; around an awm and twm bug that inhibits menu clicks unless the window has a -;;; name; this could be used better. -;;; -(defun default-create-initial-windows-hook (device) - (let* ((main-win (make-window (buffer-start-mark *current-buffer*) - :device device)) - (main-xwin (bitmap-hunk-xwindow (window-hunk main-win))) - (root (xlib:screen-root (xlib:display-default-screen - (bitmap-device-display device))))) - (multiple-value-bind - (echo-x echo-y echo-width echo-height f-width f-height) - (default-create-initial-windows-echo - (xlib:drawable-height root) - (bitmap-hunk-font-family (window-hunk main-win)) - main-xwin) - (let ((echo-win (create-window-with-properties - root echo-x echo-y echo-width echo-height - f-width f-height "Echo Area"))) - (setf *echo-area-window* - (hlet ((ed::thumb-bar-meter nil)) - (make-window - (buffer-start-mark *echo-area-buffer*) - :device device :window echo-win - :modelinep t))))) - (setf *current-window* main-win) - (setf (xlib:window-border main-xwin) *highlight-border-pixmap*))) - -;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO makes the echo area window as wide as -;;; the main window and places it directly under it. If the echo area does not -;;; fit on the screen, we change the main window to make it fit. There is -;;; a problem in computing main-xwin's x and y relative to the root window -;;; which is where we line up the echo and main windows. Some losing window -;;; managers (awm and twm) reparent the window, so we have to make sure -;;; main-xwin's x and y are relative to the root and not some false parent. -;;; -(defun default-create-initial-windows-echo (full-height font-family main-xwin) - (declare (fixnum full-height)) - (xlib:with-state (main-xwin) - (let ((w (xlib:drawable-width main-xwin)) - (h (xlib:drawable-height main-xwin))) - (declare (fixnum w h)) - (multiple-value-bind (x y) - (window-root-xy main-xwin - (xlib:drawable-x main-xwin) - (xlib:drawable-y main-xwin)) - (declare (fixnum x y)) - (let* ((ff-height (font-family-height font-family)) - (ff-width (font-family-width font-family)) - (echo-height (+ (* ff-height 4) - hunk-top-border hunk-bottom-border - hunk-modeline-top hunk-modeline-bottom))) - (declare (fixnum echo-height)) - (if (<= (+ y h echo-height xwindow-border-width*2) full-height) - (values x (+ y h xwindow-border-width*2) - w echo-height ff-width ff-height) - (let* ((newh (- full-height y echo-height xwindow-border-width*2 - ;; Since y is really the outside y, subtract - ;; two more borders, so the echo area's borders - ;; both appear on the screen. - xwindow-border-width*2))) - (setf (xlib:drawable-height main-xwin) newh) - (values x (+ y newh xwindow-border-width*2) - w echo-height ff-width ff-height)))))))) - -(defvar *create-initial-windows-hook* #'default-create-initial-windows-hook - "This function is used when the screen manager is initialized to make the - first windows, typically the main and echo area windows. It takes a - Hemlock device as a required argument. It sets *current-window* and - *echo-area-window*.") - -(defun init-bitmap-screen-manager (display) - ;; - ;; Setup stuff for X interaction. - (cond ((value ed::reverse-video) - (setf *default-background-pixel* - (xlib:screen-black-pixel (xlib:display-default-screen display))) - (setf *default-foreground-pixel* - (xlib:screen-white-pixel (xlib:display-default-screen display))) - (setf *cursor-background-color* (make-black-color)) - (setf *cursor-foreground-color* (make-white-color)) - (setf *hack-hunk-replace-line* nil)) - (t (setf *default-background-pixel* - (xlib:screen-white-pixel (xlib:display-default-screen display))) - (setf *default-foreground-pixel* - (xlib:screen-black-pixel (xlib:display-default-screen display))) - (setf *cursor-background-color* (make-white-color)) - (setf *cursor-foreground-color* (make-black-color)) - (setf *hack-hunk-replace-line* t))) - (setf *foreground-background-xor* - (logxor *default-foreground-pixel* *default-background-pixel*)) - (setf *highlight-border-pixmap* *default-foreground-pixel*) - (setf *default-border-pixmap* (get-hemlock-grey-pixmap display)) - (get-hemlock-cursor display) - (add-hook ed::make-window-hook 'define-window-cursor) - ;; - ;; Make the device for the rest of initialization. - (let ((device (make-default-bitmap-device display))) - ;; - ;; Create initial windows. - (funcall *create-initial-windows-hook* device) - ;; - ;; Unlink the echo area window from the next/prev list. - (let* ((hunk (window-hunk *echo-area-window*)) - (next (bitmap-hunk-next hunk)) - (prev (bitmap-hunk-previous hunk))) - (setf (bitmap-hunk-next prev) next) - (setf (bitmap-hunk-previous next) prev) - (setf (bitmap-hunk-previous hunk) hunk) - (setf (bitmap-hunk-next hunk) hunk) - (setf (bitmap-hunk-thumb-bar-p hunk) nil)) - ;; - ;; Setup random typeout over the user's main window. - (let ((xwindow (bitmap-hunk-xwindow (window-hunk *current-window*)))) - (xlib:with-state (xwindow) - (multiple-value-bind (x y) - (window-root-xy xwindow (xlib:drawable-x xwindow) - (xlib:drawable-y xwindow)) - (setf *random-typeout-start-x* x) - (setf *random-typeout-start-y* y)) - (setf *random-typeout-start-width* (xlib:drawable-width xwindow))))) - (add-hook ed::window-buffer-hook 'set-window-name-for-window-buffer) - (add-hook ed::buffer-name-hook 'set-window-name-for-buffer-name) - (add-hook ed::set-window-hook 'set-window-hook-raise-fun)) - -(defun make-default-bitmap-device (display) - (make-bitmap-device - :name "Windowed Bitmap Device" - :init #'init-bitmap-device - :exit #'exit-bitmap-device - :smart-redisplay #'smart-window-redisplay - :dumb-redisplay #'dumb-window-redisplay - :after-redisplay #'bitmap-after-redisplay - :clear nil - :note-read-wait #'frob-cursor - :put-cursor #'hunk-show-cursor - :show-mark #'bitmap-show-mark - :next-window #'bitmap-next-window - :previous-window #'bitmap-previous-window - :make-window #'bitmap-make-window - :delete-window #'bitmap-delete-window - :force-output #'bitmap-force-output - :finish-output #'bitmap-finish-output - :random-typeout-setup #'bitmap-random-typeout-setup - :random-typeout-cleanup #'bitmap-random-typeout-cleanup - :random-typeout-full-more #'do-bitmap-full-more - :random-typeout-line-more #'update-bitmap-line-buffered-stream - :beep #'bitmap-beep - :display display)) - -(defun init-bitmap-device (device) - (let ((display (bitmap-device-display device))) - (ext:flush-display-events display) - (hemlock-window display t))) - -(defun exit-bitmap-device (device) - (hemlock-window (bitmap-device-display device) nil)) - -(defun bitmap-finish-output (device window) - (declare (ignore window)) - (xlib:display-finish-output (bitmap-device-display device))) - -(defun bitmap-force-output () - (xlib:display-force-output - (bitmap-device-display (device-hunk-device (window-hunk (current-window)))))) - -(defun bitmap-after-redisplay (device) - (let ((display (bitmap-device-display device))) - (loop (unless (ext:object-set-event-handler display) (return))))) - - - -;;;; Miscellaneous. - -;;; HUNK-RESET is called in redisplay to make sure the hunk is up to date. -;;; If the size is wrong, or it is trashed due to font changes, then we -;;; call HUNK-CHANGED. We also clear the hunk. -;;; -(defun hunk-reset (hunk) - (let ((xwindow (bitmap-hunk-xwindow hunk)) - (trashed (bitmap-hunk-trashed hunk))) - (when trashed - (setf (bitmap-hunk-trashed hunk) nil) - (xlib:with-state (xwindow) - (let ((w (xlib:drawable-width xwindow)) - (h (xlib:drawable-height xwindow))) - (when (or (/= w (bitmap-hunk-width hunk)) - (/= h (bitmap-hunk-height hunk)) - (eq trashed :font-change)) - (hunk-changed hunk w h nil))))) - (xlib:clear-area xwindow :width (bitmap-hunk-width hunk) - :height (bitmap-hunk-height hunk)) - (hunk-draw-bottom-border hunk))) - -;;; HUNK-CHANGED is called from the changed window handler and HUNK-RESET. -;;; Don't go through REDISPLAY-WINDOW-ALL since the window changed handler -;;; updates the window image. -;;; -(defun hunk-changed (hunk new-width new-height redisplay) - (set-hunk-size hunk new-width new-height) - (funcall (bitmap-hunk-changed-handler hunk) hunk) - (when redisplay (dumb-window-redisplay (bitmap-hunk-window hunk)))) - - -;;; SET-HUNK-SIZE -- Internal -;;; -;;; Given a pixel size for a bitmap hunk, set the char size. If the window -;;; is too small, we refuse to admit it; if the user makes unreasonably small -;;; windows, our only responsibity is to not blow up. X will clip any stuff -;;; that doesn't fit. -;;; -(defun set-hunk-size (hunk w h &optional modelinep) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-width (font-family-width font-family)) - (font-height (font-family-height font-family))) - (setf (bitmap-hunk-height hunk) h) - (setf (bitmap-hunk-width hunk) w) - (setf (bitmap-hunk-char-width hunk) - (max (truncate (- w hunk-left-border) font-width) - minimum-window-columns)) - (let* ((h-minus-borders (- h hunk-top-border - (bitmap-hunk-bottom-border hunk))) - (hwin (bitmap-hunk-window hunk)) - (modelinep (or modelinep (and hwin (window-modeline-buffer hwin))))) - (setf (bitmap-hunk-char-height hunk) - (max (if modelinep - (1- (truncate (- h-minus-borders - hunk-modeline-top hunk-modeline-bottom) - font-height)) - (truncate h-minus-borders font-height)) - minimum-window-lines)) - (setf (bitmap-hunk-modeline-pos hunk) - (if modelinep (- h font-height - hunk-modeline-top hunk-modeline-bottom)))))) - -(defun bitmap-hunk-bottom-border (hunk) - (if (bitmap-hunk-thumb-bar-p hunk) - hunk-thumb-bar-bottom-border - hunk-bottom-border)) - - -;;; DEFAULT-GCONTEXT is used when making hunks. -;;; -(defun default-gcontext (drawable &optional font-family) - (xlib:create-gcontext - :drawable drawable - :foreground *default-foreground-pixel* - :background *default-background-pixel* - :font (if font-family (svref (font-family-map font-family) 0)))) - - -;;; WINDOW-ROOT-XY returns the x and y coordinates for a window relative to -;;; its root. Some window managers reparent Hemlock's window, so we have -;;; to mess around possibly to get this right. If x and y are supplied, they -;;; are relative to xwin's parent. -;;; -(defun window-root-xy (xwin &optional x y) - (multiple-value-bind (children parent root) - (xlib:query-tree xwin) - (declare (ignore children)) - (if (eq parent root) - (if (and x y) - (values x y) - (xlib:with-state (xwin) - (values (xlib:drawable-x xwin) (xlib:drawable-y xwin)))) - (multiple-value-bind - (tx ty) - (if (and x y) - (xlib:translate-coordinates parent x y root) - (xlib:with-state (xwin) - (xlib:translate-coordinates - parent (xlib:drawable-x xwin) (xlib:drawable-y xwin) root))) - (values (- tx xwindow-border-width) - (- ty xwindow-border-width)))))) - -;;; CREATE-WINDOW-WITH-PROPERTIES makes an X window with parent. X, y, w, and -;;; h are possibly nil, so we supply zero in this case. This would be used -;;; for prompting the user. Some standard properties are set to keep window -;;; managers in line. We name all windows because awm and twm window managers -;;; refuse to honor menu clicks over windows without names. Min-width and -;;; min-height are optional and only used for prompting the user for a window. -;;; -(defun create-window-with-properties (parent x y w h font-width font-height - icon-name &optional min-width min-height) - (let ((win (xlib:create-window - :parent parent :x (or x 0) :y (or y 0) - :width (or w 0) :height (or h 0) - :background *default-background-pixel* - :border-width xwindow-border-width - :border *default-border-pixmap* - :class :input-output))) - (xlib:set-wm-properties - win :name (new-hemlock-window-name) :icon-name icon-name - :resource-name "Hemlock" - :x x :y y :width w :height h - :user-specified-position-p t :user-specified-size-p t - :width-inc font-width :height-inc font-height - :min-width min-width :min-height min-height) - win)) - -#| -;;; SET-WINDOW-ROOT-Y moves xwin to the y position relative to the root. Some -;;; window managers reparent Hemlock's window, so we have to mess around -;;; possibly to get this right. In this case we want to move the parent to the -;;; root y position less how far down our window is inside this new parent. -;;; -(defun set-window-root-y (xwin y) - (multiple-value-bind (children parent root) - (xlib:query-tree xwin) - (declare (ignore children)) - (if (eq parent root) - (setf (xlib:drawable-y xwin) y) - (setf (xlib:drawable-y parent) (- y (xlib:drawable-y xwin)))))) -|# - -;;; SET-WINDOW-HOOK-RAISE-FUN is a "Set Window Hook" function controlled by -;;; "Set Window Autoraise". When autoraising, check that it isn't only the -;;; echo area window that we autoraise; if it is only the echo area window, -;;; then see if window is the echo area window. -;;; -(defun set-window-hook-raise-fun (window) - (let ((auto (value ed::set-window-autoraise))) - (when (and auto - (or (not (eq auto :echo-only)) - (eq window *echo-area-window*))) - (let* ((hunk (window-hunk window)) - (win (bitmap-hunk-xwindow hunk))) - (xlib:map-window win) - (setf (xlib:window-priority win) :above) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device hunk))))))) - - -;;; REVERSE-VIDEO-HOOK-FUN is called when the variable "Reverse Video" is set. -;;; If we are running on a windowed bitmap, we first setup the default -;;; foregrounds and backgrounds. Having done that, we get a new cursor. Then -;;; we do over all the hunks, updating their graphics contexts, cursors, and -;;; backgrounds. The current window's border is given the new highlight pixmap. -;;; Lastly, we update the random typeout hunk and redisplay everything. -;;; -(defun reverse-video-hook-fun (name kind where new-value) - (declare (ignore name kind where)) - (when (windowed-monitor-p) - (let* ((current-window (current-window)) - (current-hunk (window-hunk current-window)) - (device (device-hunk-device current-hunk)) - (display (bitmap-device-display device))) - (cond - (new-value - (setf *default-background-pixel* - (xlib:screen-black-pixel (xlib:display-default-screen display))) - (setf *default-foreground-pixel* - (xlib:screen-white-pixel (xlib:display-default-screen display))) - (setf *cursor-background-color* (make-black-color)) - (setf *cursor-foreground-color* (make-white-color)) - (setf *hack-hunk-replace-line* nil)) - (t (setf *default-background-pixel* - (xlib:screen-white-pixel (xlib:display-default-screen display))) - (setf *default-foreground-pixel* - (xlib:screen-black-pixel (xlib:display-default-screen display))) - (setf *cursor-background-color* (make-white-color)) - (setf *cursor-foreground-color* (make-black-color)) - (setf *hack-hunk-replace-line* t))) - (setf *highlight-border-pixmap* *default-foreground-pixel*) - (get-hemlock-cursor display) - (dolist (hunk (device-hunks device)) - (reverse-video-frob-hunk hunk)) - (dolist (rt-info *random-typeout-buffers*) - (reverse-video-frob-hunk - (window-hunk (random-typeout-stream-window (cdr rt-info))))) - (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk)) - *highlight-border-pixmap*)) - (redisplay-all))) - -(defun reverse-video-frob-hunk (hunk) - (let ((gcontext (bitmap-hunk-gcontext hunk))) - (setf (xlib:gcontext-foreground gcontext) *default-foreground-pixel*) - (setf (xlib:gcontext-background gcontext) *default-background-pixel*)) - (let ((xwin (bitmap-hunk-xwindow hunk))) - (setf (xlib:window-cursor xwin) *hemlock-cursor*) - (setf (xlib:window-background xwin) *default-background-pixel*))) diff --git a/hemlock/bit-stream.lisp b/hemlock/bit-stream.lisp deleted file mode 100644 index 3aeebd36e8c0ea2779dda41d57cd824ac0a0e53d..0000000000000000000000000000000000000000 --- a/hemlock/bit-stream.lisp +++ /dev/null @@ -1,146 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Some stuff to make streams that write out on bitmap hunks. -;;; -;;; Written by Rob MacLachlan. -;;; Modified by Bill Chiles to run under X on the IBM RT. -;;; -(in-package 'hemlock-internals) - - -;;; These streams have an associated bitmap-hunk that is used for its -;;; font-family, foreground and background color, and X window pointer. -;;; The hunk need not be associated with any Hemlock window, and the low -;;; level painting routines that use hunk dimensions are not used for -;;; output. Only BITMAP-HUNK-WRITE-STRING is used. The hunk is not -;;; registered for any event service, so resizing the associated X window -;;; does not invoke the exposed/changed handler in Bit-Screen.Lisp; also, the -;;; hunk's input and changed handler slots are not set. -;;; -(defstruct (bitmap-hunk-output-stream (:include stream - (out #'bitmap-hunk-out) - (sout #'bitmap-hunk-sout) - (misc #'bitmap-hunk-misc)) - (:constructor - make-bitmap-hunk-output-stream (hunk))) - hunk ; bitmap-hunk we display on. - (cursor-x 0) ; Character position of output cursor. - (cursor-y 0) - (buffer (make-string hunk-width-limit) :type simple-string) - (old-bottom 0)) ; # of lines of scrolling before next "--More--" prompt. - -;;; Bitmap-Hunk-Stream-Newline -- Internal -;;; -;;; Flush the stream's output buffer and then move the cursor down -;;; or scroll the window up if there is no room left. -;;; -(defun bitmap-hunk-stream-newline (stream) - (let* ((hunk (bitmap-hunk-output-stream-hunk stream)) - (height (bitmap-hunk-char-height hunk)) - (y (bitmap-hunk-output-stream-cursor-y stream))) - (when (zerop (bitmap-hunk-output-stream-old-bottom stream)) - (hunk-write-string hunk 0 y "--More--" 0 8) - (let ((device (device-hunk-device hunk))) - (when (device-force-output device) - (funcall (device-force-output device)))) - (wait-for-more) - (hunk-clear-lines hunk y 1) - (setf (bitmap-hunk-output-stream-old-bottom stream) (1- height))) - (hunk-write-string hunk 0 y (bitmap-hunk-output-stream-buffer stream) 0 - (bitmap-hunk-output-stream-cursor-x stream)) - (setf (bitmap-hunk-output-stream-cursor-x stream) 0) - (decf (bitmap-hunk-output-stream-old-bottom stream)) - (incf y) - (when (= y height) - (decf y) - (hunk-copy-lines hunk 1 0 y) - (hunk-clear-lines hunk y 1)) - (setf (bitmap-hunk-output-stream-cursor-y stream) y))) - -;;; Bitmap-Hunk-Misc -- Internal -;;; -;;; This is the misc method for bitmap-hunk-output-streams. It just -;;; writes out the contents of the buffer, and does the element type. -;;; -(defun bitmap-hunk-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - (:charpos - (values (bitmap-hunk-output-stream-cursor-x stream) - (bitmap-hunk-output-stream-cursor-y stream))) - ((:finish-output :force-output) - (hunk-write-string (bitmap-hunk-output-stream-hunk stream) - 0 (bitmap-hunk-output-stream-cursor-y stream) - (bitmap-hunk-output-stream-buffer stream) 0 - (bitmap-hunk-output-stream-cursor-x stream)) - (let ((device (device-hunk-device (bitmap-hunk-output-stream-hunk stream)))) - (when (device-force-output device) - (funcall (device-force-output device))))) - (:line-length - (bitmap-hunk-char-width (bitmap-hunk-output-stream-hunk stream))) - (:element-type 'string-char))) - - -;;; Bitmap-Hunk-Out -- Internal -;;; -;;; Throw a character in a bitmap-hunk-stream's buffer. If we wrap or hit a -;;; newline then call bitmap-hunk-stream-newline. -;;; -(defun bitmap-hunk-out (stream character) - (let ((hunk (bitmap-hunk-output-stream-hunk stream)) - (x (bitmap-hunk-output-stream-cursor-x stream))) - (cond ((char= character #\newline) - (bitmap-hunk-stream-newline stream) - (return-from bitmap-hunk-out nil)) - ((= x (bitmap-hunk-char-width hunk)) - (setq x 0) - (bitmap-hunk-stream-newline stream))) - (setf (schar (bitmap-hunk-output-stream-buffer stream) x) character) - (setf (bitmap-hunk-output-stream-cursor-x stream) (1+ x)))) - - -;;; Bitmap-Hunk-Sout -- Internal -;;; -;;; Write a string out to a bitmap-hunk, calling ourself recursively if the -;;; string contains newlines. -;;; -(defun bitmap-hunk-sout (stream string start end) - (let* ((hunk (bitmap-hunk-output-stream-hunk stream)) - (buffer (bitmap-hunk-output-stream-buffer stream)) - (x (bitmap-hunk-output-stream-cursor-x stream)) - (dst-end (+ x (- end start))) - (width (bitmap-hunk-char-width hunk))) - (cond ((%primitive find-character string start end #\newline) - (do ((current (%primitive find-character string start end #\newline) - (%primitive find-character string (1+ current) - end #\newline)) - (previous start (1+ current))) - ((null current) - (bitmap-hunk-sout stream string previous end)) - (bitmap-hunk-sout stream string previous current) - (bitmap-hunk-stream-newline stream))) - ((> dst-end width) - (let ((new-start (+ start (- width x)))) - (%primitive byte-blt string start buffer x width) - (setf (bitmap-hunk-output-stream-cursor-x stream) width) - (bitmap-hunk-stream-newline stream) - (do ((idx (+ new-start width) (+ idx width)) - (prev new-start idx)) - ((>= idx end) - (let ((dst-end (- end prev))) - (%primitive byte-blt string prev buffer 0 dst-end) - (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end))) - (%primitive byte-blt string prev buffer 0 width) - (setf (bitmap-hunk-output-stream-cursor-x stream) width) - (bitmap-hunk-stream-newline stream)))) - (t - (%primitive byte-blt string start buffer x dst-end) - (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end))))) diff --git a/hemlock/bufed.lisp b/hemlock/bufed.lisp deleted file mode 100644 index 6c055095524d8683ff27e8bdb31f18e33cd7c1ee..0000000000000000000000000000000000000000 --- a/hemlock/bufed.lisp +++ /dev/null @@ -1,285 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains Bufed (Buffer Editing) code. -;;; - -(in-package "HEMLOCK") - - - -;;;; Representation of existing buffers. - -;;; This is the array of buffers in the bufed buffer. Each element is a cons, -;;; where the CAR is the buffer, and the CDR indicates whether the buffer -;;; should be deleted (t deleted, nil don't). -;;; -(defvar *bufed-buffers* nil) -(defvar *bufed-buffers-end* nil) -;;; -(defmacro bufed-buffer (x) `(car ,x)) -(defmacro bufed-buffer-deleted (x) `(cdr ,x)) -(defmacro make-bufed-buffer (buffer) `(list ,buffer)) - - -;;; This is the bufed buffer if it exists. -;;; -(defvar *bufed-buffer* nil) - -;;; This is the cleanup method for deleting *bufed-buffer*. -;;; -(defun delete-bufed-buffers (buffer) - (when (eq buffer *bufed-buffer*) - (setf *bufed-buffer* nil) - (setf *bufed-buffers* nil))) - - - -;;;; Commands. - -(defmode "Bufed" :major-p t - :documentation - "Bufed allows the user to quickly save, goto, delete, etc., his buffers.") - -(defhvar "Virtual Buffer Deletion" - "When set, \"Bufed Delete\" marks a buffer for deletion instead of immediately - deleting it." - :value t) - -(defhvar "Bufed Delete Confirm" - "When set, \"Bufed\" commands that actually delete buffers ask for - confirmation before taking action." - :value t) - -(defcommand "Bufed Delete" (p) - "Delete the buffer. - Any windows displaying this buffer will display some other buffer." - "Delete the buffer indicated by the current line. Any windows displaying this - buffer will display some other buffer." - (declare (ignore p)) - (let* ((point (current-point)) - (buf-info (array-element-from-mark point *bufed-buffers*))) - (if (and (not (value virtual-buffer-deletion)) - (or (not (value bufed-delete-confirm)) - (prompt-for-y-or-n :prompt "Delete buffer? " :default t - :must-exist t :default-string "Y"))) - (delete-bufed-buffer (bufed-buffer buf-info)) - (with-writable-buffer (*bufed-buffer*) - (setf (bufed-buffer-deleted buf-info) t) - (with-mark ((point point)) - (setf (next-character (line-start point)) #\D)))))) - -(defcommand "Bufed Undelete" (p) - "Undelete the buffer. - Any windows displaying this buffer will display some other buffer." - "Undelete the buffer. Any windows displaying this buffer will display some - other buffer." - (declare (ignore p)) - (with-writable-buffer (*bufed-buffer*) - (setf (bufed-buffer-deleted (array-element-from-mark - (current-point) *bufed-buffers*)) - nil) - (with-mark ((point (current-point))) - (setf (next-character (line-start point)) #\space)))) - -(defcommand "Bufed Expunge" (p) - "Expunge buffers marked for deletion." - "Expunge buffers marked for deletion." - (declare (ignore p)) - (expunge-bufed-buffers)) - -(defcommand "Bufed Quit" (p) - "Kill the bufed buffer, expunging any buffer marked for deletion." - "Kill the bufed buffer, expunging any buffer marked for deletion." - (declare (ignore p)) - (expunge-bufed-buffers) - (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))) - -;;; EXPUNGE-BUFED-BUFFERS deletes the marked buffers in the bufed buffer, -;;; signalling an error if the current buffer is not the bufed buffer. This -;;; returns t if it deletes some buffer, otherwise nil. We build a list of -;;; buffers before deleting any because the BUFED-DELETE-HOOK moves elements -;;; around in *bufed-buffers*. -;;; -(defun expunge-bufed-buffers () - (unless (eq *bufed-buffer* (current-buffer)) - (editor-error "Not in the Bufed buffer.")) - (let (buffers) - (dotimes (i *bufed-buffers-end*) - (let ((buf-info (svref *bufed-buffers* i))) - (when (bufed-buffer-deleted buf-info) - (push (bufed-buffer buf-info) buffers)))) - (if (and buffers - (or (not (value bufed-delete-confirm)) - (prompt-for-y-or-n :prompt "Delete buffers? " :default t - :must-exist t :default-string "Y"))) - (dolist (b buffers t) (delete-bufed-buffer b))))) - -(defun delete-bufed-buffer (buf) - (when (and (buffer-modified buf) - (prompt-for-y-or-n :prompt (list "~A is modified. Save it first? " - (buffer-name buf)))) - (save-file-command nil buf)) - (delete-buffer-if-possible buf)) - - -(defcommand "Bufed Goto" (p) - "Change to the buffer." - "Change to the buffer." - (declare (ignore p)) - (change-to-buffer - (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*)))) - -(defcommand "Bufed Goto and Quit" (p) - "Change to the buffer quitting Bufed. - This supplies a function for \"Generic Pointer Up\" which is a no-op." - "Change to the buffer quitting Bufed." - (declare (ignore p)) - (expunge-bufed-buffers) - (point-to-here-command nil) - (change-to-buffer - (bufed-buffer (array-element-from-pointer-pos *bufed-buffers* - "No buffer on that line."))) - (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)) - (supply-generic-pointer-up-function #'(lambda () nil))) - -(defcommand "Bufed Save File" (p) - "Save the buffer." - "Save the buffer." - (declare (ignore p)) - (save-file-command - nil - (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*)))) - -(defcommand "Bufed" (p) - "Creates a list of buffers in a buffer supporting operations such as deletion - and selection. If there already is a bufed buffer, just go to it." - "Creates a list of buffers in a buffer supporting operations such as deletion - and selection. If there already is a bufed buffer, just go to it." - (declare (ignore p)) - (let ((buf (or *bufed-buffer* - (make-buffer "Bufed" :modes '("Bufed") - :delete-hook (list #'delete-bufed-buffers))))) - - (unless *bufed-buffer* - (setf *bufed-buffer* buf) - (setf *bufed-buffers-end* - ;; -1 echo, -1 bufed. - (- (length (the list *buffer-list*)) 2)) - (setf *bufed-buffers* (make-array *bufed-buffers-end*)) - (setf (buffer-writable buf) t) - (with-output-to-mark (s (buffer-point buf)) - (let ((i 0)) - (do-strings (n b *buffer-names*) - (declare (simple-string n)) - (unless (or (eq b *echo-area-buffer*) - (eq b buf)) - (bufed-write-line b n s) - (setf (svref *bufed-buffers* i) (make-bufed-buffer b)) - (incf i))))) - (setf (buffer-writable buf) nil) - (setf (buffer-modified buf) nil) - (let ((fields (buffer-modeline-fields *bufed-buffer*))) - (setf (cdr (last fields)) - (list (or (modeline-field :bufed-cmds) - (make-modeline-field - :name :bufed-cmds :width 18 - :function - #'(lambda (buffer window) - (declare (ignore buffer window)) - " Type ? for help."))))) - (setf (buffer-modeline-fields *bufed-buffer*) fields)) - (buffer-start (buffer-point buf))) - (change-to-buffer buf))) - -(defun bufed-write-line (buffer name s - &optional (buffer-pathname (buffer-pathname buffer))) - (let ((modified (buffer-modified buffer))) - (write-string (if modified " *" " ") s) - (if buffer-pathname - (format s "~A ~A~:[~50T~A~;~]~%" - (file-namestring buffer-pathname) - (directory-namestring buffer-pathname) - (string= (pathname-to-buffer-name buffer-pathname) name) - name) - (write-line name s)))) - - -(defcommand "Bufed Help" (p) - "Show this help." - "Show this help." - (declare (ignore p)) - (describe-mode-command nil "Bufed")) - - - -;;;; Maintenance hooks. - -(eval-when (compile eval) -(defmacro with-bufed-point ((point buffer &optional pos) &rest body) - (let ((pos (or pos (gensym)))) - `(when (and *bufed-buffers* - (not (eq *bufed-buffer* ,buffer)) - (not (eq *echo-area-buffer* ,buffer))) - (let ((,pos (position ,buffer *bufed-buffers* :key #'car - :test #'eq :end *bufed-buffers-end*))) - (unless ,pos (error "Unknown Bufed buffer.")) - (let ((,point (buffer-point *bufed-buffer*))) - (unless (line-offset (buffer-start ,point) ,pos 0) - (error "Bufed buffer not displayed?")) - (with-writable-buffer (*bufed-buffer*) ,@body)))))) -) ;eval-when - - -(defun bufed-modified-hook (buffer modified) - (with-bufed-point (point buffer) - (setf (next-character (mark-after point)) (if modified #\* #\space)))) -;;; -(add-hook buffer-modified-hook 'bufed-modified-hook) - -(defun bufed-make-hook (buffer) - (declare (ignore buffer)) - (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))) -;;; -(add-hook make-buffer-hook 'bufed-make-hook) - -(defun bufed-delete-hook (buffer) - (with-bufed-point (point buffer pos) - (with-mark ((temp point :left-inserting)) - (line-offset temp 1) - (delete-region (region point temp))) - (let ((len-1 (1- *bufed-buffers-end*))) - (replace *bufed-buffers* *bufed-buffers* - :start1 pos :end1 len-1 - :start2 (1+ pos) :end1 *bufed-buffers-end*) - (setf (svref *bufed-buffers* len-1) nil) - (setf *bufed-buffers-end* len-1)))) -;;; -(add-hook delete-buffer-hook 'bufed-delete-hook) - -(defun bufed-name-hook (buffer name) - (with-bufed-point (point buffer) - (with-mark ((temp point :left-inserting)) - (line-offset temp 1) - (delete-region (region point temp))) - (with-output-to-mark (s point) - (bufed-write-line buffer name s)))) -;;; -(add-hook buffer-name-hook 'bufed-name-hook) - -(defun bufed-pathname-hook (buffer pathname) - (with-bufed-point (point buffer) - (with-mark ((temp point :left-inserting)) - (line-offset temp 1) - (delete-region (region point temp))) - (with-output-to-mark (s point) - (bufed-write-line buffer (buffer-name buffer) s pathname)))) -;;; -(add-hook buffer-pathname-hook 'bufed-pathname-hook) diff --git a/hemlock/buffer.lisp b/hemlock/buffer.lisp deleted file mode 100644 index bb36a49b781c00275b9f74b7871a2572bd44a249..0000000000000000000000000000000000000000 --- a/hemlock/buffer.lisp +++ /dev/null @@ -1,627 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; -;;; This file contains functions for changing modes and buffers. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(buffer-modified buffer-region buffer-name buffer-pathname - buffer-major-mode buffer-minor-mode buffer-modeline-fields - buffer-modeline-field-p current-buffer current-point - in-recursive-edit exit-recursive-edit abort-recursive-edit - recursive-edit defmode mode-major-p mode-variables mode-documentation - make-buffer delete-buffer with-writable-buffer buffer-start-mark - buffer-end-mark *buffer-list*)) - - - -;;;; Some buffer structure support. - -(defun buffer-writable (buffer) - "Returns whether buffer may be modified." - (buffer-%writable buffer)) - -(defun %set-buffer-writable (buffer value) - (invoke-hook ed::buffer-writable-hook buffer value) - (setf (buffer-%writable buffer) value)) - -;;; BUFFER-MODIFIED uses the buffer modification tick which is for redisplay. -;;; We can never set this down to "unmodify" a buffer, so we keep an -;;; unmodification tick. The buffer is modified only if this is less than the -;;; modification tick. -;;; -(defun buffer-modified (buffer) - "Return T if Buffer has been modified, NIL otherwise. Can be set with Setf." - (unless (bufferp buffer) (error "~S is not a buffer." buffer)) - (> (buffer-modified-tick buffer) (buffer-unmodified-tick buffer))) - -(defun %set-buffer-modified (buffer sense) - "If true make the buffer modified, if NIL unmodified." - (unless (bufferp buffer) (error "~S is not a buffer." buffer)) - (invoke-hook ed::buffer-modified-hook buffer sense) - (if sense - (setf (buffer-modified-tick buffer) (tick)) - (setf (buffer-unmodified-tick buffer) (tick))) - sense) - - -(proclaim '(inline buffer-name buffer-pathname buffer-region)) - -(defun buffer-region (buffer) - "Return the region which contains Buffer's text." - (buffer-%region buffer)) - -(defun %set-buffer-region (buffer new-region) - (let ((old (buffer-region buffer))) - (delete-region old) - (ninsert-region (region-start old) new-region) - old)) - -(defun buffer-name (buffer) - "Return Buffer's string name." - (buffer-%name buffer)) - -(proclaim '(special *buffer-names*)) - -(defun %set-buffer-name (buffer name) - (multiple-value-bind (entry foundp) (getstring name *buffer-names*) - (cond ((or (not foundp) (eq entry buffer)) - (invoke-hook ed::buffer-name-hook buffer name) - (delete-string (buffer-%name buffer) *buffer-names*) - (setf (getstring name *buffer-names*) buffer) - (setf (buffer-%name buffer) name)) - (t (error "Cannot rename buffer ~S to ~S. Name already in use." - buffer name))))) - -(defun buffer-pathname (buffer) - "Return a pathname for the file in Buffer. This is the truename - of the file as of the last time it was read or written." - (buffer-%pathname buffer)) - - -(defun %set-buffer-pathname (buffer pathname) - (invoke-hook ed::buffer-pathname-hook buffer pathname) - (setf (buffer-%pathname buffer) pathname)) - -(defun buffer-modeline-fields (window) - "Return a copy of the buffer's modeline fields list." - (do ((finfos (buffer-%modeline-fields window) (cdr finfos)) - (result () (cons (ml-field-info-field (car finfos)) result))) - ((null finfos) (nreverse result)))) - -(defun %set-buffer-modeline-fields (buffer fields) - (check-type fields list) - (check-type buffer buffer "a Hemlock buffer") - (sub-set-buffer-modeline-fields buffer fields) - (dolist (w (buffer-windows buffer)) - (update-modeline-fields buffer w))) - -(defun sub-set-buffer-modeline-fields (buffer modeline-fields) - (unless (every #'modeline-field-p modeline-fields) - (error "Fields must be a list of modeline-field objects.")) - (setf (buffer-%modeline-fields buffer) - (do ((fields modeline-fields (cdr fields)) - (res nil (cons (make-ml-field-info (car fields)) - res))) - ((null fields) (nreverse res))))) - -(defun buffer-modeline-field-p (buffer field) - "If field, a modeline-field or the name of one, is in buffer's list of - modeline-fields, it is returned; otherwise, nil." - (let ((finfo (internal-buffer-modeline-field-p buffer field))) - (if finfo (ml-field-info-field finfo)))) - -(defun internal-buffer-modeline-field-p (buffer field) - (let ((fields (buffer-%modeline-fields buffer))) - (if (modeline-field-p field) - (find field fields :test #'eq :key #'ml-field-info-field) - (find field fields - :key #'(lambda (f) - (modeline-field-name (ml-field-info-field f))))))) - - - -;;;; Variable binding -- winding and unwinding. - -(eval-when (compile eval) - -(defmacro unbind-variable-bindings (bindings) - `(do ((binding ,bindings (binding-across binding))) - ((null binding)) - (setf (car (binding-cons binding)) - (variable-object-down (binding-object binding))))) - -(defmacro bind-variable-bindings (bindings) - `(do ((binding ,bindings (binding-across binding))) - ((null binding)) - (let ((cons (binding-cons binding)) - (object (binding-object binding))) - (setf (variable-object-down object) (car cons) - (car cons) object)))) - -) ;eval-when - -;;; UNWIND-BINDINGS -- Internal -;;; -;;; Unwind buffer variable bindings and all mode bindings up to and -;;; including mode. Return a list of the modes unwound in reverse order. -;;; (buffer-mode-objects *current-buffer*) is clobbered. If "mode" is NIL -;;; unwind all bindings. -;;; -(defun unwind-bindings (mode) - (unbind-variable-bindings (buffer-var-values *current-buffer*)) - (do ((curmode (buffer-mode-objects *current-buffer*)) - (unwound ()) cw) - (()) - (setf cw curmode curmode (cdr curmode) (cdr cw) unwound unwound cw) - (unbind-variable-bindings (mode-object-var-values (car unwound))) - (when (or (null curmode) (eq (car unwound) mode)) - (setf (buffer-mode-objects *current-buffer*) curmode) - (return unwound)))) - -;;; WIND-BINDINGS -- Internal -;;; -;;; Add "modes" to the mode bindings currently in effect. -;;; -(defun wind-bindings (modes) - (do ((curmode (buffer-mode-objects *current-buffer*)) cw) - ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode)) - (bind-variable-bindings (mode-object-var-values (car modes))) - (setf cw modes modes (cdr modes) (cdr cw) curmode curmode cw)) - (bind-variable-bindings (buffer-var-values *current-buffer*))) - - - -;;;; BUFFER-MAJOR-MODE. - -(eval-when (compile eval) -(defmacro with-mode-and-buffer ((name major-p buffer) &body forms) - `(let ((mode (get-mode-object name))) - (setq ,name (mode-object-name mode)) - (,(if major-p 'unless 'when) (mode-object-major-p mode) - (error "~S is not a ~:[Minor~;Major~] Mode." ,name ,major-p)) - (check-type ,buffer buffer) - ,@forms)) -) ;eval-when - -;;; BUFFER-MAJOR-MODE -- Public -;;; -;;; The major mode is the first on the list, so just return that. -;;; -(defun buffer-major-mode (buffer) - "Return the name of Buffer's major mode. To change tha major mode - use Setf." - (check-type buffer buffer) - (car (buffer-modes buffer))) - -;;; %SET-BUFFER-MAJOR-MODE -- Public -;;; -;;; Unwind all modes in effect and add the major mode specified. -;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers -;;;other than the current buffer, and in the reverse order in the -;;;current buffer. -;;; -(defun %set-buffer-major-mode (buffer name) - "Set the major mode of some buffer to the Name'd mode." - (with-mode-and-buffer (name t buffer) - (invoke-hook ed::buffer-major-mode-hook buffer name) - (cond - ((eq buffer *current-buffer*) - (let ((old-mode (car (last (buffer-mode-objects buffer))))) - (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil) - (funcall (mode-object-cleanup-function old-mode) buffer) - (swap-char-attributes old-mode) - (wind-bindings (cons mode (cdr (unwind-bindings old-mode)))) - (swap-char-attributes mode))) - (t - (let ((old-mode (car (buffer-mode-objects buffer)))) - (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil) - (funcall (mode-object-cleanup-function old-mode) buffer)) - (setf (car (buffer-mode-objects buffer)) mode))) - (setf (car (buffer-modes buffer)) name) - (funcall (mode-object-setup-function mode) buffer) - (invoke-hook (%value (mode-object-hook-name mode)) buffer t)) - nil) - - - -;;;; BUFFER-MINOR-MODE. - -;;; BUFFER-MINOR-MODE -- Public -;;; -;;; Check if the mode-object is in the buffer's mode-list. -;;; -(defun buffer-minor-mode (buffer name) - "Return true if the minor mode named Name is active in Buffer. - A minor mode can be turned on or off with Setf." - (with-mode-and-buffer (name nil buffer) - (not (null (memq mode (buffer-mode-objects buffer)))))) - -(proclaim '(special *mode-names*)) - -;;; %SET-BUFFER-MINOR-MODE -- Public -;;; -;;; Activate or deactivate a minor mode, with due respect for -;;; bindings. -;;; -(defun %set-buffer-minor-mode (buffer name new-value) - (let ((objects (buffer-mode-objects buffer))) - (with-mode-and-buffer (name nil buffer) - (invoke-hook ed::buffer-minor-mode-hook buffer name new-value) - (cond - ;; Already there or not there, nothing to do. - ((if (memq mode (buffer-mode-objects buffer)) new-value (not new-value))) - ;; Adding a new mode. - (new-value - (cond - ((eq buffer *current-buffer*) - ;; - ;; Unwind bindings having higher precedence, cons on the new - ;; mode and then wind them back on again. - (do ((m objects (cdr m)) - (prev nil (car m))) - ((or (null (cdr m)) - (< (mode-object-precedence (car m)) - (mode-object-precedence mode))) - (wind-bindings - (cons mode (if prev - (unwind-bindings prev) - (unbind-variable-bindings - (buffer-var-values *current-buffer*)))))))) - (t - (do ((m (cdr objects) (cdr m)) - (prev objects m)) - ((or (null m) - (>= (mode-object-precedence (car m)) - (mode-object-precedence mode))) - (setf (cdr prev) (cons mode m)))))) - ;; - ;; Add the mode name. - (let ((bm (buffer-modes buffer))) - (setf (cdr bm) - (merge 'list (cdr bm) (list name) #'< :key - #'(lambda (x) - (mode-object-precedence (getstring x *mode-names*)))))) - - (funcall (mode-object-setup-function mode) buffer) - (invoke-hook (%value (mode-object-hook-name mode)) buffer t)) - (t - ;; Removing an active mode. - (invoke-hook (%value (mode-object-hook-name mode)) buffer nil) - (funcall (mode-object-cleanup-function mode) buffer) - ;; In the current buffer, unwind buffer and any mode bindings on top - ;; pop off the mode and wind the rest back on. - (cond ((eq buffer *current-buffer*) - (wind-bindings (cdr (unwind-bindings mode)))) - (t - (setf (buffer-mode-objects buffer) - (delq mode (buffer-mode-objects buffer))))) - ;; We always use the same string, so we can delq it (How Tense!) - (setf (buffer-modes buffer) (delq name (buffer-modes buffer)))))) - new-value)) - - - -;;;; CURRENT-BUFFER, CURRENT-POINT, and buffer using setup and cleanup. - -(proclaim '(inline current-buffer)) - -(defun current-buffer () "Return the current buffer object." *current-buffer*) - -(defun current-point () - "Return the Buffer-Point of the current buffer." - (buffer-point *current-buffer*)) - -;;; %SET-CURRENT-BUFFER -- Internal -;;; -;;; Undo previous buffer and mode specific variables and character -;;;attributes and set up the new ones. Set *current-buffer*. -;;; -(defun %set-current-buffer (buffer) - (let ((old-buffer *current-buffer*)) - (check-type buffer buffer) - (invoke-hook ed::set-buffer-hook buffer) - ;; Undo old bindings. - (setf (buffer-mode-objects *current-buffer*) - (unwind-bindings nil)) - (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) - (setq *current-buffer* buffer) - (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) - ;; Make new bindings. - (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil)) - (invoke-hook ed::after-set-buffer-hook old-buffer)) - buffer) - -;;; USE-BUFFER-SET-UP -- Internal -;;; -;;; This function is called by the use-buffer macro to wind on the -;;; new buffer's variable and key bindings and character attributes. -;;; -(defun use-buffer-set-up (old-buffer) - (unless (eq old-buffer *current-buffer*) - ;; Let new char attributes overlay old ones. - (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) - ;; Wind on bindings of new current buffer. - (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil)))) - -;;; USE-BUFFER-CLEAN-UP -- Internal -;;; -;;; This function is called by use-buffer to clean up after it is done. -;;; -(defun use-buffer-clean-up (old-buffer) - (unless (eq old-buffer *current-buffer*) - ;; When we leave, unwind the bindings, - (setf (buffer-mode-objects *current-buffer*) (unwind-bindings nil)) - ;; Restore the character attributes, - (swap-char-attributes (car (buffer-mode-objects *current-buffer*))))) - - - -;;;; Recursive editing. - -(defvar *in-a-recursive-edit* nil "True if we are in a recursive edit.") - -(proclaim '(inline in-recursive-edit)) - -(defun in-recursive-edit () - "Returns whether the calling point is dynamically within a recursive edit - context." - *in-a-recursive-edit*) - -;;; RECURSIVE-EDIT -- Public -;;; -;;; Call the command interpreter recursively, winding on new state as -;;; necessary. -;;; -(defun recursive-edit (&optional (handle-abort t)) - "Call the command interpreter recursively. If Handle-Abort is true - then an abort caused by a control-g or a lisp error does not cause - the recursive edit to be aborted." - (invoke-hook ed::enter-recursive-edit-hook) - (multiple-value-bind (flag args) - (let ((*in-a-recursive-edit* t)) - (catch 'leave-recursive-edit - (if handle-abort - (loop (catch 'editor-top-level-catcher - (%command-loop))) - (%command-loop)))) - (case flag - (:abort (apply #'editor-error args)) - (:exit (values-list args)) - (t (error "Bad thing ~S thrown out of recursive edit." flag))))) - -;;; EXIT-RECURSIVE-EDIT is intended to be called within the dynamic context -;;; of RECURSIVE-EDIT, causing return from that function with values returned -;;; as multiple values. When not in a recursive edit, signal an error. -;;; -(defun exit-recursive-edit (&optional values) - "Exit from a recursive edit. Values is a list of things which are - to be the return values from Recursive-Edit." - (unless *in-a-recursive-edit* - (error "Not in a recursive edit!")) - (invoke-hook ed::exit-recursive-edit-hook values) - (throw 'leave-recursive-edit (values :exit values))) - -;;; ABORT-RECURSIVE-EDIT is intended to be called within the dynamic context -;;; of RECURSIVE-EDIT, causing EDITOR-ERROR to be called on args. When not -;;; in a recursive edit, signal an error. -;;; -(defun abort-recursive-edit (&rest args) - "Abort a recursive edit, causing an Editor-Error with the args given in - the calling context." - (unless *in-a-recursive-edit* - (error "Not in a recursive edit!")) - (invoke-hook ed::abort-recursive-edit-hook args) - (throw 'leave-recursive-edit (values :abort args))) - - - -;;;; WITH-WRITABLE-BUFFER - -;;; This list indicates recursive use of WITH-WRITABLE-BUFFER on the same -;;; buffer. -;;; -(defvar *writable-buffers* ()) - -(defmacro with-writable-buffer ((buffer) &body body) - "Executes body in a scope where buffer is writable. After body executes, - this sets the buffer's modified and writable status to nil." - (let ((buf (gensym)) - (no-unwind (gensym))) - `(let* ((,buf ,buffer) - (,no-unwind (member ,buf *writable-buffers* :test #'eq)) - (*writable-buffers* (if ,no-unwind - *writable-buffers* - (cons ,buf *writable-buffers*)))) - (unwind-protect - (progn - (setf (buffer-writable ,buf) t) - ,@body) - (unless ,no-unwind - (setf (buffer-modified ,buf) nil) - (setf (buffer-writable ,buf) nil)))))) - - - -;;;; DEFMODE. - -(defun defmode (name &key (setup-function #'identity) - (cleanup-function #'identity) major-p transparent-p - precedence documentation) - "Define a new mode, specifying whether it is a major mode, and what the - setup and cleanup functions are. Precedence, which defaults to 0.0, and is - any integer or float, determines the order of the minor modes in a buffer. - A minor mode having a greater precedence is always considered before a mode - with lesser precedence when searching for key-bindings and variable values. - If Transparent-p is true, then all key-bindings local to the defined mode - are transparent, meaning that they do not shadow other bindings, but rather - are executed in addition to them. Documentation is used as introductory - text for mode describing commands." - (let ((hook-str (concatenate 'string name " Mode Hook")) - (mode (getstring name *mode-names*))) - (cond - (mode - (when (if major-p - (not (mode-object-major-p mode)) - (mode-object-major-p mode)) - (cerror "Let bad things happen" - "Mode ~S is being redefined as a ~:[Minor~;Major~] mode ~ - where it was ~%~ - previously a ~:*~:[Major~;Minor~] mode." name major-p)) - (warn "Mode ~S is being redefined, variables and bindings will ~ - be preserved." name) - (setq name (mode-object-name mode))) - (t - (defhvar hook-str - (concatenate 'string "This is the mode hook variable for " - name " Mode.")) - (setq mode (make-mode-object - :variables (make-string-table) - :bindings (make-key-table) - :hook-name (getstring hook-str *global-variable-names*))) - (setf (getstring name *mode-names*) mode))) - - (if precedence - (if major-p - (error "Precedence ~S is meaningless for a major mode." precedence) - (check-type precedence number)) - (setq precedence 0)) - - (setf (mode-object-major-p mode) major-p - (mode-object-documentation mode) documentation - (mode-object-transparent-p mode) transparent-p - (mode-object-precedence mode) precedence - (mode-object-setup-function mode) setup-function - (mode-object-cleanup-function mode) cleanup-function - (mode-object-name mode) name)) - nil) - -(defun mode-major-p (name) - "Returns T if Name is the name of a major mode, or NIL if is the name of - a minor mode." - (mode-object-major-p (get-mode-object name))) - -(defun mode-variables (name) - "Return the string-table that contains the names of the modes variables." - (mode-object-variables (get-mode-object name))) - -(defun mode-documentation (name) - "Returns the documentation for mode with name." - (mode-object-documentation (get-mode-object name))) - - - -;;;; Making and Deleting buffers. - -(defvar *buffer-list* () "A list of all the buffer objects.") - -(defvar *current-buffer* () - "Internal variable which might contain the current buffer." ) - -(defun make-buffer (name &key (modes (value ed::default-modes)) - (modeline-fields - (value ed::default-modeline-fields)) - delete-hook) - "Creates and returns a buffer with the given Name if a buffer with Name does - not already exist, otherwise returns nil. Modes is a list of mode names, - and Modeline-fields is a list of modeline field objects. Delete-hook is a - list of functions that take a buffer as the argument." - (cond ((getstring name *buffer-names*) nil) - (t - (unless (listp delete-hook) - (error ":delete-hook is a list of functions -- ~S." delete-hook)) - (let* ((region (make-empty-region)) - (object (getstring "Fundamental" *mode-names*)) - (buffer (internal-make-buffer - :%name name - :%region region - :modes (list (mode-object-name object)) - :mode-objects (list object) - :bindings (make-key-table) - :point (copy-mark (region-end region)) - :display-start (copy-mark (region-start region)) - :delete-hook delete-hook - :variables (make-string-table)))) - (sub-set-buffer-modeline-fields buffer modeline-fields) - (setf (line-%buffer (mark-line (region-start region))) buffer) - (push buffer *buffer-list*) - (setf (getstring name *buffer-names*) buffer) - (unless (equalp modes '("Fundamental")) - (setf (buffer-major-mode buffer) (car modes)) - (dolist (m (cdr modes)) - (setf (buffer-minor-mode buffer m) t))) - (invoke-hook ed::make-buffer-hook buffer) - buffer)))) - -(defun delete-buffer (buffer) - "Deletes a buffer. If buffer is current, or if it is displayed in any - windows, an error is signaled." - (when (eq buffer *current-buffer*) - (error "Cannot delete current buffer ~S." buffer)) - (when (buffer-windows buffer) - (error "Cannot delete buffer ~S, which is displayed in ~R window~:P." - buffer (length (buffer-windows buffer)))) - (invoke-hook (buffer-delete-hook buffer) buffer) - (invoke-hook ed::delete-buffer-hook buffer) - (setq *buffer-list* (delq buffer *buffer-list*)) - (delete-string (buffer-name buffer) *buffer-names*) - nil) - - - -;;;; Buffer start and end marks. - -(defun buffer-start-mark (buffer) - "Returns the buffer-region's start mark." - (region-start (buffer-region buffer))) - -(defun buffer-end-mark (buffer) - "Returns the buffer-region's end mark." - (region-end (buffer-region buffer))) - - - -;;;; Setting up initial buffer. - -;;; SETUP-INITIAL-BUFFER -- Internal -;;; -;;; Create the buffer "Main" and the mode "Fundamental". We make a -;;; dummy fundamental mode before we make the buffer Main, because -;;; "make-buffer" wants fundamental to be defined when it is called, and we -;;; can't make the real fundamental mode until there is a current buffer -;;; because "defmode" wants to invoke it's mode definition hook. Also, -;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet -;;; defined, so we supply this argument to MAKE-BUFFER as nil. This is -;;; fine since firing up the editor in a core must set the "Main" buffer's -;;; modeline according to this variable in case the user changed it in his -;;; init file. After the main buffer is created we then define the real -;;; fundamental mode and bash it into the buffer. -;;; -(defun setup-initial-buffer () - ;; Make it look like the mode is there so make-buffer doesn't die. - (setf (getstring "Fundamental" *mode-names*) - (make-mode-object :major-p t)) - ;; Make it look like there is a make-buffer-hook... - (setf (get 'ed::make-buffer-hook 'hemlock-variable-value) - (make-variable-object "foo" "bar")) - (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental") - :modeline-fields nil)) - ;; Make the bogus variable go away... - (remf (symbol-plist 'ed::make-buffer-hook) 'hemlock-variable-value) - ;; Make it go away so defmode doesn't die. - (setf (getstring "Fundamental" *mode-names*) nil) - (defmode "Fundamental" :major-p t) - ;; Bash the real mode object into the buffer. - (let ((obj (getstring "Fundamental" *mode-names*))) - (setf (car (buffer-mode-objects *current-buffer*)) obj - (car (buffer-modes *current-buffer*)) (mode-object-name obj)))) diff --git a/hemlock/charmacs.lisp b/hemlock/charmacs.lisp deleted file mode 100644 index 204fc109c72a4eead84f86196928858e1c2dd9db..0000000000000000000000000000000000000000 --- a/hemlock/charmacs.lisp +++ /dev/null @@ -1,204 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Implementation specific character-hacking macros and constants. -;;; -(in-package 'hemlock-internals) -(export ' (syntax-char-code-limit command-char-bits-limit - command-char-code-limit search-char-code-limit - do-alpha-chars)) - -;;; This file contains various constants and macros which are -;;; implementation or ASCII dependant. In particular it contains -;;; all the character implementation parameters such as -;;; Command-Char-Bits-Limit, and contains various versions -;;; of char-code which don't check types and omit the top bit -;;; so that various structures can be allocated 128 long instead -;;; of 256, and we don't get errors if a loser visits a binary file. - -;;; There are so many different constants and macros that do the same -;;; thing because in principle the char-code-limit for the syntax -;;; functions is independant of that for the searching functions, etc. - -;;; This file also contains code which adds any implementation specific -;;; character names to the char file's Char-Name-Alist so that there -;;; is a reasonable read-syntax and print-representation for all -;;; characters a user might run across. - - -;;; All the meaningful bit names in this implementation. -;;; -(defconstant all-bit-names '(:control :meta :super :hyper)) - - -;;;; Stuff for the Syntax table functions (syntax) -;;; -(defconstant syntax-char-code-limit 128 - "The highest char-code which a character argument to the syntax - table functions may have.") -(defconstant syntax-char-code-mask #x+7f - "Mask we AND with characters given to syntax table functions to blow away - bits we don't want.") -(defmacro syntax-char-code (char) - `(logand syntax-char-code-mask (lisp::%sp-make-fixnum ,char))) - -;;;; Stuff for the command interpreter (interp) -;;; -;;; On the Perq we have bits for command bindings, on the VAX there -;;; aren't. The code to interpret them is conditionally compiled -;;; so that the VAX isnt't slowed down. -;;; -;;; Make command-char-code-limit 256 instead of 128 for X keyboard scan-codes. -(defconstant command-char-code-limit 256 - "The upper bound on character codes supported for key bindings.") -(defconstant command-char-bits-limit 16 - "The maximum value of character bits supported for key bindings.") -(defmacro key-char-bits (char) - `(ash (logand #x+F00 (lisp::%sp-make-fixnum ,char)) -8)) -(defmacro key-char-code (char) - `(char-code ,char)) -;;; `(logand #x+7f (lisp::%sp-make-fixnum ,char))) can't use with X scan-codes. - - -;;;; Stuff used by the searching primitives (search) -;;; -(defconstant search-char-code-limit 128 - "The exclusive upper bound on significant char-codes for searching.") -(defmacro search-char-code (ch) - `(logand (lisp::%sp-make-fixnum ,ch) #x+7F)) -;;; -;;; search-hash-code must be a function with the following properties: -;;; given any character it returns a number between 0 and -;;; search-char-code-limit, and the same hash code must be returned -;;; for the upper and lower case forms of each character. -;;; In ASCII this is can be done by ANDing out the 5'th bit. -;;; -(defmacro search-hash-code (ch) - `(logand (lisp::%sp-make-fixnum ,ch) #x+5F)) - -;;; Doesn't do anything special, but it should fast and not waste any time -;;; checking type and whatnot. -(defmacro search-char-upcase (ch) - `(lisp::fast-char-upcase ,ch)) - - -;;; Specal RT and Sun keys: - -(eval-when (compile load eval) - -(push (cons "DELETE" #\delete) lisp::char-name-alist) -(push (cons "ESCAPE" #\escape) lisp::char-name-alist) -(push (cons "F1" (code-char 1)) lisp::char-name-alist) -(push (cons "F2" (code-char 2)) lisp::char-name-alist) -(push (cons "F3" (code-char 3)) lisp::char-name-alist) -(push (cons "F4" (code-char 4)) lisp::char-name-alist) -(push (cons "F5" (code-char 5)) lisp::char-name-alist) -(push (cons "F6" (code-char 6)) lisp::char-name-alist) -(push (cons "F7" (code-char 7)) lisp::char-name-alist) -(push (cons "F8" (code-char 11)) lisp::char-name-alist) -(push (cons "F9" (code-char 12)) lisp::char-name-alist) -(push (cons "F10" (code-char 14)) lisp::char-name-alist) -(push (cons "F11" (code-char 17)) lisp::char-name-alist) -(push (cons "F12" (code-char 18)) lisp::char-name-alist) -(push (cons "LEFTARROW" (code-char 19)) lisp::char-name-alist) -(push (cons "RIGHTARROW" (code-char 20)) lisp::char-name-alist) -(push (cons "UPARROW" (code-char 22)) lisp::char-name-alist) -(push (cons "DOWNARROW" (code-char 23)) lisp::char-name-alist) -(push (cons "LEFTDOWN" (code-char 24)) lisp::char-name-alist) -(push (cons "MIDDLEDOWN" (code-char 25)) lisp::char-name-alist) -(push (cons "RIGHTDOWN" (code-char 128)) lisp::char-name-alist) -(push (cons "LEFTUP" (code-char 129)) lisp::char-name-alist) -(push (cons "MIDDLEUP" (code-char 130)) lisp::char-name-alist) -(push (cons "RIGHTUP" (code-char 131)) lisp::char-name-alist) -(push (cons "INSERT" (code-char 132)) lisp::char-name-alist) -(push (cons "PRINTSCREEN" (code-char 133)) lisp::char-name-alist) -(push (cons "PAUSE" (code-char 134)) lisp::char-name-alist) -(push (cons "HOME" (code-char 135)) lisp::char-name-alist) -(push (cons "END" (code-char 136)) lisp::char-name-alist) -(push (cons "PAGEUP" (code-char 137)) lisp::char-name-alist) -(push (cons "PAGEDOWN" (code-char 138)) lisp::char-name-alist) -(push (cons "NUMLOCK" (code-char 139)) lisp::char-name-alist) -(push (cons "F13" (code-char 140)) lisp::char-name-alist) -(push (cons "F14" (code-char 141)) lisp::char-name-alist) -(push (cons "F15" (code-char 142)) lisp::char-name-alist) -(push (cons "F16" (code-char 143)) lisp::char-name-alist) -(push (cons "F17" (code-char 144)) lisp::char-name-alist) -(push (cons "F18" (code-char 145)) lisp::char-name-alist) -(push (cons "F19" (code-char 146)) lisp::char-name-alist) -(push (cons "F20" (code-char 147)) lisp::char-name-alist) -(push (cons "F21" (code-char 148)) lisp::char-name-alist) -(push (cons "F22" (code-char 149)) lisp::char-name-alist) -(push (cons "F23" (code-char 150)) lisp::char-name-alist) -(push (cons "F24" (code-char 151)) lisp::char-name-alist) -(push (cons "F25" (code-char 152)) lisp::char-name-alist) -(push (cons "F26" (code-char 153)) lisp::char-name-alist) -(push (cons "F27" (code-char 154)) lisp::char-name-alist) -(push (cons "F28" (code-char 155)) lisp::char-name-alist) -(push (cons "F29" (code-char 156)) lisp::char-name-alist) -(push (cons "F30" (code-char 157)) lisp::char-name-alist) -(push (cons "F31" (code-char 158)) lisp::char-name-alist) -(push (cons "F32" (code-char 159)) lisp::char-name-alist) -(push (cons "F33" (code-char 160)) lisp::char-name-alist) -(push (cons "F34" (code-char 161)) lisp::char-name-alist) -(push (cons "F35" (code-char 162)) lisp::char-name-alist) -;; ALTERNATE key on Sun keyboard. -(push (cons "BREAK" (code-char 163)) lisp::char-name-alist) - -) ;eval-when (compile load eval) - -;;; Stick them on the end so that they don't print this way. -;;; Use two separate EVAL-WHEN forms, so the #\f<13-35> characters can be -;;; read at this point. -;;; -(eval-when (compile load eval) -(setq lisp::char-name-alist - (append lisp::char-name-alist - '(("ENTER" . #\return) ("ACTION" . #\linefeed) - - ("L1" . #\F11) ("L2" . #\F12) ("L3" . #\F13) ("L4" . #\F14) - ("L5" . #\F15) ("L6" . #\F16) ("L7" . #\F17) ("L8" . #\F18) - ("L9" . #\F19) ("L10" . #\F20) - - ("R1" . #\F21) ("R2" . #\F22) ("R3" . #\F23) ("R4" . #\F24) - ("R5" . #\F25) ("R6" . #\F26) ("R7" . #\F27) ("R8" . #\F28) - ("R9" . #\F29) ("R10" . #\F30) ("R11" . #\F31) ("R12" . #\F32) - ("R13" . #\F33) ("R14" . #\F34) ("R15" . #\F35)))) -) ;eval-when - - -;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var -;;; to the alphabetic characters and executing body. Note that the manual -;;; guarantees lower and upper case char codes to be separately in order, -;;; but other characters may be interspersed within that ordering. -(defmacro alpha-chars-loop (var start-char end-char result body) - (let ((n (gensym)) - (end-char-code (gensym))) - `(do ((,n (char-code ,start-char) (1+ ,n)) - (,end-char-code (char-code ,end-char))) - ((> ,n ,end-char-code) ,result) - (let ((,var (code-char ,n))) - (when (alpha-char-p ,var) - ,@body))))) - -(defmacro do-alpha-chars ((var kind &optional result) &rest forms) - "(do-alpha-chars (var kind [result]) . body). Kind is one of - :lower, :upper, or :both, and var is bound to each character in - order as specified under character relations in the manual. When - :both is specified, lowercase letters are processed first." - (case kind - (:both - `(progn (alpha-chars-loop ,var #\a #\z nil ,forms) - (alpha-chars-loop ,var #\A #\Z ,result ,forms))) - (:lower - `(alpha-chars-loop ,var #\a #\z ,result ,forms)) - (:upper - `(alpha-chars-loop ,var #\A #\Z ,result ,forms)) - (t (error "Kind argument not one of :lower, :upper, or :both -- ~S." - kind)))) diff --git a/hemlock/command.lisp b/hemlock/command.lisp deleted file mode 100644 index 2e367549430cabb06e480fcf480c77490074e4db..0000000000000000000000000000000000000000 --- a/hemlock/command.lisp +++ /dev/null @@ -1,464 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the definitions for the basic Hemlock commands. -;;; - -(in-package "HEMLOCK") - - -;;; Make a mark for buffers as they're consed: - -(defun hcmd-new-buffer-hook-fun (buff) - (let ((ring (make-ring 10 #'delete-mark))) - (defhvar "Buffer Mark Ring" - "This variable holds this buffer's mark ring." - :buffer buff - :value ring) - (ring-push (copy-mark (buffer-point buff) :right-inserting) ring))) - -(add-hook make-buffer-hook #'hcmd-new-buffer-hook-fun) -(dolist (buff *buffer-list*) (hcmd-new-buffer-hook-fun buff))) - -(defcommand "Exit Hemlock" (p) - "Exit hemlock returning to the Lisp top-level read-eval-print loop." - "Exit hemlock returning to the Lisp top-level read-eval-print loop." - (declare (ignore p)) - (exit-hemlock)) - -(defcommand "Pause Hemlock" (p) - "Pause the Hemlock/Lisp process returning to the process that invoked the - Lisp." - "Pause the Hemlock/Lisp process returning to the process that invoked the - Lisp." - (declare (ignore p)) - (pause-hemlock)) - - - -;;;; Simple character manipulation: - -(defcommand "Self Insert" (p) - "Insert the last character typed. - With prefix argument insert the character that many times." - "Implements ``Self Insert'', calling this function is not meaningful." - (let ((char (text-character *last-character-typed*))) - (unless char (editor-error "Can't insert that character.")) - (if (and p (> p 1)) - (insert-string - (current-point) - (make-string p :initial-element char)) - (insert-character (current-point) char)))) - -(defcommand "Quoted Insert" (p) - "Read a character from the terminal and insert it. - With prefix argument, insert the character that many times." - "Reads a character from *editor-input* and inserts it at the point." - (let ((char (text-character (read-char *editor-input* nil))) - (point (current-point))) - (unless char (editor-error "Can't insert that character.")) - (if (and p (> p 1)) - (insert-string point (make-string p :initial-element char)) - (insert-character point char)))) - -(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." - (let ((p (or p 1))) - (cond ((character-offset (current-point) p)) - ((= p 1) - (editor-error "No next character.")) - ((= p -1) - (editor-error "No previous character.")) - (t - (if (plusp p) - (buffer-end (current-point)) - (buffer-start (current-point))) - (editor-error "Not enough characters."))))) - -(defcommand "Backward Character" (p) - "Move the point backward one character. - With prefix argument move that many characters backward." - "Move the point p characters backward." - (forward-character-command (if p (- p) -1))) - -#| -(defcommand "Delete Next Character" (p) - "Deletes the character to the right of the point. - With prefix argument, delete that many characters to the right - (or left if prefix is negative)." - "Deletes p characters to the right of the point." - (unless (delete-characters (current-point) (or p 1)) - (buffer-end (current-point)) - (editor-error "No next character."))) - -(defcommand "Delete Previous Character" (p) - "Deletes the character to the left of the point. - With prefix argument, delete that many characters to the left - (or right if prefix is negative)." - "Deletes p characters to the left of the point." - (unless (delete-characters (current-point) (if p (- p) -1)) - (editor-error "No previous character."))) -|# - -(defcommand "Delete Next Character" (p) - "Deletes the character to the right of the point. - With prefix argument, delete that many characters to the right - (or left if prefix is negative)." - "Deletes p characters to the right of the point." - (cond ((kill-characters (current-point) (or p 1))) - ((and p (minusp p)) - (editor-error "Not enough previous characters.")) - (t - (editor-error "Not enough next characters.")))) - -(defcommand "Delete Previous Character" (p) - "Deletes the character to the left of the point. - Will push characters from successive deletes on to the kill ring." - "Deletes the character to the left of the point. - Will push characters from successive deletes on to the kill ring." - (delete-next-character-command (- (or p 1)))) - -(defcommand "Transpose Characters" (p) - "Exchanges the characters on either side of the point and moves forward - With prefix argument, does this that many times. A negative prefix - argument causes the point to be moved backwards instead of forwards." - "Exchanges the characters on either side of the point and moves forward." - (let ((arg (or p 1)) - (point (current-point))) - (dotimes (i (abs arg)) - (when (or (minusp arg) (end-line-p point)) (mark-before point)) - (let ((prev (previous-character point)) - (next (next-character point))) - (cond ((not prev) (editor-error "No previous character.")) - ((not next) (editor-error "No next character.")) - (t - (setf (previous-character point) next) - (setf (next-character point) prev)))) - (when (plusp arg) (mark-after point))))) - -;;;; Word hacking commands: - -;;; WORD-OFFSET -;;; -;;; Move a mark forward/backward some words. -;;; -(defun word-offset (mark offset) - "Move Mark by Offset words." - (if (minusp offset) - (do ((cnt offset (1+ cnt))) - ((zerop cnt) mark) - (cond - ((null (reverse-find-attribute mark :word-delimiter #'zerop)) - (return nil)) - ((reverse-find-attribute mark :word-delimiter)) - (t - (move-mark - mark (buffer-start-mark (line-buffer (mark-line mark))))))) - (do ((cnt offset (1- cnt))) - ((zerop cnt) mark) - (cond - ((null (find-attribute mark :word-delimiter #'zerop)) - (return nil)) - ((null (find-attribute mark :word-delimiter)) - (return nil)))))) - -(defcommand "Forward Word" (p) - "Moves forward one word. - With prefix argument, moves the point forward over that many words." - "Moves the point forward p words." - (cond ((word-offset (current-point) (or p 1))) - ((and p (minusp p)) - (buffer-start (current-point)) - (editor-error "No previous word.")) - (t - (buffer-end (current-point)) - (editor-error "No next word.")))) - -(defcommand "Backward Word" (p) - "Moves forward backward word. - With prefix argument, moves the point back over that many words." - "Moves the point backward p words." - (forward-word-command (- (or p 1)))) - - - -;;;; Moving around: - -(defvar *target-column* 0) - -(defun set-target-column (mark) - (if (eq (last-command-type) :line-motion) - *target-column* - (setq *target-column* (mark-column mark)))) - -(defcommand "Next Line" (p) - "Moves the point to the next line. - With prefix argument, moves the point that many lines down (or up if - the prefix is negative)." - "Moves the down p lines." - (let* ((point (current-point)) - (target (set-target-column point))) - (unless (line-offset point (or p 1)) - (cond ((not p) - (when (same-line-p point (buffer-end-mark (current-buffer))) - (line-end point)) - (insert-character point #\newline)) - ((minusp p) - (buffer-start point) - (editor-error "No previous line.")) - (t - (buffer-end point) - (when p (editor-error "No next line."))))) - (unless (move-to-column point target) (line-end point)) - (setf (last-command-type) :line-motion))) - - -(defcommand "Previous Line" (p) - "Moves the point to the previous line. - With prefix argument, moves the point that many lines up (or down if - the prefix is negative)." - "Moves the point up p lines." - (next-line-command (- (or p 1)))) - -(defcommand "Mark to End of Buffer" (p) - "Sets the current region from point to the end of the buffer." - "Sets the current region from point to the end of the buffer." - (declare (ignore p)) - (push-buffer-mark (buffer-end (copy-mark (current-point))) t)) - -(defcommand "Mark to Beginning of Buffer" (p) - "Sets the current region from the beginning of the buffer to point." - "Sets the current region from the beginning of the buffer to point." - (declare (ignore p)) - (push-buffer-mark (buffer-start (copy-mark (current-point))) t)) - -(defcommand "Beginning of Buffer" (p) - "Moves the point to the beginning of the current buffer." - "Moves the point to the beginning of the current buffer." - (declare (ignore p)) - (let ((point (current-point))) - (push-buffer-mark (copy-mark point)) - (buffer-start point))) - -(defcommand "End of Buffer" (p) - "Moves the point to the end of the current buffer." - "Moves the point to the end of the current buffer." - (declare (ignore p)) - (let ((point (current-point))) - (push-buffer-mark (copy-mark point)) - (buffer-end point))) - -(defcommand "Beginning of Line" (p) - "Moves the point to the beginning of the current line. - With prefix argument, moves the point to the beginning of the prefix'th - next line." - "Moves the point down p lines and then to the beginning of the line." - (let ((point (current-point))) - (unless (line-offset point (if p p 0)) (editor-error "No such line.")) - (line-start point))) - -(defcommand "End of Line" (p) - "Moves the point to the end of the current line. - With prefix argument, moves the point to the end of the prefix'th next line." - "Moves the point down p lines and then to the end of the line." - (let ((point (current-point))) - (unless (line-offset point (if p p 0)) (editor-error "No such line.")) - (line-end point))) - -(defhvar "Scroll Overlap" - "The \"Scroll Window\" commands leave this much overlap between screens." - :value 2) - -(defhvar "Scroll Redraw Ratio" - "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 line \"New Line\" and \"Open Line\" will still - efficiently, insert a line moving the rest of the window's text downward." - :value nil) - - "This is a cut-off point at which the insert/delete line terminal optimization - will not be used (in number of lines). For example, if the value is non-nil, - and that number (or more) of lines wants to be inserted or deleted from the - screen, then redisplay will simply paint the entire screen from the first - altered line down." - :value nil) - -(defcommand "Scroll Window Down" (p &optional (window (current-window))) - "Move down one screenfull. - With prefix argument scroll down that many lines." - "If P is NIL then scroll Window, which defaults to the current - window, down one screenfull. If P is supplied then scroll that - many lines." - (if p - (scroll-window window p) - (let ((height (window-height window)) - (overlap (value scroll-overlap))) - (scroll-window window (if (<= height overlap) - height (- height overlap)))))) - -(defcommand "Scroll Window Up" (p &optional (window (current-window))) - "Move up one screenfull. - With prefix argument scroll up that many lines." - "If P is NIL then scroll Window, which defaults to the current - window, up one screenfull. If P is supplied then scroll that - many lines." - (if p - (scroll-window window (- p)) - (let ((height (- (window-height window))) - (overlap (- (value scroll-overlap)))) - (scroll-window window (if (>= height overlap) - height (- height overlap)))))) - -(defcommand "Scroll Next Window Down" (p) - "Do a \"Scroll Window Down\" on the next window." - "Do a \"Scroll Window Down\" on the next window." - (let ((win (next-window (current-window)))) - (when (eq win (current-window)) (editor-error "Only one window.")) - (scroll-window-down-command p win))) - -(defcommand "Scroll Next Window Up" (p) - "Do a \"Scroll Window Up\" on the next window." - "Do a \"Scroll Window Up\" on the next window." - (let ((win (next-window (current-window)))) - (when (eq win (current-window)) (editor-error "Only one window.")) - (scroll-window-up-command p win))) - -(defcommand "Top of Window" (p) - "Move the point to the top of the current window. - The point is left before the first character displayed in the window." - "Move the point to the top of the current window." - (declare (ignore p)) - (move-mark (current-point) (window-display-start (current-window)))) - -(defcommand "Bottom of Window" (p) - "Move the point to the bottom of the current window. - The point is left at the start of the bottom line." - "Move the point to the bottom of the current window." - (declare (ignore p)) - (line-start (current-point) - (mark-line (window-display-end (current-window))))) - -;;;; Kind of miscellaneous commands: - -;;; "Refresh Screen" may not be right with respect to wrapping lines in -;;; the case where an argument is supplied due the use of -;;; WINDOW-DISPLAY-START instead of SCROLL-WINDOW, but using the latter -;;; messed with point and did other hard to predict stuff. -;;; -(defcommand "Refresh Screen" (p) - "Refreshes everything in the window, centering current line. - Given an argument, scroll that many lines." - "Refreshes everything in the window, centering current line. - Given an argument, scroll that many lines." - (let ((window (current-window))) - (cond ((not p) (center-window window (current-point))) - ((zerop p) (line-to-top-of-window-command nil)) - ((line-offset (window-display-start window) - (if (plusp p) (1- p) (1+ p)) - 0)) - (t (editor-error "Not enough lines.")))) - (unless p (redisplay-all))) - -(defcommand "Extended Command" (p) - "Prompts for and executes an extended command." - "Prompts for and executes an extended command. The prefix argument is - passed to the command." - (let* ((name (prompt-for-keyword (list *command-names*) - :prompt "Extended Command: " - :help "Name of a Hemlock command")) - (function (command-function (getstring name *command-names*)))) - (funcall function p))) - -(defhvar "Universal Argument Default" - "Default value for \"Universal Argument\" command." - :value 4) - -(defcommand "Universal Argument" (p) - "Sets prefix argument for next command. - Typing digits, regardless of any modifier keys, specifies the argument. - Optionally, you may first type a sign (- or +). While typing digits, if you - type C-U or C-u, the digits following the C-U form a number this command - multiplies by the digits preceding the C-U. The default value for this - command and any number following a C-U is the value of \"Universal Argument - Default\"." - "You probably don't want to use this as a function." - (declare (ignore p)) - (clear-echo-area) - (write-string "C-U " *echo-area-stream*) - (let ((char (read-char *editor-input*))) - (multiple-value-call #'universal-argument-loop - (case (char-code char) - (#.(char-code #\-) - (write-char #\- *echo-area-stream*) - (values (read-char *editor-input*) -1)) - (#.(char-code #\+) ;Just in case. - (write-char #\+ *echo-area-stream*) - (values (read-char *editor-input*) 1)) - (t (values char 1)))))) - -(defcommand "Negative Argument" (p) - "This command is equivalent to invoking \"Universal Argument\" and typing - a minus sign (-). It waits for more digits and a command to which to give - the prefix argument." - "Don't call this as a function." - (when p (editor-error "Must type minus sign first.")) - (clear-echo-area) - (write-string "C-U -" *echo-area-stream*) - (universal-argument-loop (read-char *editor-input*) -1)) - -(defcommand "Argument Digit" (p) - "This command is equivalent to invoking \"Universal Argument\" and typing - the digit used to invoke this command. It waits for more digits and a - command to which to give the prefix argument." - "Don't call this as a function." - (declare (ignore p)) - (clear-echo-area) - (write-string "C-U " *echo-area-stream*) - (universal-argument-loop *last-character-typed* 1)) - -(defun universal-argument-loop (char sign &optional (multiplier 1)) - (flet ((prefix (sign multiplier read-some-digit-p result) - ;; read-some-digit-p and (zerop result) are not - ;; equivalent if the user invokes this and types 0. - (* sign multiplier - (if read-some-digit-p - result - (value universal-argument-default))))) - (let* ((display-char (make-char char)) - (digit (digit-char-p display-char)) - (result 0) - (read-some-digit-p nil)) - (loop - (cond (digit - (setf read-some-digit-p t) - (write-char display-char *echo-area-stream*) - (setq result (+ digit (* 10 result))) - (setf char (read-char *editor-input*)) - (setf display-char (make-char char)) - (setf digit (digit-char-p display-char))) - ((or (char= char #\c-u) (char= char #\c-\u)) - (write-string " C-U " *echo-area-stream*) - (universal-argument-loop - (read-char *editor-input*) 1 - (prefix sign multiplier read-some-digit-p result)) - (return)) - (t - (unread-char char *editor-input*) - (setf (prefix-argument) - (prefix sign multiplier read-some-digit-p result)) - (return)))))) - (setf (last-command-type) (last-command-type))) diff --git a/hemlock/comments.lisp b/hemlock/comments.lisp deleted file mode 100644 index eac71d606c460a024dd0166f48b9f9202c3a1e2b..0000000000000000000000000000000000000000 --- a/hemlock/comments.lisp +++ /dev/null @@ -1,407 +0,0 @@ -;;; -*- Log: Hemlock.Log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; -;;; This file contains the implementation of comment commands. - -(in-package 'hemlock) - - - -;;;; -- Variables -- - -(defhvar "Comment Column" - "Colmun to start comments in." - :value 0) - -(defhvar "Comment Start" - "String that indicates the start of a comment." - :value nil) - -(defhvar "Comment End" - "String that ends comments. Nil indicates #\newline termination." - :value nil) - -(defhvar "Comment Begin" - "String that is inserted to begin a comment." - :value nil) - - -;;;; -- Internal Specials -- - -;;; For the search pattern state specials, we just use " " as the comment -;;; start and end if none exist, so we are able to make search patterns. -;;; This is reasonable since any use of these will cause the patterns to be -;;; made consistent with the actual start and end strings. - -(defvar *comment-start-pattern* - (new-search-pattern :string-insensitive :forward (or (value comment-start) " ")) - "Search pattern to keep around for looking for comment starts.") - -(defvar *last-comment-start* - (or (value comment-start) " ") - "Previous comment start used to make *comment-start-pattern*.") - -(defvar *comment-end-pattern* - (new-search-pattern :string-insensitive :forward (or (value comment-end) " ")) - "Search pattern to keep around for looking for comment ends.") - -(defvar *last-comment-end* - (or (value comment-end) " ") - "Previous comment end used to make *comment-end-pattern*.") - - -(eval-when (compile eval) -(defmacro get-comment-pattern (string kind) ;kind is either :start or :end - (let (pattern-var last-var) - (cond ((eq kind :start) - (setf pattern-var '*comment-start-pattern*) - (setf last-var '*last-comment-start*)) - (t (setf pattern-var '*comment-end-pattern*) - (setf last-var '*last-comment-end*))) - `(cond ((string= (the simple-string ,string) (the simple-string ,last-var)) - ,pattern-var) - (t (setf ,last-var ,string) - (new-search-pattern :string-insensitive :forward - ,string ,pattern-var))))) -) ;eval-when - - - -;;;; -- Commands -- - -(defcommand "Set Comment Column" (p) - "Set Comment Column to current column or argument. - If argument is provided use its absolute value." - "Set Comment Column to current column or argument. - If argument is provided use its absolute value." - (let ((new-column (or (and p (abs p)) - (mark-column (current-point))))) - (defhvar "Comment Column" "This buffer's column to start comments." - :value new-column :buffer (current-buffer)) - (message "Comment Column = ~D" new-column))) - - -(defcommand "Indent for Comment" (p) - "Move to or create a comment. Moves to the start of an existing comment - and indents it to start in Comment Column. An existing double semicolon - comment is aligned like a line of code. An existing triple semicolon - comment or any that start in column 0 is not moved. With argument, - aligns any comments on the next argument lines but does not create any. - If characters extend past comment column, a space is added before - starting comment." - "Create comment or move to beginning of existing one aligning it." - (let* ((column (value comment-column)) - (start (value comment-start)) - (begin (value comment-begin)) - (end (value comment-end))) - (unless (stringp start) (editor-error "No comment start string -- ~S." start)) - (indent-for-comment (current-point) column start begin end (or p 1)))) - - -(defcommand "Up Comment Line" (p) - "Equivalent to Previous Line followed by Indent for Comment (C-P ALT-;)." - "Equivalent to Previous Line followed by Indent for Comment (C-P ALT-;)." - (let ((column (value comment-column)) - (start (value comment-start)) - (begin (value comment-begin)) - (end (value comment-end))) - (unless (stringp start) (editor-error "No comment start string -- ~S." start)) - (change-comment-line (current-point) column start - begin end (or (and p (- p)) -1)))) - -(defcommand "Down Comment Line" (p) - "Equivalent to Next Line followed by Indent for Comment (C-N ALT-;)." - "Equivalent to Next Line followed by Indent for Comment (C-N ALT-;)." - (let ((column (value comment-column)) - (start (value comment-start)) - (begin (value comment-begin)) - (end (value comment-end))) - (unless (stringp start) (editor-error "No comment start string -- ~S." start)) - (change-comment-line (current-point) column start begin end (or p 1)))) - - -(defcommand "Kill Comment" (p) - "Kills the comment (if any) on the current line. - With argument, applies to specified number of lines, and moves past them." - "Kills the comment (if any) on the current line. - With argument, applies to specified number of lines, and moves past them." - (let ((start (value comment-start))) - (when start - (if (not (stringp start)) - (editor-error "Comment start not string or nil -- ~S." start)) - (kill-comment (current-point) start (or p 1))))) - - -(defcommand "Indent New Comment Line" (p) - "Inserts comment end and then starts a comment on a new line. - The indentation and number of additional comment-start characters are - copied from the previous line's comment. Acts like Linefeed, when done - while not inside a comment, assuming a comment is the last thing on a line." - "complete a current comment and start another a new line, copying indentation - and start characters. If no comment, call Linefeed command." - (let ((start (value comment-start)) - (begin (value comment-begin)) - (end (value comment-end)) - (point (current-point))) - (with-mark ((tmark point :left-inserting)) - (if start - (cond ((not (stringp start)) - (editor-error "Comment start not string or nil -- ~S." start)) - ((and (to-line-comment tmark start) (mark> point tmark)) - (with-mark ((emark tmark)) - (let ((endp (if end (to-comment-end emark end)))) - (cond ((and endp (mark= emark point)) - (insert-string point end) - (indent-new-comment-line point tmark start begin end)) - ((and endp - (character-offset emark endp) - (mark>= point emark)) - (indent-new-line-command p)) - (t (delete-horizontal-space point) - (if end (insert-string point end)) - (indent-new-comment-line point tmark - start begin end)))))) - (t (indent-new-line-command p))) - (indent-new-line-command p))))) - - - -;;;; -- Support Routines -- - -(eval-when (compile eval) -(defmacro %do-comment-lines ((var number) mark1 &rest forms) - (let ((next-line-p (gensym))) - `(do ((,var (if (plusp ,number) ,number 0) (1- ,var)) - (,next-line-p t)) - ((or (zerop ,var) (not ,next-line-p)) - (zerop ,var)) - ,@forms - (setf ,next-line-p (line-offset ,mark1 1))))) -) ;eval-when - - -;;; CHANGE-COMMENT-LINE closes any comment on the current line, deleting -;;; an empty comment. After offsetting by lines, a comment is either -;;; aligned or created. -(defun change-comment-line (mark column start begin end lines) - (with-mark ((tmark1 mark :left-inserting) - (tmark2 mark)) - (let ((start-len (to-line-comment mark start)) - end-len) - (when start-len - (if end - (setf end-len (to-comment-end (move-mark tmark1 mark) end)) - (line-end tmark1)) - (character-offset (move-mark tmark2 mark) start-len) - (find-attribute tmark2 :whitespace #'zerop) - (cond ((mark>= tmark2 tmark1) - (if end-len (character-offset tmark1 end-len)) - ;; even though comment is blank, the line might not be blank - ;; after it in languages that have comment terminators. - (when (blank-after-p tmark1) - (reverse-find-attribute mark :whitespace #'zerop) - (if (not (same-line-p mark tmark1)) - (line-start mark (mark-line tmark1))) - (delete-region (region mark tmark1)))) - ((and end (not end-len)) (insert-string tmark1 end)))) - (if (line-offset mark lines) - (indent-for-comment mark column start begin end 1) - (editor-error))))) - - -(defun indent-for-comment (mark column start begin end times) - (with-mark ((tmark mark :left-inserting)) - (if (= times 1) - (let ((start-len (to-line-comment tmark start))) - (cond (start-len - (align-comment tmark start start-len column) - (character-offset (move-mark mark tmark) start-len)) - (t (comment-line mark column start begin end)))) - (unless (%do-comment-lines (n times) mark - (let ((start-len (to-line-comment mark start))) - (if start-len (align-comment mark start start-len column)))) - (buffer-end mark) - (editor-error))))) - - -;;; KILL-COMMENT assumes a comment is the last thing on a line, so it does -;;; not deal with comment-end. The Tao of EMACS. -(defun kill-comment (mark start times) - (with-mark ((tmark mark :left-inserting)) - (if (= times 1) - (when (to-line-comment mark start) - (with-mark ((u-start mark) - (u-end (line-end (move-mark tmark mark)))) - (rev-scan-char u-start :whitespace nil) - (let ((undo-region (copy-region (region u-start u-end)))) - (ring-push (delete-and-save-region (region mark tmark)) - *kill-ring*) - (delete-horizontal-space mark) - (make-region-undo :insert "Kill Comment" undo-region - (copy-mark mark :left-inserting))))) - (let* ((kill-region (delete-and-save-region (region mark tmark))) - (insert-mark (region-end kill-region)) - ;; don't delete u-start and u-end since undo stuff handles that. - (u-start (line-start (copy-mark mark :left-inserting))) - (u-end (copy-mark mark :left-inserting)) - (undo-region (copy-region (region u-start - (if (line-offset u-end times) - (line-start u-end) - (buffer-end u-end))))) - (n-times-p - (%do-comment-lines (n times) mark - (when (to-line-comment mark start) - (line-end (move-mark tmark mark)) - (ninsert-region insert-mark - (delete-and-save-region (region mark tmark))) - (insert-character insert-mark #\newline) - (delete-horizontal-space mark))))) - (ring-push kill-region *kill-ring*) - (make-region-undo :twiddle "Kill Comment" - (region u-start u-end) undo-region) - (unless n-times-p - (buffer-end mark) - (editor-error)))))) - -(defun comment-line (point column start begin end) - (let* ((open (or begin start)) - (open-len (length (the simple-string open))) - (end-len (if end (length (the simple-string end)) 0)) - (insert-len (+ open-len end-len))) - (line-end point) - (insert-string point open) - (if end (insert-string point end)) - (character-offset point (- insert-len)) - (adjust-comment point column) - (character-offset point open-len))) - - -(eval-when (compile eval) -(defmacro count-extra-last-chars (mark start-len start-char) - (let ((count (gensym)) - (tmark (gensym))) - `(with-mark ((,tmark ,mark)) - (character-offset ,tmark ,start-len) - (do ((,count 0 (1+ ,count))) - ((char/= (next-character ,tmark) ,start-char) ,count) - (mark-after ,tmark))))) -) - - -;;; ALIGN-COMMENT sets a comment starting at mark to start in column -;;; column. If the comment starts at the beginning of the line, it is not -;;; moved. If the comment start is a single character and duplicated, then -;;; it is indented as if it were code, and if it is triplicated, it is not -;;; moved. If the comment is to be moved to column, then we check to see -;;; if it is already there and preceded by whitespace. - -(defun align-comment (mark start start-len column) - (unless (start-line-p mark) - (case (count-extra-last-chars mark start-len (schar start (1- start-len))) - (1 (funcall (value indent-function) mark)) - (2 ) - (t (if (or (/= (mark-column mark) column) - (zerop (character-attribute - :whitespace (previous-character mark)))) - (adjust-comment mark column)))))) - - -;;; ADJUST-COMMENT moves the comment starting at mark to start in column -;;; column, inserting a space if the line extends past column. -(defun adjust-comment (mark column) - (delete-horizontal-space mark) - (let ((current-column (mark-column mark)) - (spaces-per-tab (value spaces-per-tab)) - tabs spaces next-tab-pos) - (cond ((= current-column column) - (if (/= column 0) (insert-character mark #\space))) - ((> current-column column) (insert-character mark #\space)) - (t (multiple-value-setq (tabs spaces) - (floor current-column spaces-per-tab)) - (setf next-tab-pos - (if (zerop spaces) - current-column - (+ current-column (- spaces-per-tab spaces)))) - (cond ((= next-tab-pos column) - (insert-character mark #\tab)) - ((> next-tab-pos column) - (dotimes (i (- column current-column)) - (insert-character mark #\space))) - (t (multiple-value-setq (tabs spaces) - (floor (- column next-tab-pos) spaces-per-tab)) - (dotimes (i (if (= current-column next-tab-pos) - tabs - (1+ tabs))) - (insert-character mark #\tab)) - (dotimes (i spaces) - (insert-character mark #\space)))))))) - - -;;; INDENT-NEW-COMMENT-LINE makes a new line at point starting a comment -;;; in the same way as the one at start-mark. -(defun indent-new-comment-line (point start-mark start begin end) - (new-line-command nil) - (insert-string point (gen-comment-prefix start-mark start begin)) - (if end - (when (not (to-comment-end (move-mark start-mark point) end)) - (insert-string start-mark end) - (if (mark= start-mark point) - ;; This occurs when nothing follows point on the line and - ;; both marks are left-inserting. - (character-offset - point (- (length (the simple-string end)))))))) - - -;;; GEN-COMMENT-PREFIX returns a string suitable for beginning a line -;;; with a comment lined up with mark and starting the same as the comment -;;; immediately following mark. This is used in the auto filling stuff too. -(defun gen-comment-prefix (mark start begin) - (let* ((start-len (length (the simple-string start))) - (last-char (schar start (1- start-len))) - (extra-start-chars (count-extra-last-chars mark start-len last-char)) - (spaces-per-tab (value spaces-per-tab)) - (begin-end (if begin - (subseq begin start-len (length (the simple-string begin))) - ""))) - (multiple-value-bind (tabs spaces) (floor (mark-column mark) spaces-per-tab) - (concatenate 'simple-string - (make-string tabs :initial-element #\tab) - (make-string spaces :initial-element #\space) - start - (make-string extra-start-chars :initial-element last-char) - begin-end)))) - - -;;; TO-LINE-COMMENT moves mark to the first comment start character on its -;;; line if there is a comment and returns the length of start, otherwise -;;; nil is returned. Start must be a string. This is used by the auto -;;; filling stuff too. -(defun to-line-comment (mark start) - (with-mark ((tmark mark)) - (line-start tmark) - (let ((start-len (find-pattern tmark (get-comment-pattern start :start)))) - (when (and start-len (same-line-p mark tmark)) - (move-mark mark tmark) - start-len)))) - - -;;; TO-COMMENT-END moves mark to the first comment end character on its -;;; line if end is there and returns the length of comment end, otherwise -;;; mark is moved to the end of the line returning nil. This is used by -;;; the auto filling stuff too. -(defun to-comment-end (mark end) - (with-mark ((tmark mark)) - (let ((end-len (find-pattern tmark (get-comment-pattern end :end)))) - (cond ((and end-len (same-line-p mark tmark)) - (move-mark mark tmark) - end-len) - (t (line-end mark) nil))))) diff --git a/hemlock/completion.lisp b/hemlock/completion.lisp deleted file mode 100644 index d47a7e6d5e97f1646e066fd360ba7c523e39d0fc..0000000000000000000000000000000000000000 --- a/hemlock/completion.lisp +++ /dev/null @@ -1,509 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Skef Wholey and Blaine Burks. -;;; General idea stolen from Jim Salem's TMC LISPM completion code. -;;; - -(in-package "HEMLOCK") - - - -;;;; The Completion Database. - -;;; The top level structure here is an array that gets indexed with the -;;; first three characters of the word to be completed. That will get us to -;;; a list of the strings with that prefix sorted in most-recently-used order. -;;; The number of strings in any given bucket will never exceed -;;; Completion-Bucket-Size-Limit. Strings are stored in the database in -;;; lowercase form always. - -(defconstant completion-table-size 991) - -(defvar *completions* (make-array completion-table-size)) - -(defhvar "Completion Bucket Size" - "This limits the number of completions saved for a particular combination of - the first three letters of any word." - :value 20) - - -;;; Mapping strings into buckets. - -;;; The characters that are considered parts of "words" change from mode -;;; to mode. -;;; -(defattribute "Completion Wordchar" - "1 for characters we consider to be constituents of words.") - -(defconstant default-other-wordchars - '(#\- #\* #\' #\_)) - -(do-alpha-chars (char :both) - (setf (character-attribute :completion-wordchar char) 1)) - -(dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - (setf (character-attribute :completion-wordchar char) 1)) - -(dolist (char default-other-wordchars) - (setf (character-attribute :completion-wordchar char) 1)) - - -;;; The difference between Lisp mode and the other modes is pretty radical in -;;; this respect. These are interesting too, but they're on by default: #\*, -;;; #\-, and #\_. #\' is on by default too, but it's uninteresting in "Lisp" -;;; mode. -;;; -(defconstant default-lisp-wordchars - '(#\~ #\! #\@ #\$ #\% #\^ #\& #\+ #\= #\: #\< #\> #\. #\/ #\?)) - -(dolist (char default-lisp-wordchars) - (shadow-attribute :completion-wordchar char 1 "Lisp")) - -(shadow-attribute :completion-wordchar #\' 0 "Lisp") - -(defmacro completion-char-p (char) - `(= (the fixnum (character-attribute :completion-wordchar ,char)) 1)) - -;;; COMPLETION-BUCKET-FOR returns the Completion-Bucket that might hold a -;;; completion for the given String. With optional Value, sets the bucket. -;;; -(defun completion-bucket-for (string length &optional (value nil value-p)) - (declare (simple-string string) - (fixnum length)) - (when (and (>= length 3) - (completion-char-p (char string 0)) - (completion-char-p (char string 1)) - (completion-char-p (char string 2))) - (let ((index (mod (logxor (ash - (logxor - (ash (hi::search-hash-code (schar string 0)) - 5) - (hi::search-hash-code (schar string 1))) - 3) - (hi::search-hash-code (schar string 2))) - completion-table-size))) - (declare (fixnum index)) - (if value-p - (setf (svref *completions* index) value) - (svref *completions* index))))) - -(defsetf completion-bucket-for completion-bucket-for) - - -;;; FIND-COMPLETION returns the most recent string matching the given -;;; Prefix, or Nil if nothing appropriate is in the database. We assume -;;; the Prefix is passed to us in lowercase form so we can use String=. If -;;; we find something appropriate, we bring it to the front of the list. -;;; Prefix-Length, if supplied restricts us to look at just the start of -;;; the string... -;;; -(defun find-completion (prefix &optional (prefix-length (length prefix))) - (declare (simple-string prefix) - (fixnum prefix-length)) - (let ((bucket (completion-bucket-for prefix prefix-length))) - (do ((list bucket (cdr list))) - ((null list)) - (let ((completion (car list))) - (declare (simple-string completion)) - (when (and (>= (length completion) prefix-length) - (string= prefix completion - :end1 prefix-length - :end2 prefix-length)) - (unless (eq list bucket) - (rotatef (car list) (car bucket))) - (return completion)))))) - -;;; RECORD-COMPLETION saves string in the completion database as the first item -;;; in the bucket, that's the most recently used completion. If the bucket is -;;; full, drop the oldest item in the list. If string is already in the -;;; bucket, simply move it to the front. The way we move an element to the -;;; front requires a full bucket to be at least three elements long. -;;; -(defun record-completion (string) - (declare (simple-string string)) - (let ((string-length (length string))) - (declare (fixnum string-length)) - (when (> string-length 3) - (let ((bucket (completion-bucket-for string string-length)) - (limit (value completion-bucket-size))) - (do ((list bucket (cdr list)) - (last nil list) - (length 1 (1+ length))) - ((null list) - (setf (completion-bucket-for string string-length) - (cons string bucket))) - (cond ((= length limit) - (setf (car list) string) - (setf (completion-bucket-for string string-length) list) - (setf (cdr list) bucket) - (setf (cdr last) nil) - (return)) - ((string= string (the simple-string (car list))) - (unless (eq list bucket) - (rotatef (car list) (car bucket))) - (return)))))))) - -;;; ROTATE-COMPLETIONS rotates the completion bucket for the given Prefix. -;;; We just search for the first thing in the bucket with the Prefix, then -;;; move that to the end of the list. If there ain't no such thing there, -;;; or if it's already at the end, we do nothing. -;;; -(defun rotate-completions (prefix &optional (prefix-length (length prefix))) - (declare (simple-string prefix)) - (let ((bucket (completion-bucket-for prefix prefix-length))) - (do ((list bucket (cdr list)) - (prev nil list)) - ((null list)) - (let ((completion (car list))) - (declare (simple-string completion)) - (when (and (>= (length completion) prefix-length) - (string= prefix completion - :end1 prefix-length :end2 prefix-length)) - (when (cdr list) - (if prev - (setf (cdr prev) (cdr list)) - (setf (completion-bucket-for prefix prefix-length) (cdr list))) - (setf (cdr (last list)) list) - (setf (cdr list) nil)) - (return nil)))))) - - - -;;;; Hemlock interface. - -(defmode "Completion" :transparent-p t :precedence 10.0 - :documentation - "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 often - long identifiers used in Lisp code. All words with the same first three - letters are in one list sorted by most recently used. \"Completion Bucket - Size\" limits the number of completions saved in each list.") - -(defcommand "Completion Mode" (p) - "Toggles Completion Mode in the current buffer." - "Toggles Completion Mode in the current buffer." - (declare (ignore p)) - (setf (buffer-minor-mode (current-buffer) "Completion") - (not (buffer-minor-mode (current-buffer) "Completion")))) - - -;;; Consecutive alphanumeric keystrokes that start a word cause a possible -;;; completion to be displayed in the echo area's modeline, the status line. -;;; Since most insertion is building up a word that was already started, we -;;; keep track of the word in *completion-prefix* that the user is typing. The -;;; length of the thing is kept in *completion-prefix-length*. -;;; -(defconstant completion-prefix-max-size 100) - -(defvar *completion-prefix* (make-string completion-prefix-max-size)) - -(defvar *completion-prefix-length* 0) - - -;;; "Completion Self Insert" does different stuff depending on whether or -;;; not the thing to be inserted is Completion-Char-P. If it is, then we -;;; try to come up with a possible completion, using Last-Command-Type to -;;; tense things up a bit. Otherwise, if Last-Command-Type says we were -;;; just doing a word, then we record that word in the database. -;;; -(defcommand "Completion Self Insert" (p) - "Insert the last character typed, showing possible completions. With prefix - argument insert the character that many times." - "Implements \"Completion Self Insert\". Calling this function is not - meaningful." - (let ((char (text-character *last-character-typed*))) - (unless char (editor-error "Can't insert that character.")) - (cond ((completion-char-p char) - ;; If start of word not already in *completion-prefix*, put it - ;; there. - (unless (eq (last-command-type) :completion-self-insert) - (set-completion-prefix)) - ;; Then add new stuff. - (cond ((and p (> p 1)) - (fill *completion-prefix* (char-downcase char) - :start *completion-prefix-length* - :end (+ *completion-prefix-length* p)) - (incf *completion-prefix-length* p)) - (t - (setf (schar *completion-prefix* *completion-prefix-length*) - (char-downcase char)) - (incf *completion-prefix-length*))) - ;; Display possible completion, if any. - (display-possible-completion *completion-prefix* - *completion-prefix-length*) - (setf (last-command-type) :completion-self-insert)) - (t - (when (eq (last-command-type) :completion-self-insert) - (record-completion (subseq *completion-prefix* - 0 *completion-prefix-length*))))))) - -;;; SET-COMPLETION-PREFIX grabs any completion-wordchars immediately before -;;; point and stores these into *completion-prefix*. -;;; -(defun set-completion-prefix () - (let* ((point (current-point)) - (point-line (mark-line point))) - (cond ((and (previous-character point) - (completion-char-p (previous-character point))) - (with-mark ((mark point)) - (reverse-find-attribute mark :completion-wordchar #'zerop) - (unless (eq (mark-line mark) point-line) - (editor-error "No completion wordchars on this line!")) - (let ((insert-string (nstring-downcase - (region-to-string - (region mark point))))) - (replace *completion-prefix* insert-string) - (setq *completion-prefix-length* (length insert-string))))) - (t - (setq *completion-prefix-length* 0))))) - - -(defcommand "Completion Complete Word" (p) - "Complete the word if we've got a completion, fixing up the case. Invoking - this immediately in succession rotates through possible completions in the - buffer. If there is no currently displayed completion, this tries to choose - a completion from text immediately before the point and displays the - completion if found." - "Complete the word if we've got a completion, fixing up the case." - (declare (ignore p)) - (let ((last-command-type (last-command-type))) - ;; If the user has been cursoring around and then tries to complete, - ;; let him. - ;; - (unless (member last-command-type '(:completion-self-insert :completion)) - (set-completion-prefix) - (setf last-command-type :completion-self-insert)) - (case last-command-type - (:completion-self-insert - (do-completion)) - (:completion - (rotate-completions *completion-prefix* *completion-prefix-length*) - (do-completion)))) - (setf (last-command-type) :completion)) - -(defcommand "List Possible Completions" (p) - "List all possible completions of the prefix the user has typed." - "List all possible completions of the prefix the user has typed." - (declare (ignore p)) - (let ((last-command-type (last-command-type))) - (unless (member last-command-type '(:completion-self-insert :completion)) - (set-completion-prefix)) - (let* ((prefix *completion-prefix*) - (prefix-length *completion-prefix-length*) - (bucket (completion-bucket-for prefix prefix-length))) - (with-pop-up-display (s) - (dolist (completion bucket) - (when (and (> (length completion) prefix-length) - (string= completion prefix - :end1 prefix-length - :end2 prefix-length)) - (write-line completion s)))))) - ;; Keep the redisplay hook from clearing any possibly displayed completion. - (setf (last-command-type) :completion-self-insert)) - -(defvar *last-completion-mark* nil) - -(defun do-completion () - (let ((completion (find-completion *completion-prefix* - *completion-prefix-length*)) - (point (current-point))) - (when completion - (if *last-completion-mark* - (move-mark *last-completion-mark* point) - (setq *last-completion-mark* (copy-mark point :temporary))) - (let ((mark *last-completion-mark*)) - (reverse-find-attribute mark :completion-wordchar #'zerop) - (let* ((region (region mark point)) - (string (region-to-string region))) - (declare (simple-string string)) - (delete-region region) - (let* ((first (position-if #'alpha-char-p string)) - (next (if first (position-if #'alpha-char-p string - :start (1+ first))))) - (insert-string point - (cond ((and first (lower-case-p (char string first))) - completion) - ((and next (lower-case-p (char string next))) - (word-capitalize completion)) - (t - (string-upcase completion)))))))))) - - -;;; WORD-CAPITALIZE is like STRING-CAPITALIZE except that it treats apostrophes -;;; the Right Way. -;;; -(defun word-capitalize (string) - (let* ((length (length string)) - (strung (make-string length))) - (do ((i 0 (1+ i)) - (new-word t)) - ((= i length)) - (let ((char (schar string i))) - (cond ((or (alphanumericp char) - (char= char #\')) - (setf (schar strung i) - (if new-word (char-upcase char) (char-downcase char))) - (setq new-word nil)) - (t - (setf (schar strung i) char) - (setq new-word t))))) - strung)) - -(defcommand "Completion Rotate Completions" (p) - "Show another possible completion in the status line, if there is one. - If there is no currently displayed completion, this tries to choose a - completion from text immediately before the point and displays the - completion if found. With an argument, rotate the completion ring that many - times." - "Show another possible completion in the status line, if there is one. - With an argument, rotate the completion ring that many times." - (unless (eq (last-command-type) :completion-self-insert) - (set-completion-prefix) - (setf (last-command-type) :completion-self-insert)) - (dotimes (i (or p 1)) - (rotate-completions *completion-prefix* *completion-prefix-length*)) - (display-possible-completion *completion-prefix* *completion-prefix-length*) - (setf (last-command-type) :completion-self-insert)) - - -;;;; Nifty database and parsing machanisms. - -(defhvar "Completion Database Filename" - "The file that \"Save Completions\" and \"Read Completions\" will - respectively write and read the completion database to and from." - :value nil) - -(defvar *completion-default-default-database-filename* - "hemlock-completions.txt" - "The file that will be defaultly written to and read from by \"Save - Completions\" and \"Read Completions\".") - -(defcommand "Save Completions" (p) - "Writes the current completion database to a file, defaultly the value of - \"Completion Database Filename\". With an argument, prompts for a - filename." - "Writes the current completion database to a file, defaultly the value of - \"Completion Database Filename\". With an argument, prompts for a - filename." - (let ((filename (or (and (not p) (value completion-database-filename)) - (prompt-for-file - :must-exist nil - :default *completion-default-default-database-filename* - :prompt "File to write completions to: ")))) - (with-open-file (s filename - :direction :output - :if-exists :rename-and-delete - :if-does-not-exist :create) - (message "Saving completions...") - (dotimes (i (length *completions*)) - (let ((bucket (svref *completions* i))) - (when bucket - (write i :stream s :base 10 :radix 10) - (write-char #\newline s) - (dolist (completion bucket) - (write-line completion s)) - (terpri s)))) - (message "Done.")))) - -(defcommand "Read Completions" (p) - "Reads some completions from a file, defaultly the value of \"Completion - Database File\". With an argument, prompts for a filename." - "Reads some completions from a file, defaultly the value of \"Completion - Database File\". With an argument, prompts for a filename." - (let ((filename (or (and (not p) (value completion-database-filename)) - (prompt-for-file - :must-exist nil - :default *completion-default-default-database-filename* - :prompt "File to read completions from: "))) - (index nil) - (completion nil)) - (with-open-file (s filename :if-does-not-exist :error) - (message "Reading in completions...") - (loop - (let ((new-completions '())) - (unless (setf index (read-preserving-whitespace s nil nil)) - (return)) - ;; Zip past the newline that I know is directly after the number. - ;; All this to avoid consing. I love it. - (read-char s) - (loop - (setf completion (read-line s)) - (when (string= completion "") (return)) - (unless (member completion (svref *completions* index)) - (push completion new-completions))) - (let ((new-bucket (nconc (nreverse new-completions) - (svref *completions* index)))) - (setf (svref *completions* index) new-bucket) - (do ((completion new-bucket (cdr completion)) - (end (1- (value completion-bucket-size))) - (i 0 (1+ i))) - ((endp completion)) - (when (= i end) (setf (cdr completion) nil)))))) - (message "Done.")))) - -(defcommand "Parse Buffer for Completions" (p) - "Zips over a buffer slamming everything that is a valid completion word - into the completion hashtable." - "Zips over a buffer slamming everything that is a valid completion word - into the completion hashtable." - (declare (ignore p)) - (let ((buffer (prompt-for-buffer :prompt "Buffer to parse: " - :must-exist t - :default (current-buffer) - :default-string (buffer-name - (current-buffer))))) - (with-mark ((word-start (buffer-start-mark buffer) :right-inserting) - (word-end (buffer-start-mark buffer) :left-inserting) - (buffer-end-mark (buffer-start-mark buffer))) - (message "Starting parse of ~S..." (buffer-name buffer)) - (loop - (unless (find-attribute word-start :completion-wordchar) (return)) - (record-completion - (region-to-string (region word-start - (or (find-attribute - (move-mark word-end word-start) - :completion-wordchar #'zerop) - buffer-end-mark)))) - (move-mark word-start word-end)) - (message "Done.")))) - - - -;;;; Modeline hackery: - -(defvar *completion-mode-possibility* "") - -(defvar *completion-modeline-field* (modeline-field :completion)) - -(defun display-possible-completion (prefix - &optional (prefix-length (length prefix))) - (let ((old *completion-mode-possibility*)) - (setq *completion-mode-possibility* - (or (find-completion prefix prefix-length) "")) - (unless (eq old *completion-mode-possibility*) - (update-modeline-field *echo-area-buffer* *echo-area-window* - *completion-modeline-field*)))) - -(defun clear-completion-display () - (unless (= (length (the simple-string *completion-mode-possibility*)) 0) - (setq *completion-mode-possibility* "") - (update-modeline-field *echo-area-buffer* *echo-area-window* - *completion-modeline-field*))) - - -;;; COMPLETION-REDISPLAY-FUN erases any completion displayed in the status line. -;;; -(defun completion-redisplay-fun (window) - (declare (ignore window)) - (unless (eq (last-command-type) :completion-self-insert) - (clear-completion-display))) -;;; -(add-hook redisplay-hook #'completion-redisplay-fun) diff --git a/hemlock/cursor.lisp b/hemlock/cursor.lisp deleted file mode 100644 index d90265bd5838f505295908179fa2eb7153024384..0000000000000000000000000000000000000000 --- a/hemlock/cursor.lisp +++ /dev/null @@ -1,409 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; -;;; Cursor: Routines for cursor positioning and recentering -;;; -(in-package 'hemlock-internals) -(export '(mark-to-cursorpos center-window displayed-p scroll-window - mark-column cursorpos-to-mark move-to-column)) - - -;;;; Mark-To-Cursorpos -;;; -;;; Since performance analysis showed that HALF of the time in the editor -;;; was being spent in this function, I threw all of the tricks in the -;;; book at it to try and make it tenser. -;;; -;;; The algorithm is roughly as follows: -;;; -;;; 1) Eliminate the annoying boundry condition of the mark being -;;; off the end of the window, if it is return NIL now. -;;; 2) If the charpos is on or immediately after the last character -;;; in the line, then find the last dis-line on which the line is -;;; displayed. We know that the mark is at the end of this dis-line -;;; because it is known to be on the screen. X position is trivially -;;; derived from the dis-line-length. -;;; 3) Call Real-Line-Length or Cached-Real-Line-Length to get the -;;; X position and number of times wrapped. - -(proclaim '(special the-sentinel)) - -(eval-when (compile eval) -;;; find-line -;;; -;;; Find a dis-line which line is displayed on which starts before -;;; charpos, setting ypos and dis-line to the dis-line and it's index. -;;; Offset is expected to be the mark-charpos of the display-start for -;;; the window initially, and is set to offset within line that -;;; Dis-Line begins. Charpos is the mark-charpos of the mark we want -;;; to find. Check if same as *redisplay-favorite-line* and then scan -;;; if not. -;;; -(defmacro find-line (line offset charpos ypos dis-lines dis-line) - `(cond - ;; No lines at all, fail. - ((eq ,dis-lines the-sentinel) nil) - ;; On the first line, offset is already set, so just set dis-line and - ;; ypos and fall through. - ((eq (dis-line-line (car ,dis-lines)) ,line) - (setq ,dis-line ,dis-lines ,ypos 0)) - ;; Look farther down. - ((do ((l (cdr ,dis-lines) (cdr l))) - ((eq l the-sentinel)) - (when (eq (dis-line-line (car l)) ,line) - (setq ,dis-line l ,ypos (dis-line-position (car l)) ,offset 0) - (return t)))) - (t - (error "Horrible flaming lossage, Sorry Man.")))) - -;;; find-last -;;; -;;; Find the last dis-line on which line is displayed, set ypos and -;;; dis-line. -;;; -(defmacro find-last (line ypos dis-line) - `(do ((trail ,dis-line dl) - (dl (cdr ,dis-line) (cdr dl))) - ((not (eq (dis-line-line (car dl)) ,line)) - (setq ,dis-line (car trail) ,ypos (dis-line-position ,dis-line))))) - -;;; find-charpos -;;; -;;; Special-Case mark at end of line, if not punt out to real-line-length -;;; function. Return the correct values. -;;; -(defmacro find-charpos (line offset charpos length ypos dis-line width - fun chars) - `(cond - ((= ,charpos ,length) - (find-last ,line ,ypos ,dis-line) - (values (min (dis-line-length ,dis-line) (1- ,width)) ,ypos)) - ((= ,charpos (1- ,length)) - (multiple-value-bind (x dy) - (,fun ,line (1- ,width) ,offset ,charpos) - (if (and (not (zerop dy)) (zerop x)) - (values (1- ,width) (1- (+ ,ypos dy))) - (values x (+ ,ypos dy))))) - (t - (multiple-value-bind (x dy) - (,fun ,line (1- ,width) ,offset ,charpos) - (values x (+ ,ypos dy)))))) - -); eval-when (compile eval) - -;;; real-line-length -;;; -;;; Return as values the X position and the number of times wrapped if -;;; one to display the characters from Start to End of Line starting at an -;;; X position of 0 wrapping Width wide. -;;; %SP-Find-Character-With-Attribute is used to find charaters -;;; with funny representation much as in Compute-Line-Image. -;;; -(defun real-line-length (line width start end) - (declare (fixnum width start end)) - (do ((xpos 0) - (ypos 0) - (chars (line-chars line)) losing dy) - ((= start end) (values xpos ypos)) - (declare (fixnum xpos ypos losing dy) (simple-string chars)) - (setq losing (%fcwa chars start end losing-char)) - (when (null losing) - (multiple-value-setq (dy xpos) (truncate (+ xpos (- end start)) width)) - (return (values xpos (+ ypos dy)))) - (multiple-value-setq (dy xpos) (truncate (+ xpos (- losing start)) width)) - (setq ypos (+ ypos dy) start losing) - (do ((last (or (%fcwa chars start end winning-char) end)) str) - ((= start last)) - (declare (fixnum last)) - (setq str (get-rep (schar chars start))) - (incf start) - (unless (simple-string-p str) (setq str (funcall str xpos))) - (multiple-value-setq (dy xpos) (truncate (+ xpos (strlen str)) width)) - (setq ypos (+ ypos dy))))) - -;;; cached-real-line-length -;;; -;;; The same as Real-Line-Length, except does it for the cached line. -;;; the line argument is ignored, but present to make the arglists the -;;; same. -;;; -(defun cached-real-line-length (line width start end) - (declare (fixnum width start end) (ignore line)) - (let ((offset (- right-open-pos left-open-pos)) bound) - (declare (fixnum offset bound)) - (cond - ((>= start left-open-pos) - (setq start (+ start offset) bound (setq end (+ end offset)))) - ((> end left-open-pos) - (setq bound left-open-pos end (+ end offset))) - (t - (setq bound end))) - - (do ((xpos 0) - (ypos 0) losing dy) - (()) - (declare (fixnum xpos ypos losing dy)) - (when (= start bound) - (when (= start end) (return (values xpos ypos))) - (setq start right-open-pos bound end)) - (setq losing (%fcwa open-chars start bound losing-char)) - (cond - (losing - (multiple-value-setq (dy xpos) - (truncate (+ xpos (- losing start)) width)) - (setq ypos (+ ypos dy) start losing) - (do ((last (or (%fcwa open-chars start bound winning-char) bound)) str) - ((= start last)) - (declare (fixnum last)) - (setq str (get-rep (schar open-chars start))) - (incf start) - (unless (simple-string-p str) (setq str (funcall str xpos))) - (multiple-value-setq (dy xpos) - (truncate (+ xpos (strlen str)) width)) - (setq ypos (+ ypos dy)))) - (t - (multiple-value-setq (dy xpos) - (truncate (+ xpos (- bound start)) width)) - (setq ypos (+ ypos dy) start bound)))))) - -;;; mark-to-cursorpos -- Public -;;; -;;; Return as multiple values the x and y position within window of -;;; mark. NIL is returned if the mark is not displayed in the window given -;;; -;;; -(defun mark-to-cursorpos (mark window) - "Return the (x, y) position of mark within window, or NIL if not displayed." - (let* ((line (mark-line mark)) - (number (line-number line)) - (charpos (mark-charpos mark)) - (dis-lines (cdr (window-first-line window))) - (width (window-width window)) - (start (window-display-start window)) - (offset (mark-charpos start)) - (start-number (line-number (mark-line start))) - (end (window-display-end window)) - (end-number (line-number (mark-line end))) ypos dis-line) - (declare (fixnum width charpos ypos number end-number) - (simple-vector dis-lines)) - (cond - ((or (< number start-number) - (and (= number start-number) (< charpos offset)) - (> number end-number) - (and (= number end-number) (> charpos (mark-charpos end)))) nil) - (t - (find-line line offset charpos ypos dis-lines dis-line) - (cond - ((eq line open-line) - (let ((len (- line-cache-length (- right-open-pos left-open-pos)))) - (declare (fixnum len)) - (find-charpos line offset charpos len ypos dis-line width - cached-real-line-length open-chars))) - (t - (let* ((chars (line-chars line)) - (len (strlen chars))) - (declare (fixnum len) (simple-string chars)) - (find-charpos line offset charpos len ypos dis-line width - real-line-length chars)))))))) - -;;; Dis-Line-Offset-Guess -- Internal -;;; -;;; Move Mark by Offset display lines. The mark is assumed to be at the -;;; beginning of a display line, and we attempt to leave it at one. We assume -;;; all characters print one wide. Width is the width of the window we are -;;; displaying in. -;;; -(defun dis-line-offset-guess (mark offset width) - (let ((w (1- width))) - (if (minusp offset) - (dotimes (i (- offset) t) - (let ((pos (mark-charpos mark))) - (if (>= pos w) - (character-offset mark (- w)) - (let ((prev (line-previous (mark-line mark)))) - (unless prev (return nil)) - (multiple-value-bind - (lines chars) - (truncate (line-length prev) w) - (move-to-position mark - (cond ((zerop lines) 0) - ((< chars 2) - (* w (1- lines))) - (t - (* w lines))) - prev)))))) - (dotimes (i offset t) - (let ((left (- (line-length (mark-line mark)) - (mark-charpos mark)))) - (if (> left width) - (character-offset mark w) - (unless (line-offset mark 1 0) - (return nil)))))))) - -;;; maybe-recenter-window -- Internal -;;; -;;; Update the dis-lines for Window and recenter if the point is off -;;; the screen. -;;; -(defun maybe-recenter-window (window) - (unless (%displayed-p (buffer-point (window-buffer window)) window) - (center-window window (buffer-point (window-buffer window))) - t)) - -;;; center-window -- Public -;;; -;;; Try to move the start of window so that Mark is on a line in the -;;; center. -;;; -(defun center-window (window mark) - "Adjust the start of Window so that Mark is displayed on the center line." - (let ((height (window-height window)) - (start (window-display-start window))) - (move-mark start mark) - (unless (dis-line-offset-guess start (- (truncate height 2)) - (window-width window)) - (move-mark start (buffer-start-mark (window-buffer window)))) - (update-window-image window) - ;; If that doesn't work, panic and make the start the point. - (unless (%displayed-p mark window) - (move-mark start mark) - (update-window-image window)))) - - -;;; %Displayed-P -- Internal -;;; -;;; If Mark is within the displayed bounds in Window, then return true, -;;; otherwise false. We assume the window image is up to date. -;;; -(defun %displayed-p (mark window) - (let ((start (window-display-start window)) - (end (window-display-end window))) - (not (or (mark< mark start) (mark> mark end) - (if (mark= mark end) - (let ((ch (next-character end))) - (and ch (char/= ch #\newline))) - nil))))) - - -;;; Displayed-p -- Public -;;; -;;; Update the window image and then check if the mark is displayed. -;;; -(defun displayed-p (mark window) - "Return true if Mark is displayed on Window, false otherwise." - (update-window-image window) - (%displayed-p mark window)) - - -;;; scroll-window -- Public -;;; -;;; This is not really right, since it uses dis-line-offset-guess. -;;; Probably if there is any screen overlap then we figure it out -;;; exactly. -;;; -(defun scroll-window (window n) - "Scroll Window down N lines, up if negative." - (let ((start (window-display-start window)) - (point (window-point window)) - (width (window-width window)) - (height (window-height window))) - (cond ((dis-line-offset-guess start n width)) - ((minusp n) - (buffer-start start)) - (t - (buffer-end start) - (let ((fraction (- (truncate height 3) height))) - (dis-line-offset-guess start fraction width)))) - (update-window-image window) - (let ((iscurrent (eq window *current-window*)) - (bpoint (buffer-point (window-buffer window)))) - (when iscurrent (move-mark point bpoint)) - (unless (%displayed-p point window) - (move-mark point start) - (dis-line-offset-guess point (truncate (window-height window) 2) - width) - (when iscurrent (move-mark bpoint point))))) - t) - -;;; Mark-Column -- Public -;;; -;;; Find the X position of a mark supposing that it were displayed -;;; in an infinitely wide screen. -;;; -(defun mark-column (mark) - "Find the X position at which Mark would be displayed if it were on - an infinitely wide screen. This takes into account tabs and control - characters." - (let ((charpos (mark-charpos mark)) - (line (mark-line mark))) - (if (eq line open-line) - (values (cached-real-line-length line 10000 0 charpos)) - (values (real-line-length line 10000 0 charpos))))) - -;;; Find-Position -- Internal -;;; -;;; Return the charpos which corresponds to the specified X position -;;; within Line. If there is no such position between Start and End then -;;; rutne NIL. -;;; -(defun find-position (line position start end width) - (do* ((cached (eq line open-line)) - (lo start) - (hi (1- end)) - (probe (truncate (+ lo hi) 2) (truncate (+ lo hi) 2))) - ((> lo hi) - (if (= lo end) nil hi)) - (let ((val (if cached - (cached-real-line-length line width start probe) - (real-line-length line width start probe)))) - (cond ((= val position) (return probe)) - ((< val position) (setq lo (1+ probe))) - (t (setq hi (1- probe))))))) - -;;; Cursorpos-To-Mark -- Public -;;; -;;; Find the right dis-line, then zero in on the correct position -;;; using real-line-length. -;;; -(defun cursorpos-to-mark (x y window) - (check-type window window) - (let ((width (window-width window)) - (first (window-first-line window))) - (when (>= x width) - (return-from cursorpos-to-mark nil)) - (do* ((prev first dl) - (dl (cdr first) (cdr dl)) - (ppos (mark-charpos (window-display-start window)) - (if (eq (dis-line-line (car dl)) (dis-line-line (car prev))) - (dis-line-end (car prev)) 0))) - ((eq dl the-sentinel) - (copy-mark (window-display-end window) :temporary)) - (when (= (dis-line-position (car dl)) y) - (let* ((line (dis-line-line (car dl))) - (end (dis-line-end (car dl)))) - (return (mark line (or (find-position line x ppos end width) end)))))))) - -;;; Move-To-Column -- Public -;;; -;;; Just look up the charpos using find-position... -;;; -(defun move-to-column (mark column &optional (line (mark-line mark))) - "Move Mark to the specified Column on Line. This function is analogous - to Move-To-Position, but it deals with the physical screen position - as returned by Mark-Column; the mark is moved to before the character - which would be displayed in Column if the line were displayed on - an infinitely wide screen. If the column specified is greater than - the column of the last character, then Nil is returned and the mark - is not modified." - (let ((res (find-position line column 0 (line-length line) 10000))) - (if res - (move-to-position mark res line)))) diff --git a/hemlock/defsyn.lisp b/hemlock/defsyn.lisp deleted file mode 100644 index d2dbfc7d232d1369d8251eecfe14812d5180df90..0000000000000000000000000000000000000000 --- a/hemlock/defsyn.lisp +++ /dev/null @@ -1,157 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains definitions of various character attributes. -;;; -(in-package 'hemlock) - -(defattribute "Whitespace" - "A value of 1 for this attribute indicates that the corresponding character - should be considered as whitespace. This is used by the Blank-Line-P - function.") - -(setf (character-attribute :whitespace #\space) 1) -(setf (character-attribute :whitespace #\linefeed) 1) -(setf (character-attribute :whitespace #\tab) 1) -(setf (character-attribute :whitespace #\newline) 1) - -(defattribute "Word Delimiter" - "A value of 1 for this attribute indicates that the corresponding character - separates words. This is used by the word manipulating commands.") - -(setf (character-attribute :word-delimiter nil) 1) -(setf (character-attribute :word-delimiter #\!) 1) -(setf (character-attribute :word-delimiter #\@) 1) -(setf (character-attribute :word-delimiter #\#) 1) -(setf (character-attribute :word-delimiter #\$) 1) -(setf (character-attribute :word-delimiter #\%) 1) -(setf (character-attribute :word-delimiter #\^) 1) -(setf (character-attribute :word-delimiter #\&) 1) -(setf (character-attribute :word-delimiter #\*) 1) -(setf (character-attribute :word-delimiter #\() 1) -(setf (character-attribute :word-delimiter #\)) 1) -(setf (character-attribute :word-delimiter #\-) 1) -(setf (character-attribute :word-delimiter #\_) 1) -(setf (character-attribute :word-delimiter #\=) 1) -(setf (character-attribute :word-delimiter #\+) 1) -(setf (character-attribute :word-delimiter #\[) 1) -(setf (character-attribute :word-delimiter #\]) 1) -(setf (character-attribute :word-delimiter #\\) 1) -(setf (character-attribute :word-delimiter #\|) 1) -(setf (character-attribute :word-delimiter #\;) 1) -(setf (character-attribute :word-delimiter #\:) 1) -(setf (character-attribute :word-delimiter #\') 1) -(setf (character-attribute :word-delimiter #\") 1) -(setf (character-attribute :word-delimiter #\{) 1) -(setf (character-attribute :word-delimiter #\}) 1) -(setf (character-attribute :word-delimiter #\,) 1) -(setf (character-attribute :word-delimiter #\.) 1) -(setf (character-attribute :word-delimiter #\<) 1) -(setf (character-attribute :word-delimiter #\>) 1) -(setf (character-attribute :word-delimiter #\/) 1) -(setf (character-attribute :word-delimiter #\?) 1) -(setf (character-attribute :word-delimiter #\`) 1) -(setf (character-attribute :word-delimiter #\~) 1) -(setf (character-attribute :word-delimiter #\space) 1) -(setf (character-attribute :word-delimiter #\linefeed) 1) -(setf (character-attribute :word-delimiter #\formfeed) 1) -(setf (character-attribute :word-delimiter #\tab) 1) -(setf (character-attribute :word-delimiter #\newline) 1) - -(shadow-attribute :word-delimiter #\. 0 "Fundamental") -(shadow-attribute :word-delimiter #\' 0 "Text") -(shadow-attribute :word-delimiter #\backspace 0 "Text") -(shadow-attribute :word-delimiter #\_ 0 "Text") - -(defattribute "Page Delimiter" - "This attribute is 1 for characters that separate pages, 0 otherwise.") -(setf (character-attribute :page-delimiter nil) 1) -(setf (character-attribute :page-delimiter #\page) 1) - - -(defattribute "Lisp Syntax" - "These character attribute is used by the lisp mode commands, and possibly - other people. The value of ths attribute is always a symbol. Currently - defined values are: - NIL - No interesting properties. - :space - Acts like whitespace, should not include newline. - :newline - Newline, man. - :open-paren - An opening bracket. - :close-paren - A closing bracket. - :prefix - A character that is a part of any form it appears before. - :string-quote - The character that quotes a string. - :char-quote - The character that escapes a single character. - :comment - The character that comments out to end of line. - :constituent - Things that make up symbols." - 'symbol nil) - -(setf (character-attribute :lisp-syntax #\space) :space) -(setf (character-attribute :lisp-syntax #\tab) :space) - -(setf (character-attribute :lisp-syntax #\() :open-paren) -(setf (character-attribute :lisp-syntax #\)) :close-paren) -(setf (character-attribute :lisp-syntax #\') :prefix) -(setf (character-attribute :lisp-syntax #\`) :prefix) -(setf (character-attribute :lisp-syntax #\#) :prefix) -(setf (character-attribute :lisp-syntax #\,) :prefix) -(setf (character-attribute :lisp-syntax #\") :string-quote) -(setf (character-attribute :lisp-syntax #\\) :char-quote) -(setf (character-attribute :lisp-syntax #\;) :comment) -(setf (character-attribute :lisp-syntax #\newline) :newline) -(setf (character-attribute :lisp-syntax nil) :newline) - -(do-alpha-chars (ch :both) - (setf (character-attribute :lisp-syntax ch) :constituent)) - -(setf (character-attribute :lisp-syntax #\0) :constituent) -(setf (character-attribute :lisp-syntax #\1) :constituent) -(setf (character-attribute :lisp-syntax #\2) :constituent) -(setf (character-attribute :lisp-syntax #\3) :constituent) -(setf (character-attribute :lisp-syntax #\4) :constituent) -(setf (character-attribute :lisp-syntax #\5) :constituent) -(setf (character-attribute :lisp-syntax #\6) :constituent) -(setf (character-attribute :lisp-syntax #\7) :constituent) -(setf (character-attribute :lisp-syntax #\8) :constituent) -(setf (character-attribute :lisp-syntax #\9) :constituent) - -(setf (character-attribute :lisp-syntax #\!) :constituent) -(setf (character-attribute :lisp-syntax #\{) :constituent) -(setf (character-attribute :lisp-syntax #\}) :constituent) -(setf (character-attribute :lisp-syntax #\[) :constituent) -(setf (character-attribute :lisp-syntax #\]) :constituent) -(setf (character-attribute :lisp-syntax #\/) :constituent) -(setf (character-attribute :lisp-syntax #\@) :constituent) -(setf (character-attribute :lisp-syntax #\-) :constituent) -(setf (character-attribute :lisp-syntax #\_) :constituent) -(setf (character-attribute :lisp-syntax #\+) :constituent) -(setf (character-attribute :lisp-syntax #\%) :constituent) -(setf (character-attribute :lisp-syntax #\*) :constituent) -(setf (character-attribute :lisp-syntax #\$) :constituent) -(setf (character-attribute :lisp-syntax #\^) :constituent) -(setf (character-attribute :lisp-syntax #\&) :constituent) -(setf (character-attribute :lisp-syntax #\~) :constituent) -(setf (character-attribute :lisp-syntax #\=) :constituent) -(setf (character-attribute :lisp-syntax #\<) :constituent) -(setf (character-attribute :lisp-syntax #\>) :constituent) -(setf (character-attribute :lisp-syntax #\?) :constituent) -(setf (character-attribute :lisp-syntax #\.) :constituent) -(setf (character-attribute :lisp-syntax #\:) :constituent) - - -(defattribute "Sentence Terminator" - "Used for terminating sentences -- ., !, ?. - Possibly could make type (mod 3) and use the value of 2 and 1 for spaces - to place after chacter." - '(mod 2) - 0) - -(setf (character-attribute :sentence-terminator #\.) 1) -(setf (character-attribute :sentence-terminator #\!) 1) -(setf (character-attribute :sentence-terminator #\?) 1) diff --git a/hemlock/dired.lisp b/hemlock/dired.lisp deleted file mode 100644 index 2ae2b8ea81a100ee21741b57428363e31401298e..0000000000000000000000000000000000000000 --- a/hemlock/dired.lisp +++ /dev/null @@ -1,691 +0,0 @@ -;;; -*- Log: hemlock.log; Package: dired -*- -;;; -;;; ********************************************************************** -;;; 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 site dependent code for dired. -;;; Written by Bill Chiles. -;;; - -(in-package "DIRED") - -(shadow '(rename-file delete-file)) - -(export '(copy-file rename-file find-file delete-file make-directory - *update-default* *clobber-default* *recursive-default* - *report-function* *error-function* *yesp-function* - pathnames-from-pattern)) - - - -;;;; Exported parameters. - -(defparameter *update-default* nil - "Update arguments to utilities default to this value.") - -(defparameter *clobber-default* t - "Clobber arguments to utilities default to this value.") - -(defparameter *recursive-default* nil - "Recursive arguments to utilities default to this value.") - - - -;;;; WILDCARDP - -(defconstant wildcard-char #\* - "Wildcard designator for file names will match any substring.") - -(defmacro wildcardp (file-namestring) - `(position wildcard-char (the simple-string ,file-namestring) :test #'char=)) - - - -;;;; User interaction functions, variable declarations, and their defaults. - -(defun default-error-function (string &rest args) - (apply #'error string args)) -;;; -(defvar *error-function* #'default-error-function - "This function is called when an error is encountered in dired code.") - -(defun default-report-function (string &rest args) - (apply #'format t string args)) -;;; -(defvar *report-function* #'default-report-function - "This function is called when the user needs to be informed of something.") - -(defun default-yesp-function (string &rest args) - (apply #'format t string args) - (let ((answer (nstring-downcase (string-trim '(#\space #\tab) (read-line))))) - (declare (simple-string answer)) - (or (string= answer "") - (string= answer "y") - (string= answer "yes") - (string= answer "ye")))) -;;; -(defvar *yesp-function* #'default-yesp-function - "Function to query the user about clobbering an already existent file.") - - - -;;;; Copy-File - -;;; WILD-MATCH objects contain information about wildcard matches. File is the -;;; Sesame namestring of the file matched, and substitute is a substring of the -;;; file-namestring of file. -;;; -(defstruct (wild-match (:print-function print-wild-match) - (:constructor make-wild-match (file substitute))) - file - substitute) - -(defun print-wild-match (obj str n) - (declare (ignore n)) - (format str "#<Wild-Match ~S ~S>" - (wild-match-file obj) (wild-match-substitute obj))) - - -(defun copy-file (spec1 spec2 &key (update *update-default*) - (clobber *clobber-default*) - (directory () directoryp)) - "Copy file spec1 to spec2. A single wildcard is acceptable, and directory - names may be used. If spec1 and spec2 are both directories, then a - recursive copy is done of the files and subdirectory structure of spec1; - if spec2 is in the subdirectory structure of spec1, the recursion will - not descend into it. Use spec1/* to copy only the files in spec1 to - directory spec2. If spec2 is a directory, and spec1 is a file, then - spec1 is copied into spec2 with the same pathname-name. Files are - copied maintaining the source's write date. If :update is non-nil, then - files are only copied if the source is newer than the destination, still - maintaining the source's write date; the user is not warned if the - destination is newer (not the same write date) than the source. If - :clobber and :update are nil, then if any file spec2 already exists, the - user will be asked whether it should be overwritten or not." - (cond - ((not directoryp) - (multiple-value-bind (ses-name1 exists1p) - (lisp::predict-name spec1 t) - (let* ((ses-name2 (lisp::predict-name spec2 nil)) - (pname1 (pathname ses-name1)) - (pname2 (pathname ses-name2)) - (dirp1 (directoryp pname1)) - (dirp2 (directoryp pname2)) - (wildp1 (wildcardp (file-namestring pname1))) - (wildp2 (wildcardp (file-namestring pname2)))) - (when (and dirp1 wildp1) - (funcall *error-function* - "Cannot have wildcards in directory names -- ~S." pname1)) - (when (and dirp2 wildp2) - (funcall *error-function* - "Cannot have wildcards in directory names -- ~S." pname2)) - (when (and dirp1 (not dirp2)) - (funcall *error-function* - "Cannot handle spec1 being a directory and spec2 a file.")) - (when (and wildp2 (not wildp1)) - (funcall *error-function* - "Cannot handle destination having wildcards without ~ - source having wildcards.")) - (when (and wildp1 (not wildp2) (not dirp2)) - (funcall *error-function* - "Cannot handle source with wildcards and destination ~ - without, unless destination is a directory.")) - (cond ((and dirp1 dirp2) - (unless (directory-existsp ses-name1) - (funcall *error-function* - "Directory does not exist -- ~S." pname1)) - (unless (directory-existsp ses-name2) - (enter-directory ses-name2)) - (recursive-copy pname1 pname2 update clobber pname2 - ses-name1 ses-name2)) - (dirp2 - ;; merge pname2 with pname1 to pick up a similar file-namestring. - (copy-file-1 pname1 wildp1 exists1p - (merge-pathnames pname2 pname1) - wildp1 update clobber)) - (t (copy-file-1 pname1 wildp1 exists1p - pname2 wildp2 update clobber)))))) - (directory - (when (pathname-directory spec1) - (funcall *error-function* - "Spec1 is just a pattern when supplying directory -- ~S." - spec1)) - (let* ((pname2 (pathname (lisp::predict-name spec2 nil))) - (dirp2 (directoryp pname2)) - (wildp1 (wildcardp spec1)) - (wildp2 (wildcardp (file-namestring pname2)))) - (unless wildp1 - (funcall *error-function* - "Pattern, ~S, does not contain a wildcard." - spec1)) - (when (and (not wildp2) (not dirp2)) - (funcall *error-function* - "Cannot handle source with wildcards and destination ~ - without, unless destination is a directory.")) - (copy-wildcard-files spec1 wildp1 - (if dirp2 (merge-pathnames pname2 spec1) pname2) - (if dirp2 wildp1 wildp2) - update clobber directory)))) - (values)) - -;;; RECURSIVE-COPY takes two pathnames that represent directories, and -;;; the files in pname1 are copied into pname2, recursively descending into -;;; subdirectories. If a subdirectory of pname1 does not exist in pname2, -;;; it is created. Pname1 is known to exist. Forbidden-dir is originally -;;; the same as pname2; this keeps us from infinitely recursing if pname2 -;;; is in the subdirectory structure of pname1. Returns t if some file gets -;;; copied. -;;; -(defun recursive-copy (pname1 pname2 update clobber - forbidden-dir ses-name1 ses-name2) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2) - (dolist (spec (directory (directory-namestring pname1))) - (let ((spec-ses-name (namestring spec))) - (if (directoryp spec) - (unless (equal (pathname spec-ses-name) forbidden-dir) - (let* ((dir2-pname (merge-dirs spec pname2)) - (dir2-ses-name (namestring dir2-pname))) - (unless (directory-existsp dir2-ses-name) - (enter-directory dir2-ses-name)) - (recursive-copy spec dir2-pname update clobber forbidden-dir - spec-ses-name dir2-ses-name) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 - ses-name2))) - (copy-file-2 spec-ses-name - (namestring (merge-pathnames pname2 spec)) - update clobber))))) - -;;; MERGE-DIRS picks out the last directory name in the pathname pname1 and -;;; adds it to the end of the sequence of directory names from pname2, returning -;;; a pathname. -;;; -(defun merge-dirs (pname1 pname2) - (let* ((dirs1 (pathname-directory pname1)) - (dirs2 (pathname-directory pname2)) - (dirs2-len (length dirs2)) - (new-dirs2 (make-array (1+ dirs2-len)))) - (declare (simple-vector dirs1 dirs2 new-dirs2)) - (replace new-dirs2 dirs2) - (setf (svref new-dirs2 dirs2-len) - (svref dirs1 (1- (length dirs1)))) - (make-pathname :directory new-dirs2 :device :absolute))) - -;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard -;;; or none. Wildp1 and Wildp2 are either nil or indexes into the -;;; file-namestring of pname1 and pname2, respectively, indicating the position -;;; of the wildcard character. If there is no wildcard, then simply call -;;; COPY-FILE-2; otherwise, resolve the wildcard and copy those matching files. -;;; -(defun copy-file-1 (pname1 wildp1 exists1p pname2 wildp2 update clobber) - (if wildp1 - (copy-wildcard-files pname1 wildp1 pname2 wildp2 update clobber) - (let ((ses-name1 (namestring pname1))) - (unless exists1p (funcall *error-function* - "~S does not exist." ses-name1)) - (copy-file-2 ses-name1 (namestring pname2) update clobber)))) - -(defun copy-wildcard-files (pname1 wildp1 pname2 wildp2 update clobber - &optional directory) - (multiple-value-bind (dst-before dst-after) - (before-wildcard-after (file-namestring pname2) wildp2) - (dolist (match (resolve-wildcard pname1 wildp1 directory)) - (copy-file-2 (wild-match-file match) - (namestring (concatenate 'simple-string - (directory-namestring pname2) - dst-before - (wild-match-substitute match) - dst-after)) - update clobber)))) - -;;; COPY-FILE-2 copies ses-name1 to ses-name2 depending on the values of update -;;; and clobber, with respect to the documentation of COPY-FILE. If ses-name2 -;;; doesn't exist, then just copy it; otherwise, if update, then only copy it -;;; if the destination's write date precedes the source's, and if not clobber -;;; and not update, then ask the user before doing the copy. -;;; -(defun copy-file-2 (ses-name1 ses-name2 update clobber) - (let ((secs1 (get-write-date ses-name1))) - (cond ((not (probe-file ses-name2)) - (do-the-copy ses-name1 ses-name2 secs1)) - (update - (let ((secs2 (get-write-date ses-name2))) - (cond (clobber - (do-the-copy ses-name1 ses-name2 secs1)) - ((and (> secs2 secs1) - (funcall *yesp-function* - "~&~S ==> ~S~% ~ - ** Destination is newer than source. ~ - Overwrite it? " - ses-name1 ses-name2)) - (do-the-copy ses-name1 ses-name2 secs1)) - ((< secs2 secs1) - (do-the-copy ses-name1 ses-name2 secs1))))) - ((not clobber) - (when (funcall *yesp-function* - "~&~S ==> ~S~% ** Destination already exists. ~ - Overwrite it? " - ses-name1 ses-name2) - (do-the-copy ses-name1 ses-name2 secs1))) - (t (do-the-copy ses-name1 ses-name2 secs1))))) - -(defun do-the-copy (ses-name1 ses-name2 secs1) - (let* ((fd (open-file ses-name1))) - (unwind-protect - (multiple-value-bind (data byte-count mode) - (read-file fd ses-name1) - (unwind-protect (write-file ses-name2 data byte-count mode) - (dispose-storage data byte-count))) - (close-file fd))) - (set-write-date ses-name2 secs1) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)) - - -;;;; Rename-File - -(defun rename-file (spec1 spec2 &key (clobber *clobber-default*) - (directory () directoryp)) - "Rename file spec1 to spec2. A single wildcard is acceptable, and spec2 may - be a directory with the result spec being the merging of spec2 with spec1. - If clobber is nil and spec2 exists, then the user will be asked to confirm - the renaming. As with Unix mv, if you are renaming a directory, don't - specify the trailing slash." - (cond - ((not directoryp) - (multiple-value-bind (ses-name1 exists1p) - (lisp::predict-name spec1 t) - (let* ((ses-name2 (lisp::predict-name spec2 nil)) - (pname1 (pathname ses-name1)) - (pname2 (pathname ses-name2)) - (dirp2 (directoryp pname2)) - (wildp1 (wildcardp (file-namestring pname1))) - (wildp2 (wildcardp (file-namestring pname2)))) - (if (and dirp2 wildp2) - (funcall *error-function* - "Cannot have wildcards in directory names -- ~S." pname2)) - (if (and wildp2 (not wildp1)) - (funcall *error-function* - "Cannot handle destination having wildcards without ~ - source having wildcards.")) - (if (and wildp1 (not wildp2) (not dirp2)) - (funcall *error-function* - "Cannot handle source with wildcards and destination ~ - without, unless destination is a directory.")) - (if dirp2 - (rename-file-1 pname1 wildp1 exists1p (merge-pathnames pname2 - pname1) - wildp1 clobber) - (rename-file-1 pname1 wildp1 exists1p pname2 wildp2 clobber))))) - (directory - (when (pathname-directory spec1) - (funcall *error-function* - "Spec1 is just a pattern when supplying directory -- ~S." - spec1)) - - (let* ((pname2 (pathname (lisp::predict-name spec2 nil))) - (dirp2 (directoryp pname2)) - (wildp1 (wildcardp spec1)) - (wildp2 (wildcardp (file-namestring pname2)))) - (unless wildp1 - (funcall *error-function* - "Pattern, ~S, does not contain a wildcard." - spec1)) - (when (and (not wildp2) (not dirp2)) - (funcall *error-function* - "Cannot handle source with wildcards and destination ~ - without, unless destination is a directory.")) - (rename-wildcard-files spec1 wildp1 - (if dirp2 (merge-pathnames pname2 spec1) pname2) - (if dirp2 wildp1 wildp2) - clobber directory)))) - (values)) - -;;; RENAME-FILE-1 takes pathnames which either both contain a single wildcard -;;; or none. Wildp1 and Wildp2 are either nil or indexes into the -;;; file-namestring of pname1 and pname2, respectively, indicating the position -;;; of the wildcard character. If there is no wildcard, then simply call -;;; RENAME-FILE-2; otherwise, resolve the wildcard and rename those matching files. -;;; -(defun rename-file-1 (pname1 wildp1 exists1p pname2 wildp2 clobber) - (if wildp1 - (rename-wildcard-files pname1 wildp1 pname2 wildp2 clobber) - (let ((ses-name1 (namestring pname1))) - (unless exists1p (funcall *error-function* - "~S does not exist." ses-name1)) - (rename-file-2 ses-name1 (namestring pname2) clobber)))) - -(defun rename-wildcard-files (pname1 wildp1 pname2 wildp2 clobber - &optional directory) - (multiple-value-bind (dst-before dst-after) - (before-wildcard-after (file-namestring pname2) wildp2) - (dolist (match (resolve-wildcard pname1 wildp1 directory)) - (rename-file-2 (wild-match-file match) - (namestring (concatenate 'simple-string - (directory-namestring pname2) - dst-before - (wild-match-substitute match) - dst-after)) - clobber)))) - -(defun rename-file-2 (ses-name1 ses-name2 clobber) - (cond ((and (probe-file ses-name2) (not clobber)) - (when (funcall *yesp-function* - "~&~S ==> ~S~% ** Destination already exists. ~ - Overwrite it? " - ses-name1 ses-name2) - (sub-rename-file ses-name1 ses-name2) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2))) - (t (sub-rename-file ses-name1 ses-name2) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)))) - - - -;;;; Find-File - -(defun find-file (file-name &optional (directory "") - (find-all-p nil find-all-suppliedp)) - "Find the file with file-namestring file recursively looking in directory. - If find-all-p is non-nil, then do not stop searching upon finding the first - occurance of file. File may contain a single wildcard, which causes - find-all-p to default to t instead of nil." - (let* ((file (coerce file-name 'simple-string)) - (wildp (wildcardp file)) - (find-all-p (if find-all-suppliedp find-all-p wildp))) - (declare (simple-string file)) - (catch 'found-file - (if wildp - (multiple-value-bind (before after) - (before-wildcard-after file wildp) - (find-file-aux file directory find-all-p before after)) - (find-file-aux file directory find-all-p)))) - (values)) - -(defun find-file-aux (the-file directory find-all-p &optional before after) - (declare (simple-string the-file)) - (dolist (spec (directory directory)) - (let* ((spec-ses-name (namestring spec)) - (spec-file-name (file-namestring spec-ses-name))) - (declare (simple-string spec-ses-name spec-file-name)) - (if (directoryp spec) - (find-file-aux the-file spec find-all-p before after) - (when (if before - (find-match before after spec-file-name :no-cons) - (string-equal the-file spec-file-name)) - (print spec-ses-name) - (unless find-all-p (throw 'found-file t))))))) - - - -;;;; Delete-File - -;;; DELETE-FILE -;;; If spec is a directory, but recursive is nil, just pass the directory -;;; down through, letting LISP:DELETE-FILE signal an error if the directory -;;; is not empty. -;;; -(defun delete-file (spec &key (recursive *recursive-default*) - (clobber *clobber-default*)) - "Delete spec asking confirmation on each file if clobber is nil. A single - wildcard is acceptable. If recursive is non-nil, then a directory spec may - be given to recursively delete the entirety of the directory and its - subdirectory structure. An empty directory may be specified without - recursive being non-nil. When specifying a directory, the trailing slash - must be included." - (let* ((ses-name (lisp::predict-name spec t)) - (pname (pathname ses-name)) - (wildp (wildcardp (file-namestring pname))) - (dirp (directoryp pname))) - (if dirp - (if recursive - (recursive-delete pname ses-name clobber) - (delete-file-2 ses-name clobber)) - (delete-file-1 pname ses-name wildp clobber))) - (values)) - -(defun recursive-delete (directory dir-ses-name clobber) - (dolist (spec (directory (directory-namestring directory))) - (let ((spec-ses-name (namestring spec))) - (if (directoryp spec) - (recursive-delete (pathname spec-ses-name) spec-ses-name clobber) - (delete-file-2 spec-ses-name clobber)))) - (delete-file-2 dir-ses-name clobber)) - -(defun delete-file-1 (pname ses-name wildp clobber) - (if wildp - (dolist (match (resolve-wildcard pname wildp)) - (delete-file-2 (wild-match-file match) clobber)) - (delete-file-2 ses-name clobber))) - -(defun delete-file-2 (ses-name clobber) - (when (or clobber (funcall *yesp-function* "~&Delete ~S? " ses-name)) - (if (directoryp ses-name) - (delete-directory ses-name) - (lisp:delete-file ses-name)) - (funcall *report-function* "~&~A~%" ses-name))) - - - -;;;; Wildcard resolution - -(defun pathnames-from-pattern (pattern files) - "Return a list of pathnames from files whose file-namestrings match - pattern. Pattern must be a non-empty string and contains only one - asterisk. Files contains no directories." - (declare (simple-string pattern)) - (when (string= pattern "") - (funcall *error-function* "Must be a non-empty pattern.")) - (unless (= (count wildcard-char pattern :test #'char=) 1) - (funcall *error-function* "Pattern must contain one asterisk.")) - (multiple-value-bind (before after) - (before-wildcard-after pattern (wildcardp pattern)) - (let ((result nil)) - (dolist (f files result) - (let* ((ses-namestring (namestring f)) - (f-namestring (file-namestring ses-namestring)) - (match (find-match before after f-namestring))) - (when match (push f result))))))) - - -;;; RESOLVE-WILDCARD takes a pathname with a wildcard and the position of the -;;; wildcard character in the file-namestring and returns a list of wild-match -;;; objects. When directory is supplied, pname is just a pattern, or a -;;; file-namestring. It is an error for directory to be anything other than -;;; absolute pathnames in the same directory. Each wild-match object contains -;;; the Sesame namestring of a file in the same directory as pname, or -;;; directory, and a simple-string representing what the wildcard matched. -;;; -(defun resolve-wildcard (pname wild-pos &optional directory) - (multiple-value-bind (before after) - (before-wildcard-after (if directory - pname - (file-namestring pname)) - wild-pos) - (let (result) - (dolist (f (or directory (directory (directory-namestring pname))) - (nreverse result)) - (unless (directoryp f) - (let* ((ses-namestring (namestring f)) - (f-namestring (file-namestring ses-namestring)) - (match (find-match before after f-namestring))) - (if match - (push (make-wild-match ses-namestring match) result)))))))) - -;;; FIND-MATCH takes a "before wildcard" and "after wildcard" string and a -;;; file-namestring. If before and after match a substring of file-namestring -;;; and are respectively left bound and right bound, then anything left in -;;; between is the match returned. If no match is found, nil is returned. -;;; NOTE: if version numbers ever really exist, then this code will have to be -;;; changed since the file-namestring of a pathname contains the version number. -;;; -(defun find-match (before after file-namestring &optional no-cons) - (declare (simple-string before after file-namestring)) - (let ((before-len (length before)) - (after-len (length after)) - (name-len (length file-namestring))) - (if (>= name-len (+ before-len after-len)) - (let* ((start (if (string= before file-namestring - :end1 before-len :end2 before-len) - before-len)) - (end (- name-len after-len)) - (matchp (and start - (string= after file-namestring :end1 after-len - :start2 end :end2 name-len)))) - (if matchp - (if no-cons - t - (subseq file-namestring start end))))))) - -(defun before-wildcard-after (file-namestring wild-pos) - (declare (simple-string file-namestring)) - (values (subseq file-namestring 0 wild-pos) - (subseq file-namestring (1+ wild-pos) (length file-namestring)))) - - - -;;;; Miscellaneous Utilities (e.g., MAKEDIR). - -(defun make-directory (name) - "Creates directory name. If name exists, then an error is signaled." - (multiple-value-bind (ses-name existsp) - (lisp::predict-name name nil) - (when existsp (funcall *error-function* - "Name already exists -- ~S" ses-name)) - (enter-directory ses-name)) - t) - - - -;;;; Mach Operations - -(defun open-file (ses-name) - (multiple-value-bind (fd err) - (mach:unix-open ses-name mach:o_rdonly 0) - (unless fd - (funcall *error-function* "Opening ~S failed: ~A." ses-name err)) - fd)) - -(defun close-file (fd) - (mach:unix-close fd)) - -(defun read-file (fd ses-name) - (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size) - (mach:unix-fstat fd) - (declare (ignore ino nlink uid gid rdev)) - (unless winp (funcall *error-function* - "Opening ~S failed: ~A." ses-name dev-or-err)) - (let ((storage (lisp::fixnum-to-sap (allocate-storage size)))) - (multiple-value-bind (read-bytes err) - (mach:unix-read fd storage size) - (when (or (null read-bytes) (not (= size read-bytes))) - (dispose-storage storage size) - (funcall *error-function* - "Reading file ~S failed: ~A." ses-name err))) - (values storage size mode)))) - -(defun dispose-storage (storage size) - (mach::vm_deallocate lisp::*task-self* - (lisp::sap-to-fixnum storage) - size)) - -(defun allocate-storage (size) - (lisp::do-validate 0 size -1)) - -(defun write-file (ses-name data byte-count mode) - (multiple-value-bind (fd err) (mach:unix-creat ses-name #o644) - (unless fd - (funcall *error-function* "Couldn't create file ~S: ~A" - ses-name (mach:get-unix-error-msg err))) - (multiple-value-bind (winp err) (mach:unix-write fd data 0 byte-count) - (unless winp - (funcall *error-function* "Writing file ~S failed: ~A" - ses-name - (mach:get-unix-error-msg err)))) - (mach:unix-fchmod fd (logand mode #o777)) - (mach:unix-close fd))) - -(defvar *utimes-buffer* (make-list 4 :initial-element 0)) - -(defun set-write-date (ses-name secs) - (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime) - (mach:unix-stat ses-name) - (declare (ignore ino mode nlink uid gid rdev size)) - (unless winp (funcall *error-function* - "Couldn't stat file ~S failed: ~A." ses-name - dev-or-err)) - (setf (car *utimes-buffer*) atime) - (setf (caddr *utimes-buffer*) secs)) - (multiple-value-bind (winp err) (mach:unix-utimes ses-name *utimes-buffer*) - (unless winp - (funcall *error-function* "Couldn't set write date of file ~S: ~A" - ses-name - (mach:get-unix-error-msg err))))) - -(defun get-write-date (ses-name) - (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size - atime mtime) - (mach:unix-stat ses-name) - (declare (ignore ino mode nlink uid gid rdev size atime)) - (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A." - ses-name dev-or-err)) - mtime)) - -;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE. -;;; This is because it merges the new name with the old name to pick up -;;; defaults, and this conflicts with Unix-oid names. For example, renaming -;;; "foo.bar" to ".baz" causes a result of "foo.baz"! This routine doesn't -;;; have this problem. -;;; -(defun sub-rename-file (ses-name1 ses-name2) - (multiple-value-bind (res err) (mach:unix-rename ses-name1 ses-name2) - (unless res - (funcall *error-function* "Failed to rename ~A to ~A: ~A." - ses-name1 ses-name2 (mach:get-unix-error-msg err))))) - -(defun directory-existsp (ses-name) - (multiple-value-bind (winp type) - (mach:unix-subtestname ses-name) - (and winp (eq type :entry_directory)))) - -(defun enter-directory (ses-name) - (declare (simple-string ses-name)) - (let* ((length-1 (1- (length ses-name))) - (name (if (= (position #\/ ses-name :test #'char= :from-end t) - length-1) - (subseq ses-name 0 (1- (length ses-name))) - ses-name))) - (multiple-value-bind (winp err) (mach:unix-mkdir name #o755) - (unless winp - (funcall *error-function* "Couldn't make directory ~S: ~A" - name - (mach:get-unix-error-msg err)))))) - -(defun delete-directory (ses-name) - (declare (simple-string ses-name)) - (multiple-value-bind (winp err) - (mach:unix-rmdir (subseq ses-name 0 - (1- (length ses-name)))) - (unless winp - (funcall *error-function* "Couldn't delete directory ~S: ~A" - ses-name - (mach:get-unix-error-msg err))))) - - - -;;;; Misc. Utility Utilities - -;;; NSEPARATE-FILES destructively returns a list of file specs from listing. -(defun nseparate-files (listing) - (do (files hold) - ((null listing) files) - (setf hold (cdr listing)) - (unless (directoryp (car listing)) - (setf (cdr listing) files) - (setf files listing)) - (setf listing hold))) - - -(defun directoryp (p) - (not (or (pathname-name p) (pathname-type p)))) diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp deleted file mode 100644 index 7a95ef0339fd9525358444728b1482639328ebf1..0000000000000000000000000000000000000000 --- a/hemlock/diredcoms.lisp +++ /dev/null @@ -1,879 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Simple directory editing support. -;;; This file contains site dependent calls. -;;; -;;; Written by Blaine Burks and Bill Chiles. -;;; - -(in-package "HEMLOCK") - - -(defmode "Dired" :major-p t - :documentation - "Dired permits convenient directory browsing and file operations including - viewing, deleting, copying, renaming, and wildcard specifications.") - - -(defstruct (dired-information (:print-function print-dired-information) - (:conc-name dired-info-)) - pathname ; Pathname of directory. - pattern ; FILE-NAMESTRING with wildcard possibly. - dot-files-p ; Whether to include UNIX dot files. - write-date ; Write date of directory. - files ; Simple-vector of dired-file structures. - file-list) ; List of pathnames for files, excluding directories. - -(defun print-dired-information (obj str n) - (declare (ignore n)) - (format str "#<Dired Info ~S>" (namestring (dired-info-pathname obj)))) - - -(defstruct (dired-file (:print-function print-dired-file) - (:constructor make-dired-file (pathname))) - pathname - (deleted-p nil) - (write-date nil)) - -(defun print-dired-file (obj str n) - (declare (ignore n)) - (format str "#<Dired-file ~A>" (namestring (dired-file-pathname obj)))) - - - -;;;; "Dired" command. - -;;; *pathnames-to-dired-buffers* is an a-list mapping directory namestrings to -;;; buffers that display their contents. -;;; -(defvar *pathnames-to-dired-buffers* ()) - -(make-modeline-field - :name :dired-cmds :width 20 - :function - #'(lambda (buffer window) - (declare (ignore buffer window)) - " Type ? for help. ")) - -(defcommand "Dired" (p &optional directory) - "Prompt for a directory and edit it. If a dired for that directory already - exists, go to that buffer, otherwise create one. With an argument, include - UNIX dot files." - "Prompt for a directory and edit it. If a dired for that directory already - exists, go to that buffer, otherwise create one. With an argument, include - UNIX dot files." - (let ((info (if directory (value dired-information)))) - (dired-guts nil - ;; Propagate dot-files property to subdirectory edits. - (or (and info (dired-info-dot-files-p info)) - p) - directory))) - -(defcommand "Dired with Pattern" (p) - "Do a dired, prompting for a pattern which may include a single *. With an - argument, include UNIX dit files." - "Do a dired, prompting for a pattern which may include a single *. With an - argument, include UNIX dit files." - (dired-guts t p nil)) - -(defun dired-guts (patternp dot-files-p directory) - (let* ((dpn (value pathname-defaults)) - (directory (dired-directorify - (or directory - (prompt-for-file - :prompt "Edit Directory: " - :help "Pathname to edit." - :default (make-pathname - :device (pathname-device dpn) - :directory (pathname-directory dpn)) - :must-exist nil)))) - (pattern (if patternp - (prompt-for-string - :prompt "Filename pattern: " - :help "Type a filename with a single asterisk." - :trim t))) - (full-name (namestring (if pattern - (merge-pathnames directory pattern) - directory))) - (name (concatenate 'simple-string "Dired " full-name)) - (buffer (cdr (assoc full-name *pathnames-to-dired-buffers* - :test #'string=)))) - (declare (simple-string full-name)) - (setf (value pathname-defaults) (merge-pathnames directory dpn)) - (change-to-buffer - (cond (buffer - (when (and dot-files-p - (not (dired-info-dot-files-p - (variable-value 'dired-information - :buffer buffer)))) - (setf (dired-info-dot-files-p (variable-value 'dired-information - :buffer buffer)) - t) - (update-dired-buffer directory pattern buffer)) - buffer) - (t - (let ((buffer (make-buffer - name :modes '("Dired") - :modeline-fields - (append (value default-modeline-fields) - (list (modeline-field :dired-cmds))) - :delete-hook (list 'dired-buffer-delete-hook)))) - (unless (initialize-dired-buffer directory pattern - dot-files-p buffer) - (delete-buffer-if-possible buffer) - (editor-error "No entries for ~A." full-name)) - (push (cons full-name buffer) *pathnames-to-dired-buffers*) - buffer)))))) - -;;; INITIALIZE-DIRED-BUFFER gets a dired in the buffer and defines some -;;; variables to make it usable as a dired buffer. If there are no file -;;; satisfying directory, then this returns nil, otherwise t. -;;; -(defun initialize-dired-buffer (directory pattern dot-files-p buffer) - (multiple-value-bind (pathnames dired-files) - (dired-in-buffer directory pattern dot-files-p buffer) - (if (zerop (length dired-files)) - nil - (defhvar "Dired Information" - "Contains the information neccessary to manipulate dired buffers." - :buffer buffer - :value (make-dired-information :pathname directory - :pattern pattern - :dot-files-p dot-files-p - :write-date (file-write-date directory) - :files dired-files - :file-list pathnames))))) - -;;; CALL-PRINT-DIRECTORY gives us a nice way to report PRINT-DIRECTORY errors -;;; to the user and to clean up the dired buffer. -;;; -(defun call-print-directory (directory mark dot-files-p) - (handler-case (with-output-to-mark (s mark :full) - (print-directory directory s - :all dot-files-p :verbose t :return-list t)) - (error (condx) - (delete-buffer-if-possible (line-buffer (mark-line mark))) - (editor-error "~A" condx)))) - -;;; DIRED-BUFFER-DELETE-HOOK is called on dired buffers upon deletion. This -;;; removes the buffer from the pathnames mapping, and it deletes and buffer -;;; local variables referring to it. -;;; -(defun dired-buffer-delete-hook (buffer) - (setf *pathnames-to-dired-buffers* - (delete buffer *pathnames-to-dired-buffers* :test #'eq :key #'cdr))) - - - -;;;; Dired deletion and undeletion. - -(defcommand "Dired Delete File" (p) - "Marks a file for deletion; signals an error if not in a dired buffer. - With an argument, this prompts for a pattern that may contain at most one - wildcard, an asterisk, and all names matching the pattern will be flagged - for deletion." - "Marks a file for deletion; signals an error if not in a dired buffer." - (dired-frob-deletion p t)) - -(defcommand "Dired Undelete File" (p) - "Removes a mark for deletion; signals and error if not in a dired buffer. - With an argument, this prompts for a pattern that may contain at most one - wildcard, an asterisk, and all names matching the pattern will be unflagged - for deletion." - "Removes a mark for deletion; signals and error if not in a dired buffer." - (dired-frob-deletion p nil)) - -(defcommand "Dired Delete File and Down Line" (p) - "Marks file for deletion and moves down a line. - See \"Dired Delete File\"." - "Marks file for deletion and moves down a line. - See \"Dired Delete File\"." - (declare (ignore p)) - (dired-frob-deletion nil t) - (dired-down-line (current-point))) - -(defcommand "Dired Undelete File and Down Line" (p) - "Marks file undeleted and moves down a line. - See \"Dired Delete File\"." - "Marks file undeleted and moves down a line. - See \"Dired Delete File\"." - (declare (ignore p)) - (dired-frob-deletion nil nil) - (dired-down-line (current-point))) - -(defcommand "Dired Delete File with Pattern" (p) - "Prompts for a pattern and marks matching files for deletion. - See \"Dired Delete File\"." - "Prompts for a pattern and marks matching files for deletion. - See \"Dired Delete File\"." - (declare (ignore p)) - (dired-frob-deletion t t) - (dired-down-line (current-point))) - -(defcommand "Dired Undelete File with Pattern" (p) - "Prompts for a pattern and marks matching files undeleted. - See \"Dired Delete File\"." - "Prompts for a pattern and marks matching files undeleted. - See \"Dired Delete File\"." - (declare (ignore p)) - (dired-frob-deletion t nil) - (dired-down-line (current-point))) - -;;; DIRED-FROB-DELETION takes arguments indicating whether to prompt for a -;;; pattern and whether to mark the file deleted or undeleted. This uses -;;; CURRENT-POINT and CURRENT-BUFFER, and if not in a dired buffer, signal -;;; an error. -;;; -(defun dired-frob-deletion (patternp deletep) - (unless (hemlock-bound-p 'dired-information) - (editor-error "Not in Dired buffer.")) - (with-mark ((mark (current-point) :left-inserting)) - (let* ((dir-info (value dired-information)) - (files (dired-info-files dir-info)) - (del-files - (if patternp - (dired:pathnames-from-pattern - (prompt-for-string - :prompt "Filename pattern: " - :help "Type a filename with a single asterisk." - :trim t) - (dired-info-file-list dir-info)) - (list (dired-file-pathname - (array-element-from-mark mark files))))) - (note-char (if deletep #\D #\space))) - (with-writable-buffer ((current-buffer)) - (dolist (f del-files) - (let* ((pos (position f files :test #'equal - :key #'dired-file-pathname)) - (dired-file (svref files pos))) - (buffer-start mark) - (line-offset mark pos 0) - (setf (dired-file-deleted-p dired-file) deletep) - (if deletep - (setf (dired-file-write-date dired-file) - (file-write-date (dired-file-pathname dired-file))) - (setf (dired-file-write-date dired-file) nil)) - (setf (next-character mark) note-char))))))) - -(defun dired-down-line (point) - (line-offset point 1) - (when (blank-line-p (mark-line point)) - (line-offset point -1))) - - - -;;;; Dired file finding and going to dired buffers. - -(defcommand "Dired Edit File" (p) - "Read in file or recursively \"Dired\" a directory." - "Read in file or recursively \"Dired\" a directory." - (declare (ignore p)) - (let ((point (current-point))) - (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) - (let ((pathname (dired-file-pathname - (array-element-from-mark - point (dired-info-files (value dired-information)))))) - (if (directoryp pathname) - (dired-command nil (directory-namestring pathname)) - (change-to-buffer (find-file-buffer pathname)))))) - -(defcommand "Dired View File" (p) - "Read in file as if by \"View File\" or recursively \"Dired\" a directory. - This associates the file's buffer with the dired buffer." - "Read in file as if by \"View File\". - This associates the file's buffer with the dired buffer." - (declare (ignore p)) - (let ((point (current-point))) - (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) - (let ((pathname (dired-file-pathname - (array-element-from-mark - point (dired-info-files (value dired-information)))))) - (if (directoryp pathname) - (dired-command nil (directory-namestring pathname)) - (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))))))))) - -(defcommand "Dired from Buffer Pathname" (p) - "Invokes \"Dired\" on the directory part of the current buffer's pathname. - With an argument, also prompt for a file pattern within that directory." - "Invokes \"Dired\" on the directory part of the current buffer's pathname. - With an argument, also prompt for a file pattern within that directory." - (let ((pathname (buffer-pathname (current-buffer)))) - (if pathname - (dired-command p (directory-namestring pathname)) - (editor-error "No pathname associated with buffer.")))) - - - -;;;; Dired misc. commands -- update, help, line motion. - -(defcommand "Dired Update Buffer" (p) - "Recompute the contents of a dired buffer. - This maintains delete flags for files that have not been modified." - "Recompute the contents of a dired buffer. - This maintains delete flags for files that have not been modified." - (declare (ignore p)) - (unless (hemlock-bound-p 'dired-information) - (editor-error "Not in Dired buffer.")) - (let ((buffer (current-buffer)) - (dir-info (value dired-information))) - (update-dired-buffer (dired-info-pathname dir-info) - (dired-info-pattern dir-info) - buffer))) - -;;; UPDATE-DIRED-BUFFER updates buffer with a dired of directory, deleting -;;; whatever is in the buffer already. This assumes buffer was previously -;;; used as a dired buffer having necessary variables bound. The new files -;;; are compared to the old ones propagating any deleted flags if the name -;;; and the write date is the same for both specifications. -;;; -(defun update-dired-buffer (directory pattern buffer) - (with-writable-buffer (buffer) - (delete-region (buffer-region buffer)) - (let ((dir-info (variable-value 'dired-information :buffer buffer))) - (multiple-value-bind (pathnames new-dired-files) - (dired-in-buffer directory pattern - (dired-info-dot-files-p dir-info) - buffer) - (let ((point (buffer-point buffer)) - (old-dired-files (dired-info-files dir-info))) - (declare (simple-vector old-dired-files)) - (dotimes (i (length old-dired-files)) - (let ((old-file (svref old-dired-files i))) - (when (dired-file-deleted-p old-file) - (let ((pos (position (dired-file-pathname old-file) - new-dired-files :test #'equal - :key #'dired-file-pathname))) - (when pos - (let* ((new-file (svref new-dired-files pos)) - (write-date (file-write-date - (dired-file-pathname new-file)))) - (when (= (dired-file-write-date old-file) write-date) - (setf (dired-file-deleted-p new-file) t) - (setf (dired-file-write-date new-file) write-date) - (setf (next-character - (line-offset (buffer-start point) pos 0)) - #\D)))))))) - (setf (dired-info-files dir-info) new-dired-files) - (setf (dired-info-file-list dir-info) pathnames) - (setf (dired-info-write-date dir-info) - (file-write-date directory)) - (move-mark point (buffer-start-mark buffer))))))) - -;;; DIRED-IN-BUFFER inserts a dired listing of directory in buffer returning -;;; two values: a list of pathnames of files only, and an array of dired-file -;;; structures. This uses FILTER-REGION to insert a space for the indication -;;; of whether the file is flagged for deletion. Then we clean up extra header -;;; and trailing lines known to be in the output (into every code a little -;;; slime must fall). -;;; -(defun dired-in-buffer (directory pattern dot-files-p buffer) - (let ((point (buffer-point buffer))) - (with-writable-buffer (buffer) - (let* ((pathnames (call-print-directory - (if pattern - (merge-pathnames directory pattern) - directory) - point - dot-files-p)) - (dired-files (make-array (length pathnames)))) - (declare (list pathnames) (simple-vector dired-files)) - (filter-region #'(lambda (str) - (concatenate 'simple-string " " str)) - (buffer-region buffer)) - (delete-characters point -2) - (delete-region (line-to-region (mark-line (buffer-start point)))) - (delete-characters point) - (do ((p pathnames (cdr p)) - (i 0 (1+ i))) - ((null p)) - (setf (svref dired-files i) (make-dired-file (car p)))) - (values (delete-if #'directoryp pathnames) dired-files))))) - - -(defcommand "Dired Help" (p) - "How to use dired." - "How to use dired." - (declare (ignore p)) - (describe-mode-command nil "Dired")) - -(defcommand "Dired Next File" (p) - "Moves to next undeleted file." - "Moves to next undeleted file." - (declare (ignore p)) - (unless (dired-line-offset (current-point) (or p 1)) - (editor-error "Not enough lines."))) - -(defcommand "Dired Previous File" (p) - "Moves to previous undeleted file." - "Moves to next undeleted file." - (declare (ignore p)) - (unless (dired-line-offset (current-point) (or p -1)) - (editor-error "Not enough lines."))) - -;;; DIRED-LINE-OFFSET moves mark n undeleted file lines, returning mark. If -;;; there are not enough lines, mark remains unmoved, this returns nil. -;;; -(defun dired-line-offset (mark n) - (with-mark ((m mark)) - (let ((step (if (plusp n) 1 -1))) - (dotimes (i (abs n) (move-mark mark m)) - (loop - (unless (line-offset m step 0) - (return-from dired-line-offset nil)) - (when (blank-line-p (mark-line m)) - (return-from dired-line-offset nil)) - (when (char= (next-character m) #\space) - (return))))))) - - - -;;;; Dired user interaction functions. - -(defun dired-error-function (string &rest args) - (apply #'editor-error string args)) - -(defun dired-report-function (string &rest args) - (clear-echo-area) - (apply #'message string args)) - -(defun dired-yesp-function (string &rest args) - (prompt-for-y-or-n :prompt (cons string args) :default t)) - - - -;;;; Dired expunging and quitting. - -(defcommand "Dired Expunge Files" (p) - "Expunges files marked for deletion. - Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do - the same with directories and the value of \"Dired Directory Expunge - Confirm\"." - "Expunges files marked for deletion. - Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do - the same with directories and the value of \"Dired Directory Expunge - Confirm\"." - (declare (ignore p)) - (when (expunge-dired-files) - (dired-update-buffer-command nil)) - (maintain-dired-consistency)) - -(defcommand "Dired Quit" (p) - "Expunges the files in a dired buffer and then exits." - "Expunges the files in a dired buffer and then exits." - (declare (ignore p)) - (expunge-dired-files) - (delete-buffer-if-possible (current-buffer))) - -(defhvar "Dired File Expunge Confirm" - "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask - for confirmation before deleting the marked files." - :value t) - -(defhvar "Dired Directory Expunge Confirm" - "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask - for confirmation before deleting each marked directory." - :value t) - -(defun expunge-dired-files () - (multiple-value-bind (marked-files marked-dirs) (get-marked-dired-files) - (let ((dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function) - (we-did-something nil)) - (when (and marked-files - (or (not (value dired-file-expunge-confirm)) - (prompt-for-y-or-n :prompt "Really delete files? " - :default t - :must-exist t - :default-string "Y"))) - (setf we-did-something t) - (dolist (file-info marked-files) - (let ((pathname (car file-info)) - (write-date (cdr file-info))) - (if (= write-date (file-write-date pathname)) - (dired:delete-file (namestring pathname) :clobber t - :recursive nil) - (message "~A has been modified, it remains unchanged." - (namestring pathname)))))) - (when marked-dirs - (dolist (dir-info marked-dirs) - (let ((dir (car dir-info)) - (write-date (cdr dir-info))) - (if (= write-date (file-write-date dir)) - (when (or (not (value dired-directory-expunge-confirm)) - (prompt-for-y-or-n - :prompt (list "~a is a directory. Delete it? " - (directory-namestring dir)) - :default t - :must-exist t - :default-string "Y")) - (dired:delete-file (directory-namestring dir) :clobber t - :recursive t) - (setf we-did-something t)) - (message "~A has been modified, it remains unchanged."))))) - we-did-something))) - - - -;;;; Dired copying and renaming. - -(defhvar "Dired Copy File Confirm" - "Can be either t, nil, or :update. T means always query before clobbering an - existing file, nil means don't query before clobbering an existing file, and - :update means only ask if the existing file is newer than the source." - :value T) - -(defhvar "Dired Rename File Confirm" - "When non-nil, dired will query before clobbering an existing file." - :value T) - -(defcommand "Dired Copy File" (p) - "Copy the file under the point" - "Copy the file under the point" - (declare (ignore p)) - (let* ((point (current-point)) - (confirm (value dired-copy-file-confirm)) - (source (dired-file-pathname - (array-element-from-mark - point (dired-info-files (value dired-information))))) - (dest (prompt-for-file - :prompt (if (directoryp source) - "Destination Directory Name: " - "Destination Filename: ") - :help "Name of new file." - :default source - :must-exist nil)) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - (dired:copy-file source dest :update (if (eq confirm :update) t nil) - :clobber (not confirm))) - (maintain-dired-consistency)) - -(defcommand "Dired Rename File" (p) - "Rename the file or directory under the point" - "Rename the file or directory under the point" - (declare (ignore p)) - (let* ((point (current-point)) - (source (dired-namify (dired-file-pathname - (array-element-from-mark - point - (dired-info-files (value dired-information)))))) - (dest (prompt-for-file - :prompt "New Filename: " - :help "The new name for this file." - :default source - :must-exist nil)) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - ;; ARRAY-ELEMENT-FROM-MARK moves mark to line start. - (dired:rename-file source dest :clobber (value dired-rename-file-confirm))) - (maintain-dired-consistency)) - -(defcommand "Dired Copy with Wildcard" (p) - "Copy files that match a pattern containing ONE wildcard." - "Copy files that match a pattern containing ONE wildcard." - (declare (ignore p)) - (let* ((dir-info (value dired-information)) - (confirm (value dired-copy-file-confirm)) - (pattern (prompt-for-string - :prompt "Filename pattern: " - :help "Type a filename with a single asterisk." - :trim t)) - (destination (namestring - (prompt-for-file - :prompt "Destination Spec: " - :help "Destination spec. May contain ONE asterisk." - :default (dired-info-pathname dir-info) - :must-exist nil))) - (dired:*error-function* #'dired-error-function) - (dired:*yesp-function* #'dired-yesp-function) - (dired:*report-function* #'dired-report-function)) - (dired:copy-file pattern destination :update (if (eq confirm :update) t nil) - :clobber (not confirm) - :directory (dired-info-file-list dir-info))) - (maintain-dired-consistency)) - -(defcommand "Dired Rename with Wildcard" (p) - "Rename files that match a pattern containing ONE wildcard." - "Rename files that match a pattern containing ONE wildcard." - (declare (ignore p)) - (let* ((dir-info (value dired-information)) - (pattern (prompt-for-string - :prompt "Filename pattern: " - :help "Type a filename with a single asterisk." - :trim t)) - (destination (namestring - (prompt-for-file - :prompt "Destination Spec: " - :help "Destination spec. May contain ONE asterisk." - :default (dired-info-pathname dir-info) - :must-exist nil))) - (dired:*error-function* #'dired-error-function) - (dired:*yesp-function* #'dired-yesp-function) - (dired:*report-function* #'dired-report-function)) - (dired:rename-file pattern destination - :clobber (not (value dired-rename-file-confirm)) - :directory (dired-info-file-list dir-info))) - (maintain-dired-consistency)) - -(defcommand "Delete File" (p) - "Delete a file. Specify directories with a trailing slash." - "Delete a file. Specify directories with a trailing slash." - (declare (ignore p)) - (let* ((spec (namestring - (prompt-for-file - :prompt "Delete File: " - :help '("Name of File or Directory to delete. ~ - One wildcard is permitted.") - :must-exist nil))) - (directoryp (directoryp spec)) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - (when (or (not directoryp) - (not (value dired-directory-expunge-confirm)) - (prompt-for-y-or-n - :prompt (list "~A is a directory. Delete it? " - (directory-namestring spec)) - :default t :must-exist t :default-string "Y"))) - (dired:delete-file spec :recursive t - :clobber (or directoryp - (value dired-file-expunge-confirm)))) - (maintain-dired-consistency)) - -(defcommand "Copy File" (p) - "Copy a file, allowing ONE wildcard." - "Copy a file, allowing ONE wildcard." - (declare (ignore p)) - (let* ((confirm (value dired-copy-file-confirm)) - (source (namestring - (prompt-for-file - :prompt "Source Filename: " - :help "Name of File to copy. One wildcard is permitted." - :must-exist nil))) - (dest (namestring - (prompt-for-file - :prompt (if (directoryp source) - "Destination Directory Name: " - "Destination Filename: ") - :help "Name of new file." - :default source - :must-exist nil))) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - (dired:copy-file source dest :update (if (eq confirm :update) t nil) - :clobber (not confirm))) - (maintain-dired-consistency)) - -(defcommand "Rename File" (p) - "Rename a file, allowing ONE wildcard." - "Rename a file, allowing ONE wildcard." - (declare (ignore p)) - (let* ((source (namestring - (prompt-for-file - :prompt "Source Filename: " - :help "Name of file to rename. One wildcard is permitted." - :must-exist nil))) - (dest (namestring - (prompt-for-file - :prompt (if (directoryp source) - "Destination Directory Name: " - "Destination Filename: ") - :help "Name of new file." - :default source - :must-exist nil))) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - (dired:rename-file source dest - :clobber (not (value dired-rename-file-confirm)))) - (maintain-dired-consistency)) - -(defun maintain-dired-consistency () - (dolist (info *pathnames-to-dired-buffers*) - (let* ((directory (directory-namestring (car info))) - (buffer (cdr info)) - (dir-info (variable-value 'dired-information :buffer buffer)) - (write-date (file-write-date directory))) - (unless (= (dired-info-write-date dir-info) write-date) - (update-dired-buffer directory (dired-info-pattern dir-info) buffer))))) - - - -;;;; Dired utilities. - -;;; GET-MARKED-DIRED-FILES returns as multiple values a list of file specs -;;; and a list of directory specs that have been marked for deletion. This -;;; assumes the current buffer is a "Dired" buffer. -;;; -(defun get-marked-dired-files () - (let* ((files (dired-info-files (value dired-information))) - (length (length files)) - (marked-files ()) - (marked-dirs ())) - (unless files (editor-error "Not in Dired buffer.")) - (do ((i 0 (1+ i))) - ((= i length) (values (nreverse marked-files) (nreverse marked-dirs))) - (let* ((thing (svref files i)) - (pathname (dired-file-pathname thing))) - (when (dired-file-deleted-p thing) - (if (directoryp pathname) - (push (cons pathname (file-write-date pathname)) marked-dirs) - (push (cons pathname (file-write-date pathname)) - marked-files))))))) - -;;; ARRAY-ELEMENT-FROM-MARK counts the lines between it and the beginning -;;; of the buffer. The number is used to index vector as if each line -;;; mapped to an element starting with the zero'th element (lines are -;;; numbered starting at 1). -;;; -(defun array-element-from-mark (mark vector - &optional (error-msg "Invalid line.")) - (when (blank-line-p (mark-line mark)) (editor-error error-msg)) - (svref vector - (1- (count-lines (region - (buffer-start-mark (line-buffer (mark-line mark))) - mark))))) - -;;; DIRED-NAMIFY and DIRED-DIRECTORIFY are implementation dependent slime. -;;; -(defun dired-namify (pathname) - (let* ((string (namestring pathname)) - (last (1- (length string)))) - (if (char= (schar string last) #\/) - (subseq string 0 last) - string))) -;;; -;;; This is necessary to derive a canonical representation for directory -;;; names, so "Dired" can map various strings naming one directory to that -;;; one directory. -;;; -(defun dired-directorify (pathname) - (let ((directory (lisp::predict-name pathname t))) - (if (directoryp directory) - directory - (pathname (concatenate 'simple-string (namestring directory) "/"))))) - - - -;;;; View Mode. - -(defmode "View" :major-p nil - :setup-function 'setup-view-mode - :cleanup-function 'cleanup-view-mode - :precedence 5.0 - :documentation - "View mode scrolls forwards and backwards in a file with the buffer read-only. - Scrolling off the end optionally deletes the buffer.") - -(defun setup-view-mode (buffer) - (defhvar "View Return Function" - "Function that gets called when quitting or returning from view mode." - :value nil - :buffer buffer) - (setf (buffer-writable buffer) nil)) -;;; -(defun cleanup-view-mode (buffer) - (delete-variable 'view-return-function :buffer buffer) - (setf (buffer-writable buffer) t)) - -(defcommand "View File" (p &optional pathname) - "Reads a file in as if by \"Find File\", but read-only. Commands exist - for scrolling convenience." - "Reads a file in as if by \"Find File\", but read-only. Commands exist - for scrolling convenience." - (declare (ignore p)) - (let* ((pn (or pathname - (prompt-for-file - :prompt "View File: " :must-exist t - :help "Name of existing file to read into its own buffer." - :default (buffer-default-pathname (current-buffer))))) - (buffer (make-buffer (format nil "View File ~A" (gensym))))) - (visit-file-command nil pn buffer) - (setf (buffer-minor-mode buffer "View") t) - (change-to-buffer buffer) - buffer)) - -(defcommand "View Return" (p) - "Return to a parent buffer, if it exists." - "Return to a parent buffer, if it exists." - (declare (ignore p)) - (unless (call-view-return-fun) - (editor-error "No View return method for this buffer."))) - -(defcommand "View Quit" (p) - "Delete a buffer in view mode." - "Delete a buffer in view mode, invoking VIEW-RETURN-FUNCTION if it exists for - this buffer." - (declare (ignore p)) - (let* ((buf (current-buffer)) - (funp (call-view-return-fun))) - (delete-buffer-if-possible buf) - (unless funp (editor-error "No View return method for this buffer.")))) - -;;; CALL-VIEW-RETURN-FUN returns nil if there is no current -;;; view-return-function. If there is one, it calls it and returns t. -;;; -(defun call-view-return-fun () - (if (hemlock-bound-p 'view-return-function) - (let ((fun (value view-return-function))) - (cond (fun - (funcall fun) - t))))) - - -(defhvar "View Scroll Deleting Buffer" - "When this is set, \"View Scroll Down\" deletes the buffer when the end - of the file is visible." - :value t) - -(defcommand "View Scroll Down" (p) - "Scroll the current window down through its buffer. - If the end of the file is visible, then delete the buffer if \"View Scroll - Deleting Buffer\" is set. If the buffer is associated with a dired buffer, - this returns there instead of to the previous buffer." - "Scroll the current window down through its buffer. - If the end of the file is visible, then delete the buffer if \"View Scroll - Deleting Buffer\" is set. If the buffer is associated with a dired buffer, - this returns there instead of to the previous buffer." - (if (and (not p) - (displayed-p (buffer-end-mark (current-buffer)) - (current-window)) - (value view-scroll-deleting-buffer)) - (view-quit-command nil) - (scroll-window-down-command p))) - -(defcommand "View Edit File" (p) - "Turn off \"View\" mode in this buffer." - "Turn off \"View\" mode in this buffer." - (declare (ignore p)) - (let ((buf (current-buffer))) - (setf (buffer-minor-mode buf "View") nil) - (warn-about-visit-file-buffers buf))) - -(defcommand "View Help" (p) - "Shows \"View\" mode help message." - "Shows \"View\" mode help message." - (declare (ignore p)) - (describe-mode-command nil "View")) diff --git a/hemlock/display.lisp b/hemlock/display.lisp deleted file mode 100644 index fe5c21ffaa99884c2e86bbbe6589190f51d738a4..0000000000000000000000000000000000000000 --- a/hemlock/display.lisp +++ /dev/null @@ -1,243 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles. -;;; -;;; This is the device independent redisplay entry points for Hemlock. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(redisplay redisplay-all)) - - - -;;;; Main redisplay entry points. - -(defvar *things-to-do-once* () - "This is a list of lists of functions and args to be applied to. The - functions are called with args supplied at the top of the command loop.") - -(defvar *screen-image-trashed* () - "This variable is set to true if the screen has been trashed by some screen - manager operation, and thus should be totally refreshed. This is currently - only used by tty redisplay.") - -(proclaim '(special *window-list*)) - -(eval-when (compile eval) - -;;; REDISPLAY-LOOP binds win-var to each window that is not the -;;; *current-window*, and calls the executes the general-form after executing -;;; the current-window-form. Then we put the cursor in the appropriate place -;;; and force output. Routines such as REDISPLAY and REDISPLAY-ALL want to -;;; invoke the after-redisplay method to make sure we've handled any events -;;; generated from redisplaying. This is in case some user loops over one of -;;; these for a long time without going through Hemlock's input loop and event -;;; handling. Routines such as INTERNAL-REDISPLAY don't want to worry about -;;; this since they are called from the input/event-handling loop. -;;; -(defmacro redisplay-loop ((win-var) general-form current-window-form - &optional (afterp t)) - (let ((device (gensym)) (point (gensym)) (hunk (gensym))) - `(progn - ,current-window-form - (dolist (,win-var *window-list*) - (unless (eq ,win-var *current-window*) ,general-form)) - (let* ((,hunk (window-hunk *current-window*)) - (,device (device-hunk-device ,hunk)) - (,point (window-point *current-window*))) - (move-mark ,point (buffer-point (window-buffer *current-window*))) - (multiple-value-bind (x y) (mark-to-cursorpos ,point *current-window*) - (unless x (error "??? Cursor not on the screen ???")) - (funcall (device-put-cursor ,device) ,hunk x y)) - (when (device-force-output ,device) - (funcall (device-force-output ,device))) - ,@(if afterp - `((when (device-after-redisplay ,device) - (funcall (device-after-redisplay ,device) ,device)))) - t)))) - -) ;eval-when - - -;;; REDISPLAY -- Public -;;; -;;; This function updates the display of all windows which need it. -;;; it assumes it's internal representation of the screen is accurate -;;; and attempts to do the minimal amount of output to bring the screen -;;; into correspondence. *screen-image-trashed* is only used by terminal -;;; redisplay. -;;; -(defun redisplay () - "The main entry into redisplay; updates any windows that seem to need it." - (when *things-to-do-once* - (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) - (setq *things-to-do-once* nil)) - (cond (*screen-image-trashed* - (setq *screen-image-trashed* nil) - (redisplay-all)) - (t - (catch 'redisplay-catcher - (redisplay-loop (w) - (redisplay-window w) - (redisplay-window-recentering *current-window*)))))) - - -;;; REDISPLAY-ALL -- Public -;;; -;;; Update the screen making no assumptions about what is on it. -;;; useful if the screen (or redisplay) gets trashed. Since windows -;;; potentially may be on different devices, we have to go through the -;;; list clearing all possible devices. -;;; -(defun redisplay-all () - "An entry into redisplay; causes all windows to be fully refreshed." - (let ((cleared-devices nil)) - (dolist (w *window-list*) - (let* ((hunk (window-hunk w)) - (device (device-hunk-device hunk))) - (unless (member device cleared-devices :test #'eq) - (when (device-clear device) - (funcall (device-clear device) device)) - ;; - ;; It's cleared whether we did clear it or there was no method. - (push device cleared-devices))))) - (redisplay-loop (w) - (redisplay-window-all w) - (progn - (setf (window-tick *current-window*) (tick)) - (update-window-image *current-window*) - (maybe-recenter-window *current-window*) - (funcall (device-dumb-redisplay - (device-hunk-device (window-hunk *current-window*))) - *current-window*)))) - - - -;;;; Internal redisplay entry points. - -(defun internal-redisplay () - "The main internal entry into redisplay. This is just like REDISPLAY, but it - doesn't call the device's after-redisplay method." - (when *things-to-do-once* - (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) - (setq *things-to-do-once* nil)) - (cond (*screen-image-trashed* - (setq *screen-image-trashed* nil) - (redisplay-all)) - (t - (catch 'redisplay-catcher - (redisplay-loop (w) - (redisplay-window w) - (redisplay-window-recentering *current-window*) - nil))))) - -;;; REDISPLAY-WINDOWS-FROM-MARK is called from the hemlock-output-stream -;;; methods to bring the screen up to date. It only redisplays windows which -;;; are displaying the buffer concerned, and doesn't deal with making the -;;; cursor track the point. *screen-image-trashed* is only used by terminal -;;; redisplay. This must call the device after-redisplay method since stream -;;; output may be done repeatedly without ever returning to the main Hemlock -;;; read loop and event servicing. -;;; -(defun redisplay-windows-from-mark (mark) - (when *things-to-do-once* - (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) - (setq *things-to-do-once* nil)) - (cond (*screen-image-trashed* - (redisplay-all) - (setq *screen-image-trashed* nil)) - (t - (catch 'redisplay-catcher - (let ((buffer (line-buffer (mark-line mark)))) - (when buffer - (flet ((frob (win) - (let* ((device (device-hunk-device (window-hunk win))) - (force (device-force-output device)) - (after (device-after-redisplay device))) - (when force (funcall force)) - (when after (funcall after device))))) - (let ((windows (buffer-windows buffer))) - (when (member *current-window* windows :test #'eq) - (redisplay-window-recentering *current-window*) - (frob *current-window*)) - (dolist (window windows) - (unless (eq window *current-window*) - (redisplay-window window) - (frob window))))))))))) - -(defun redisplay-window (window) - "Maybe updates the window's image and calls the device's smart redisplay - method. NOTE: the smart redisplay method may throw to - 'hi::redisplay-catcher to abort redisplay." - (maybe-update-window-image window) - (funcall (device-smart-redisplay (device-hunk-device (window-hunk window))) - window)) - -(defun redisplay-window-all (window) - "Updates the window's image and calls the device's dumb redisplay method." - (setf (window-tick window) (tick)) - (update-window-image window) - (funcall (device-dumb-redisplay (device-hunk-device (window-hunk window))) - window)) - -(defun random-typeout-redisplay (window) - (catch 'redisplay-catcher - (maybe-update-window-image window) - (let* ((device (device-hunk-device (window-hunk window))) - (force (device-force-output device))) - (funcall (device-smart-redisplay device) window) - (when force (funcall force))))) - - -;;;; Support for redisplay entry points. - -;;; REDISPLAY-WINDOW-RECENTERING tries to be clever about updating the window -;;; image unnecessarily, recenters the window if the window's buffer's point -;;; moved off the window, and does a smart redisplay. We call the redisplay -;;; method even if we didn't update the image or recenter because someone -;;; else may have modified the window's image and already have updated it; -;;; if nothing happened, then the smart method shouldn't do anything anyway. -;;; NOTE: the smart redisplay method may throw to 'hi::redisplay-catcher to -;;; abort redisplay. -;;; -(defun redisplay-window-recentering (window) - (setup-for-recentering-redisplay window) - (invoke-hook ed::redisplay-hook window) - (setup-for-recentering-redisplay window) - (funcall (device-smart-redisplay (device-hunk-device (window-hunk window))) - window)) - -(defun setup-for-recentering-redisplay (window) - (let* ((display-start (window-display-start window)) - (old-start (window-old-start window))) - ;; - ;; If the start is in the middle of a line and it wasn't before, - ;; then move the start there. - (when (and (same-line-p display-start old-start) - (not (start-line-p display-start)) - (start-line-p old-start)) - (line-start display-start)) - (maybe-update-window-image window) - (maybe-recenter-window window))) - - -;;; MAYBE-UPDATE-WINDOW-IMAGE only updates if the text has changed or the -;;; display start. -;;; -(defun maybe-update-window-image (window) - (when (or (> (buffer-modified-tick (window-buffer window)) - (window-tick window)) - (mark/= (window-display-start window) - (window-old-start window))) - (setf (window-tick window) (tick)) - (update-window-image window) - t)) diff --git a/hemlock/doccoms.lisp b/hemlock/doccoms.lisp deleted file mode 100644 index 1a937c2d44d7a7945d5f295cdaa1a584af7eaff8..0000000000000000000000000000000000000000 --- a/hemlock/doccoms.lisp +++ /dev/null @@ -1,434 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock Documentation and Help commands. -;;; Written by Rob MacLachlan and Bill Chiles. -;;; - -(in-package "HEMLOCK") - - - -;;;; Help. - -(defcommand "Help" (p) - "Give helpful information. - This command dispatches to a number of other documentation commands, - on the basis of a character command." - "Prompt for a single character command to dispatch to another helping - function." - (declare (ignore p)) - (command-case (:prompt "Doc (Help for Help): " - :help "Type a Help option to say what kind of help you want:") - (#\A "List all commands, variables and attributes Apropos a keyword." - (apropos-command nil)) - (#\D "Describe a command, given its name." - (describe-command-command nil)) - (#\G "Generic describe, any Hemlock thing (e.g., variables, keys, attributes)." - (generic-describe-command nil)) - (#\V "Describe variable and show its values." - (describe-and-show-variable-command nil)) - (#\C "Describe the command bound to a Character." - (describe-key-command nil)) - (#\L "List the last 60 characters typed." - (what-lossage-command nil)) - (#\M "Describe a mode." - (describe-mode-command nil)) - (#\P "Describe commands with mouse/pointer bindings." - (describe-pointer-command nil)) - (#\W "Find out Where a command is bound." - (where-is-command nil)) - (#\T "Describe a Lisp object." - (editor-describe-command nil)) - ((#\Q :no) "Quits, You don't really want help."))) - -(defcommand "Where Is" (p) - "Find what key a command is bound to. - Prompts for the command to look for, and says what environment it is - available in." - "List places where a command is bound." - (declare (ignore p)) - (multiple-value-bind (nam cmd) - (prompt-for-keyword (list *command-names*) - :prompt "Command: " - :help "Name of command to look for.") - (let ((bindings (command-bindings cmd))) - (with-pop-up-display (s) - (cond - ((null bindings) - (format s "~S may only be invoked as an extended command.~%" nam)) - (t - (format s "~S may be invoked in the following ways:~%" nam) - (print-command-bindings bindings s))))))) - - - -;;;; Apropos. - -(defcommand "Apropos" (p) - "List things whose names contain a keyword." - "List things whose names contain a keyword." - (declare (ignore p)) - (let* ((str (prompt-for-string - :prompt "Apropos keyword: " - :help - "String to look for in command, variable and attribute names.")) - (coms (find-containing str *command-names*)) - (vars (mapcar #'(lambda (table) - (let ((res (find-containing str table))) - (if res (cons table res)))) - (current-variable-tables))) - (attr (find-containing str *character-attribute-names*))) - (if (or coms vars attr) - (apropos-command-output str coms vars attr) - (with-pop-up-display (s :height 1) - (format s "No command, attribute or variable name contains ~S." - str))))) - -(defun apropos-command-output (str coms vars attr) - (declare (list coms vars attr)) - (with-pop-up-display (s) - (when coms - (format s "Commands with ~S in their names:~%" str) - (dolist (com coms) - (let ((obj (getstring com *command-names*))) - (write-string com s) - (write-string " " s) - (print-command-bindings (command-bindings obj) s) - (terpri s) - (print-short-doc (command-documentation obj) s)))) - (when vars - (when coms (terpri s)) - (format s "Variables with ~S in their names:~%" str) - (dolist (stuff vars) - (let ((table (car stuff))) - (dolist (var (cdr stuff)) - (let ((obj (getstring var table))) - (write-string var s) - (write-string " " s) - (let ((*print-level* 2) (*print-length* 3)) - (prin1 (variable-value obj) s)) - (terpri s) - (print-short-doc (variable-documentation obj) s)))))) - (when attr - (when (or coms vars) (terpri s)) - (format s "Attributes with ~S in their names:~%" str) - (dolist (att attr) - (let ((obj (getstring att *character-attribute-names*))) - (write-line att s) - (print-short-doc (character-attribute-documentation obj) s)))))) - -;;; PRINT-SHORT-DOC takes doc, a function or string, and gets it out on stream. -;;; If doc is a string, this only outputs up to the first newline. All output -;;; is preceded by two spaces. -;;; -(defun print-short-doc (doc stream) - (let ((str (typecase doc - (function (funcall doc :short)) - (simple-string - (let ((nl (position #\newline (the simple-string doc)))) - (subseq doc 0 (or nl (length doc))))) - (t - (error "Bad documentation: ~S" doc))))) - (write-string " " stream) - (write-line str stream))) - - - -;;;; Describe command, key, pointer. - -(defcommand "Describe Command" (p) - "Describe a command. - Prompts for a command and then prints out it's full documentation." - "Print out the command documentation for a command which is prompted for." - (declare (ignore p)) - (multiple-value-bind (nam com) - (prompt-for-keyword - (list *command-names*) - :prompt "Describe command: " - :help "Name of a command to document.") - (let ((bindings (command-bindings com))) - (with-pop-up-display (s) - (format s "Documentation for ~S:~% ~A~%" - nam (command-documentation com)) - (cond ((not bindings) - (write-line - "This can only be invoked as an extended command." s)) - (t - (write-line - "This can be invoked in the following ways:" s) - (write-string " " s) - (print-command-bindings bindings s) - (terpri s))))))) - -(defcommand "Describe Key" (p) - "Prompt for a sequence of characters. When the first character is typed that - terminates a key binding in the current context, describe the command bound - to it. When the first character is typed that no longer allows a correct - key to be entered, tell the user that this sequence is not bound to anything." - "Print out the command documentation for a key which is prompted for." - (declare (ignore p)) - (let ((old-window (current-window))) - (unwind-protect - (progn - (setf (current-window) hi::*echo-area-window*) - (hi::display-prompt-nicely "Describe key: " nil) - (setf (fill-pointer hi::*prompt-key*) 0) - (loop - (let ((char (read-char hi::*editor-input*))) - (vector-push-extend char hi::*prompt-key*) - (let ((res (get-command hi::*prompt-key* :current))) - (format hi::*echo-area-stream* "~:C " char) - (cond ((commandp res) - (with-pop-up-display (s) - (sub-print-key (copy-seq hi::*prompt-key*) s) - (format s " is bound to ~S.~%" (command-name res)) - (format s "Documentation for this command:~% ~A" - (command-documentation res))) - (return)) - ((not (eq res :prefix)) - (with-pop-up-display (s :height 1) - (sub-print-key (copy-seq hi::*prompt-key*) s) - (write-string " is not bound to anything." s)) - (return))))))) - (setf (current-window) old-window)))) - -(defcommand "Describe Pointer" (p) - "Describe commands with any key binding that contains a \"mouse\" character - (modified or not). Does not describe the command \"Illegal\"." - "Describe commands with any key binding that contains a \"mouse\" character - (modified or not). Does not describe the command \"Illegal\"." - (declare (ignore p)) - (let ((illegal-command (getstring "Illegal" *command-names*))) - (with-pop-up-display (s) - (dolist (cmd (get-mouse-commands)) - (unless (eq cmd illegal-command) - (format s "Documentation for ~S:~% ~A~%" - (command-name cmd) - (command-documentation cmd)) - (write-line - "This can be invoked in the following ways:" s) - (write-string " " s) - (print-command-bindings (command-bindings cmd) s) - (terpri s) (terpri s)))))) - -(defun get-mouse-commands () - (let ((result nil)) - (do-strings (name cmd *command-names* result) - (declare (ignore name)) - (dolist (b (command-bindings cmd)) - (let ((key (car b))) - (declare (simple-vector key)) - (when (dotimes (i (length key) nil) - (when (member (make-char (svref key i)) - '(#\leftdown #\leftup #\middledown #\middleup - #\rightdown #\rightup)) - (push cmd result) - (return t))) - (return))))))) - - - -;;;; Generic describe variable, command, key, attribute. - -(defvar *generic-describe-kinds* - (list (make-string-table :initial-contents - '(("Variable" . :variable) - ("Command" . :command) - ("Key" . :key) - ("Attribute" . :attribute))))) - -(defcommand "Generic Describe" (p) - "Describe some Hemlock thing. - First prompt for the kind of thing, then prompt for the thing to describe. - Currently supported kinds of things are variables, commands, keys and - character attributes." - "Prompt for some Hemlock thing to describe." - (declare (ignore p)) - (multiple-value-bind (ignore kwd) - (prompt-for-keyword *generic-describe-kinds* - :default "Variable" - :help "Kind of thing to describe." - :prompt "Kind: ") - (declare (ignore ignore)) - (case kwd - (:variable - (describe-and-show-variable-command nil)) - (:command (describe-command-command ())) - (:key (describe-key-command ())) - (:attribute - (multiple-value-bind (name attr) - (prompt-for-keyword - (list *character-attribute-names*) - :help "Name of character attribute to describe." - :prompt "Attribute: ") - (print-full-doc name (character-attribute-documentation attr))))))) - -;;; PRINT-FULL-DOC displays whole documentation string in a pop-up window. -;;; Doc may be a function that takes at least one arg, :short or :full. -;;; -(defun print-full-doc (nam doc) - (typecase doc - (function (funcall doc :full)) - (simple-string - (with-pop-up-display (s) - (format s "Documentation for ~S:~% ~A" nam doc))) - (t (error "Bad documentation: ~S" doc)))) - - - -;;;; Describing and show variables. - -(defcommand "Show Variable" (p) - "Display the values of a Hemlock variable." - "Display the values of a Hemlock variable." - (declare (ignore p)) - (multiple-value-bind (name var) - (prompt-for-variable - :help "Name of variable to describe." - :prompt "Variable: ") - (with-pop-up-display (s) - (show-variable s name var)))) - -(defcommand "Describe and Show Variable" (p) - "Describe in full and show all of variable's value. - Variable is prompted for." - "Describe in full and show all of variable's value." - (declare (ignore p)) - (multiple-value-bind (name var) - (prompt-for-variable - :help "Name of variable to describe." - :prompt "Variable: ") - (with-pop-up-display (s) - (format s "Documentation for ~S:~% ~A~&~%" - name (variable-documentation var)) - (show-variable s name var)))) - -(defun show-variable (s name var) - (when (hemlock-bound-p var :global) - (format s "Global value of ~S:~% ~S~%" - name (variable-value var :global))) - (let ((buffer (current-buffer))) - (when (hemlock-bound-p var :buffer (current-buffer)) - (format s "Value of ~S in buffer ~A:~% ~S~%" - name (buffer-name buffer) - (variable-value var :buffer buffer)))) - (do-strings (mode-name val *mode-names*) - (declare (ignore val)) - (when (hemlock-bound-p var :mode mode-name) - (format s "Value of ~S in ~S Mode:~% ~S~%" - name mode-name - (variable-value var :mode mode-name))))) - - - -;;;; Describing modes. - -(defvar *describe-mode-ignore* (list "Illegal" "Do Nothing")) - -(defcommand "Describe Mode" (p &optional name) - "Describe a mode showing special bindings for that mode." - "Describe a mode showing special bindings for that mode." - (declare (ignore p)) - (let ((name (or name - (prompt-for-keyword (list *mode-names*) - :prompt "Mode: " - :help "Enter mode to describe." - :default - (car (buffer-modes (current-buffer))))))) - (with-pop-up-display (s) - (format s "~A mode description:~%" name) - (let ((doc (mode-documentation name))) - (when doc - (write-line doc s) - (terpri s))) - (map-bindings - #'(lambda (key cmd) - (unless (member (command-name cmd) - *describe-mode-ignore* - :test #'string-equal) - (let ((str (key-to-string key))) - (cond ((= (length str) 1) - (write-string str s) - (write-string " - " s)) - (t (write-line str s) - (write-string " - " s))) - (print-short-doc (command-documentation cmd) s)))) - :mode name)))) - -(defun key-to-string (key) - (with-output-to-string (s) - (sub-print-key key s))) - - - -;;;; Printing bindings and last N characters typed. - -(defcommand "What Lossage" (p) - "Display the last 60 characters typed." - "Display the last 60 characters typed." - (declare (ignore p)) - (with-pop-up-display (s :height 7) - (let ((num (ring-length *character-history*))) - (format s "The last ~D characters typed:~%" num) - (do ((i (1- num) (1- i))) - ((minusp i)) - (print-pretty-character (ring-ref *character-history* i) s) - (write-char #\space s))))) - -(defun print-command-bindings (bindings stream) - (let ((buffer ()) - (mode ()) - (global ())) - (dolist (b bindings) - (case (second b) - (:global (push (first b) global)) - (:mode - (let ((m (assoc (third b) mode :test #'string=))) - (if m - (push (first b) (cdr m)) - (push (list (third b) (first b)) mode)))) - (t - (let ((f (assq (third b) buffer))) - (if f - (push (first b) (cdr f)) - (push (list (third b) (first b)) buffer)))))) - (when global - (print-some-keys global stream) - (write-string "; " stream)) - (dolist (b buffer) - (format stream "Buffer ~S: " (buffer-name (car b))) - (print-some-keys (cdr b) stream) - (write-string "; " stream)) - (dolist (m mode) - (write-string (car m) stream) - (write-string ": " stream) - (print-some-keys (cdr m) stream) - (write-string "; " stream)))) - -;;; PRINT-SOME-KEYS prints the list of keys onto Stream. -;;; -(defun print-some-keys (keys stream) - (do ((key keys (cdr key))) - ((null (cdr key)) - (sub-print-key (car key) stream)) - (sub-print-key (car key) stream) - (write-string ", " stream))) - -;;; SUB-PRINT-KEY writes key on stream as a serious pretty printed characters -;;; separated by spaces. -;;; -(defun sub-print-key (key stream) - (declare (simple-vector key)) - (let ((last (1- (length key)))) - (dotimes (i last) - (print-pretty-character (svref key i) stream) - (write-char #\space stream)) - (print-pretty-character (svref key last) stream))) diff --git a/hemlock/echo.lisp b/hemlock/echo.lisp deleted file mode 100644 index bea9cacad399afbb76a566bd4dd34674608ccf57..0000000000000000000000000000000000000000 --- a/hemlock/echo.lisp +++ /dev/null @@ -1,731 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock Echo Area stuff. -;;; Written by Skef Wholey and Rob MacLachlan. -;;; Modified by Bill Chiles. -;;; -(in-package 'hemlock-internals) -(export '(*echo-area-buffer* *echo-area-stream* *echo-area-window* - *parse-starting-mark* *parse-input-region* - *parse-verification-function* *parse-string-tables* - *parse-value-must-exist* *parse-default* *parse-default-string* - *parse-prompt* *parse-help* clear-echo-area message loud-message - prompt-for-buffer prompt-for-file prompt-for-integer - prompt-for-keyword prompt-for-expression prompt-for-string - prompt-for-variable prompt-for-yes-or-no prompt-for-y-or-n - prompt-for-character prompt-for-key *logical-character-names* - logical-char= logical-character-documentation - logical-character-name logical-character-characters - define-logical-character *parse-type* current-variable-tables)) - - -(defmode "Echo Area" :major-p t) -(defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area")) - "Buffer used to hack text for the echo area.") -(defvar *echo-area-region* (buffer-region *echo-area-buffer*) - "Internal thing that's the *echo-area-buffer*'s region.") -(defvar *echo-area-stream* - (make-hemlock-output-stream (region-end *echo-area-region*) :full) - "Buffered stream that prints into the echo area.") -(defvar *echo-area-window* () - "Window used to display stuff in the echo area.") -(defvar *parse-starting-mark* - (copy-mark (buffer-point *echo-area-buffer*) :right-inserting) - "Mark that points to the beginning of the text that'll be parsed.") -(defvar *parse-input-region* - (region *parse-starting-mark* (region-end *echo-area-region*)) - "Region that contains the text typed in.") - - - -;;;; Variables that control parsing: - -(defvar *parse-verification-function* '%not-inside-a-parse - "Function that verifies what's being parsed.") - -;;; %Not-Inside-A-Parse -- Internal -;;; -;;; This function is called if someone does stuff in the echo area when -;;; we aren't inside a parse. It tries to put them back in a reasonable place. -;;; -(defun %not-inside-a-parse (quaz) - "Thing that's called when somehow we get called to confirm a parse that's - not in progress." - (declare (ignore quaz)) - (let* ((bufs (remove *echo-area-buffer* *buffer-list*)) - (buf (or (find-if #'buffer-windows bufs) - (car bufs) - (make-buffer "Main")))) - (setf (current-buffer) buf) - (dolist (w *window-list*) - (when (and (eq (window-buffer w) *echo-area-buffer*) - (not (eq w *echo-area-window*))) - (setf (window-buffer w) buf))) - (setf (current-window) - (or (car (buffer-windows buf)) - (make-window (buffer-start-mark buf))))) - (editor-error "Wham! We tried to confirm a parse that wasn't in progress?")) - -(defvar *parse-string-tables* () - "String tables being used in the current parse.") - -(defvar *parse-value-must-exist* () - "You know.") - -(defvar *parse-default* () - "When the user attempts to default a parse, we call the verification function - on this string. This is not the :Default argument to the prompting function, - but rather a string representation of it.") - -(defvar *parse-default-string* () - "String that we show the user to inform him of the default. If this - is NIL then we just use *Parse-Default*.") - -(defvar *parse-prompt* () - "Prompt for the current parse.") - -(defvar *parse-help* () - "Help string for the current parse.") - -(defvar *parse-type* :string "A hack. :String, :File or :Keyword.") - - - -;;;; MESSAGE and CLEAR-ECHO-AREA: - -(defhvar "Message Pause" "The number of seconds to pause after a Message." - :value 0.5s0) - -(defvar *last-message-time* 0 - "Internal-Real-Time the last time we displayed a message.") - -(defun maybe-wait () - (let* ((now (get-internal-real-time)) - (delta (/ (float (- now *last-message-time*)) - (float internal-time-units-per-second))) - (pause (value ed::message-pause))) - (when (< delta pause) - (sleep (- pause delta))))) - -(defun clear-echo-area () - "You guessed it." - (maybe-wait) - (delete-region *echo-area-region*) - (setf (buffer-modified *echo-area-buffer*) nil)) - -;;; Message -- Public -;;; -;;; Display the stuff on *echo-area-stream* and then wait. Editor-Sleep -;;; will do a redisplay if appropriate. -;;; -(defun message (string &rest args) - "Nicely display a message in the echo-area. - Put the message on a fresh line and wait for \"Message Pause\" seconds - to give the luser a chance to see it. String and Args are a format - control string and format arguments, respectively." - (maybe-wait) - (cond ((eq *current-window* *echo-area-window*) - (let ((point (buffer-point *echo-area-buffer*))) - (with-mark ((m point :left-inserting)) - (line-start m) - (with-output-to-mark (s m :full) - (apply #'format s string args) - (fresh-line s))))) - (t - (let ((mark (region-end *echo-area-region*))) - (cond ((buffer-modified *echo-area-buffer*) - (clear-echo-area)) - ((not (zerop (mark-charpos mark))) - (insert-character mark #\newline) - (unless (displayed-p mark *echo-area-window*) - (clear-echo-area)))) - (apply #'format *echo-area-stream* string args) - (setf (buffer-modified *echo-area-buffer*) nil)))) - (force-output *echo-area-stream*) - (setq *last-message-time* (get-internal-real-time)) - nil) - - -;;; LOUD-MESSAGE -- Public. -;;; Like message, only more provocative. -;;; -(defun loud-message (&rest args) - "This is the same as MESSAGE, but it beeps and clears the echo area before - doing anything else." - (beep) - (clear-echo-area) - (apply #'message args)) - - - -;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING. - -(defun display-prompt-nicely (&optional (prompt *parse-prompt*) - (default (or *parse-default-string* - *parse-default*))) - (clear-echo-area) - (let ((point (buffer-point *echo-area-buffer*))) - (if (listp prompt) - (apply #'format *echo-area-stream* prompt) - (insert-string point prompt)) - (when default - (insert-character point #\[) - (insert-string point default) - (insert-string point "] ")))) - -(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)))) - - - -;;;; Buffer prompting. - -(defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t) - default - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Buffer: ") - ((:help *parse-help*) "Type a buffer name.")) - "Prompts for a buffer name and returns the corresponding buffer. If - :must-exist is nil, then return the input string. This refuses to accept - the empty string as input when no default is supplied. :default-string - may be used to supply a default buffer name even when :default is nil, but - when :must-exist is non-nil, :default-string must be the name of an existing - buffer." - (let ((*parse-string-tables* (list *buffer-names*)) - (*parse-type* :keyword) - (*parse-default* (cond - (default (buffer-name default)) - (*parse-default-string* - (when (and *parse-value-must-exist* - (not (getstring *parse-default-string* - *buffer-names*))) - (error "Default-string must name an existing ~ - buffer when must-exist is non-nil -- ~S." - *parse-default-string*)) - *parse-default-string*) - (t nil))) - (*parse-verification-function* #'buffer-verification-function)) - (parse-for-something))) - -(defun buffer-verification-function (string) - (declare (simple-string string)) - (cond ((string= string "") nil) - (*parse-value-must-exist* - (multiple-value-bind - (prefix key value field ambig) - (complete-string string *parse-string-tables*) - (declare (ignore field)) - (ecase key - (:none nil) - ((:unique :complete) - (list value)) - (:ambiguous - (delete-region *parse-input-region*) - (insert-string (region-start *parse-input-region*) prefix) - (let ((point (current-point))) - (move-mark point (region-start *parse-input-region*)) - (unless (character-offset point ambig) - (buffer-end point))) - nil)))) - (t - (list (or (getstring string *buffer-names*) string))))) - - - -;;;; File Prompting. - -(defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t) - default - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Filename: ") - ((:help *parse-help*) "Type a file name.")) - "Prompts for a filename." - (let ((*parse-verification-function* #'file-verification-function) - (*parse-default* (if default (namestring default))) - (*parse-type* :file)) - (parse-for-something))) - -(defun file-verification-function (string) - (let ((pn (pathname-or-lose string))) - (if pn - (let ((merge - (cond ((not *parse-default*) nil) - ((directoryp pn) - (merge-pathnames pn *parse-default*)) - (t - (merge-pathnames - (prompting-merge-pathnames (directory-namestring pn) - (directory-namestring - *parse-default*)) - (file-namestring pn)))))) - (cond ((probe-file pn) (list pn)) - ((and merge (probe-file merge)) (list merge)) - ((not *parse-value-must-exist*) (list (or merge pn))) - (t nil)))))) - -(defun prompting-merge-pathnames (pathname default-directory) - "Merges pathname with default-directory. If pathname is not absolute, it - is assumed to be relative to default-directory. The result is always a - directory. This works even when pathname is a logical name." - (if (and pathname (string/= (namestring pathname) "")) - (let ((pathname (pathname pathname)) - (device (pathname-device pathname))) - (if (and device - (not (eq device :absolute)) - (not (string= device "Default"))) - pathname - (merge-relative-pathnames pathname default-directory))) - default-directory)) - -;;; PATHNAME-OR-LOSE tries to convert string to a pathname using -;;; PARSE-NAMESTRING. If it succeeds, this returns the pathname. Otherwise, -;;; this deletes the offending characters from *parse-input-region* and signals -;;; an editor-error. -;;; -(defun pathname-or-lose (string) - (declare (simple-string string)) - (multiple-value-bind (pn idx) - (parse-namestring string nil *default-pathname-defaults* - :junk-allowed t) - (cond (pn) - (t (delete-characters (region-end *echo-area-region*) - (- idx (length string))) - nil)))) - - - -;;;; Keyword and variable prompting. - -(defun prompt-for-keyword (*parse-string-tables* - &key - ((:must-exist *parse-value-must-exist*) t) - ((:default *parse-default*)) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Keyword: ") - ((:help *parse-help*) "Type a keyword.")) - "Prompts for a keyword using the String Tables." - (let ((*parse-verification-function* #'keyword-verification-function) - (*parse-type* :keyword)) - (parse-for-something))) - -(defun prompt-for-variable (&key ((:must-exist *parse-value-must-exist*) t) - ((:default *parse-default*)) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Variable: ") - ((:help *parse-help*) - "Type the name of a variable.")) - "Prompts for a variable defined in the current scheme of things." - (let ((*parse-string-tables* (current-variable-tables)) - (*parse-verification-function* #'keyword-verification-function) - (*parse-type* :keyword)) - (parse-for-something))) - -(defun current-variable-tables () - "Returns a list of all the variable tables currently established globally, - by the current buffer, and by any modes for the current buffer." - (do ((tables (list (buffer-variables *current-buffer*) - *global-variable-names*) - (cons (hi::mode-object-variables (car mode)) tables)) - (mode (buffer-mode-objects *current-buffer*) (cdr mode))) - ((null mode) tables))) - -(defun keyword-verification-function (string) - (declare (simple-string string)) - (multiple-value-bind - (prefix key value field ambig) - (complete-string string *parse-string-tables*) - (declare (ignore field)) - (cond (*parse-value-must-exist* - (ecase key - (:none nil) - ((:unique :complete) - (list prefix value)) - (:ambiguous - (delete-region *parse-input-region*) - (insert-string (region-start *parse-input-region*) prefix) - (let ((point (current-point))) - (move-mark point (region-start *parse-input-region*)) - (unless (character-offset point ambig) - (buffer-end point))) - nil))) - (t - ;; HACK: If it doesn't have to exist, and the completion does not - ;; add anything, then return the completion's capitalization, - ;; instead of the user's input. - (list (if (= (length string) (length prefix)) prefix string)))))) - - - -;;;; Integer, expression, and string prompting. - -(defun prompt-for-integer (&key ((:must-exist *parse-value-must-exist*) t) - default - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Integer: ") - ((:help *parse-help*) "Type an integer.")) - "Prompt for an integer. If :must-exist is Nil, then we return as a string - whatever was input if it is not a valid integer." - (let ((*parse-verification-function* - #'(lambda (string) - (let ((number (parse-integer string :junk-allowed t))) - (if *parse-value-must-exist* - (if number (list number)) - (list (or number string)))))) - (*parse-default* (if default (write-to-string default :base 10)))) - (parse-for-something))) - - -(defvar hemlock-eof '(()) - "An object that won't be EQ to anything read.") - -(defun prompt-for-expression (&key ((:must-exist *parse-value-must-exist*) t) - (default nil defaultp) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Expression: ") - ((:help *parse-help*) - "Type a Lisp expression.")) - "Prompts for a Lisp expression." - (let ((*parse-verification-function* - #'(lambda (string) - (let ((expr (with-input-from-region (stream *parse-input-region*) - (handler-case (read stream nil hemlock-eof) - (error () hemlock-eof))))) - (if *parse-value-must-exist* - (if (not (eq expr hemlock-eof)) (values (list expr) t)) - (if (eq expr hemlock-eof) - (list string) (values (list expr) t)))))) - (*parse-default* (if defaultp (prin1-to-string default)))) - (parse-for-something))) - - -(defun prompt-for-string (&key ((:default *parse-default*)) - ((:default-string *parse-default-string*)) - (trim ()) - ((:prompt *parse-prompt*) "String: ") - ((:help *parse-help*) "Type a string.")) - "Prompts for a string. If :trim is t, then leading and trailing whitespace - is removed from input, otherwise it is interpreted as a Char-Bag argument - to String-Trim." - (let ((*parse-verification-function* - #'(lambda (string) - (list (string-trim (if (eq trim t) '(#\space #\tab) trim) - string))))) - (parse-for-something))) - - - -;;;; Yes-or-no and y-or-n prompting. - -(defvar *yes-or-no-string-table* - (make-string-table :initial-contents '(("Yes" . t) ("No" . nil)))) - -(defun prompt-for-yes-or-no (&key ((:must-exist *parse-value-must-exist*) t) - (default nil defaultp) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Yes or No? ") - ((:help *parse-help*) "Type Yes or No.")) - "Prompts for Yes or No." - (let* ((*parse-string-tables* (list *yes-or-no-string-table*)) - (*parse-default* (if defaultp (if default "Yes" "No"))) - (*parse-verification-function* - #'(lambda (string) - (multiple-value-bind - (prefix key value field ambig) - (complete-string string *parse-string-tables*) - (declare (ignore prefix field ambig)) - (let ((won (or (eq key :complete) (eq key :unique)))) - (if *parse-value-must-exist* - (if won (values (list value) t)) - (list (if won (values value t) string))))))) - (*parse-type* :keyword)) - (parse-for-something))) - -(defun prompt-for-y-or-n (&key ((:must-exist must-exist) t) - (default nil defaultp) - default-string - ((:prompt prompt) "Y or N? ") - ((:help *parse-help*) "Type Y or N.")) - "Prompts for Y or N." - (let ((old-window (current-window))) - (unwind-protect - (progn - (setf (current-window) *echo-area-window*) - (display-prompt-nicely prompt (or default-string - (if defaultp (if default "Y" "N")))) - (do ((char (read-char *editor-input*) (read-char *editor-input*))) - (()) - (cond ((or (char= char #\y) (char= char #\Y)) - (return t)) - ((or (char= char #\n) (char= char #\N)) - (return nil)) - ((logical-char= char :confirm) - (if defaultp - (return default) - (beep))) - ((logical-char= char :help) - (ed::help-on-parse-command ())) - (t - (unless must-exist (return char)) - (beep))))) - (setf (current-window) old-window)))) - - - -;;;; Character and key prompting. - -(defun prompt-for-character (&key (prompt "Character: ") (change-window t)) - "Prompts for a character." - (prompt-for-character* prompt change-window)) - -(defun prompt-for-character* (prompt change-window) - (let ((old-window (current-window))) - (unwind-protect - (progn - (when change-window - (setf (current-window) *echo-area-window*)) - (display-prompt-nicely prompt) - (read-char *editor-input* nil)) - (when change-window (setf (current-window) old-window))))) - -(defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0)) -(defun prompt-for-key (&key ((:must-exist must-exist) t) - default default-string - (prompt "Key: ") - ((:help *parse-help*) "Type a key.")) - (let ((old-window (current-window)) - (string (if default - (or default-string - (let ((l (coerce default 'list))) - (format nil "~:C~{ ~:C~}" (car l) (cdr l))))))) - - (unwind-protect - (progn - (setf (current-window) *echo-area-window*) - (display-prompt-nicely prompt string) - (setf (fill-pointer *prompt-key*) 0) - (prog ((key *prompt-key*) char) - (declare (vector key)) - TOP - (setq char (read-char *editor-input*)) - (cond ((logical-char= char :quote) - (setq char (read-char *editor-input* nil))) - ((logical-char= char :confirm) - (cond ((and default (zerop (length key))) - (let ((res (get-command default :current))) - (unless (commandp res) (go FLAME)) - (return (values default res)))) - ((and (not must-exist) (plusp (length key))) - (return (copy-seq key))) - (t - (go FLAME)))) - ((logical-char= char :help) - (ed::help-on-parse-command ()) - (go TOP))) - (vector-push-extend char key) - (when must-exist - (let ((res (get-command key :current))) - (cond ((commandp res) - (format *echo-area-stream* "~:C " char) - (return (values (copy-seq key) res))) - ((not (eq res :prefix)) - (vector-pop key) - (go FLAME))))) - (format *echo-area-stream* "~:C " char) - (go TOP) - FLAME - (beep) - (go TOP))) - (force-output *echo-area-stream*) - (setf (current-window) old-window)))) - - - -;;;; Logical character stuff. - -(defvar *logical-character-names* (make-string-table) - "This variable holds a string-table from logical-character names to the - corresponding keywords.") - -(defvar *real-to-logical-characters* (make-hash-table :test #'eql) - "A hashtable from real characters to their corresponding logical - character keywords.") - -(defvar *logical-character-descriptors* (make-hash-table :test #'eq) - "A hashtable from logical-characters to logical-character-descriptors.") - -(defstruct (logical-character-descriptor - (:constructor make-logical-character-descriptor ())) - name - characters - documentation) - -;;; Logical-Char= -- Public -;;; -;;; Just look up the character in the hashtable. -;;; -(defun logical-char= (character keyword) - "Return true if Character has been defined to have Keyword as its - logical character. The relation between logical and real characters - is defined by using Setf on Logical-Char=. If it is set to - true then calling Logical-Char= with the same Character and - Keyword, will result in truth. Setting to false produces the opposite - result. See Define-Logical-Character and Command-Case." - (not (null (memq keyword (gethash (char-upcase character) - *real-to-logical-characters*))))) - -;;; Get-Logical-Char-Desc -- Internal -;;; -;;; Return the descriptor for the logical character Kwd, or signal -;;; an error if it isn't defined. -;;; -(defun get-logical-char-desc (kwd) - (let ((res (gethash kwd *logical-character-descriptors*))) - (unless res - (error "~S is not a defined logical-character keyword." kwd)) - res)) - -;;; %Set-Logical-Char= -- Internal -;;; -;;; Add or remove a logical character link by adding to or deleting from -;;; the list in the from-char hashtable and the descriptor. -;;; -(defun %set-logical-char= (character keyword new-value) - (let* ((character (char-upcase character)) - (entry (get-logical-char-desc keyword))) - (cond - (new-value - (pushnew keyword (gethash character *real-to-logical-characters*)) - (pushnew character (logical-character-descriptor-characters entry))) - (t - (setf (gethash character *real-to-logical-characters*) - (delete keyword (gethash character *real-to-logical-characters*))) - (setf (logical-character-descriptor-characters entry) - (delete keyword (logical-character-descriptor-characters entry)))))) - new-value) - -;;; Logical-Character-Documentation, Name, Characters -- Public -;;; -;;; Grab the right field out of the descriptor and return it. -;;; -(defun logical-character-documentation (keyword) - "Return the documentation for the logical character Keyword." - (logical-character-descriptor-documentation (get-logical-char-desc keyword))) -;;; -(defun logical-character-name (keyword) - "Return the string name for the logical character Keyword." - (logical-character-descriptor-name (get-logical-char-desc keyword))) -;;; -(defun logical-character-characters (keyword) - "Return the list of characters for which Keyword is the logical character." - (logical-character-descriptor-characters (get-logical-char-desc keyword))) - -;;; Define-Logical-Character -- Public -;;; -;;; Make the entries in the two hashtables and the string-table. -;;; -(defun define-logical-character (name documentation) - "Define a logical character having the specified Name and Documentation. - See Logical-Char= and Command-Case." - (check-type name string) - (check-type documentation (or string function)) - (let* ((keyword (string-to-keyword name)) - (entry (or (gethash keyword *logical-character-descriptors*) - (setf (gethash keyword *logical-character-descriptors*) - (make-logical-character-descriptor))))) - (setf (logical-character-descriptor-name entry) name) - (setf (logical-character-descriptor-documentation entry) documentation) - (setf (getstring name *logical-character-names*) keyword))) - - - -;;;; Some standard logical-characters: - -(define-logical-character "Forward Search" - "This character is used to indicate that a forward search should be made.") -(define-logical-character "Backward Search" - "This character is used to indicate that a backward search should be made.") -(define-logical-character "Recursive Edit" - "This character indicates that a recursive edit should be entered.") -(define-logical-character "Cancel" - "This character is used to cancel a previous character of input.") -(define-logical-character "Abort" - "This character is used to abort the command in progress.") -(define-logical-character "Exit" - "This character is used to exit normally the command in progress.") -(define-logical-character "Yes" - "This character is used to indicate a positive response.") -(define-logical-character "No" - "This character is used to indicate a negative response.") -(define-logical-character "Do All" - "This character means do it as many times as you can.") -(define-logical-character "Do Once" - "This character means, do it this time, then exit.") -(define-logical-character "Help" - "This character is used to ask for help.") -(define-logical-character "Confirm" - "This character is used to confirm some choice.") -(define-logical-character "Quote" - "This character is used to quote the next character of input.") -(define-logical-character "Keep" - "This character means exit but keep something around.") - - - -;;;; COMMAND-CASE help message printing. - -(defvar *my-string-output-stream* (make-string-output-stream)) - -(defun chars-to-string (chars) - (do ((s *my-string-output-stream*) - (chars chars (cdr chars))) - ((null chars) - (get-output-stream-string s)) - (let ((char (car chars))) - (if (characterp char) - (print-pretty-character char s) - (do ((chars (logical-character-characters char) (cdr chars))) - ((null chars)) - (print-pretty-character (car chars) s) - (unless (null (cdr chars)) - (write-string ", " s)))) - (unless (null (cdr chars)) - (write-string ", " s))))) - -;;; Command-Case-Help -- Internal -;;; -;;; Print out a help message derived from the options in a -;;; random-typeout window. -;;; -(defun command-case-help (help options) - (let ((help (if (listp help) - (apply #'format nil help) help))) - (with-pop-up-display (s) - (write-string help s) - (fresh-line s) - (do ((o options (cdr o))) - ((null o)) - (let ((string (chars-to-string (caar o)))) - (declare (simple-string string)) - (cond ((= (length string) 1) - (write-char (char string 0) s) - (write-string " - " s) - (write-line (cdar o) s)) - (t - (write-line string s) - (write-string " - " s) - (write-line (cdar o) s)))))))) diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp deleted file mode 100644 index a171aa7d3caa46f2b02d3edcea15298219d00d16..0000000000000000000000000000000000000000 --- a/hemlock/echocoms.lisp +++ /dev/null @@ -1,315 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Echo area commands. -;;; -;;; Written by Rob MacLachlan and Skef Wholey. -;;; -(in-package 'hemlock) - -(defhvar "Beep on Ambiguity" - "If non-NIL, beep when completion of a parse is ambiguous." - :value t) - -(defhvar "Ignore File Types" - "File types to ignore when trying to complete a filename." - :value - (list "fasl" "err" ; Lisp - "BAK" "CKP" ; Backups & Checkpoints - "PS" "ps" "press" "otl" "dvi" "toc" ; Formatting - "bbl" "lof" "idx" "lot" "aux" ; Formatting - "mo" "elc" ; Other editors - "bin" "lbin" ; Obvious binary extensions. - "o" "a" "aout" ; UNIXY stuff - "bm" "onx" "snf" ; X stuff - "UU" "uu" "arc" "Z" "tar" ; Binary encoded files - )) - - -;;; Field separator characters separate fields for TOPS-20 ^F style -;;; completion. -(defattribute "Parse Field Separator" - "A value of 1 for this attribute indicates that the corresponding character - should be considered to be a field separator by the prompting commands.") -(setf (character-attribute :parse-field-separator #\space) 1) - - -;;; Find-All-Completions -- Internal -;;; -;;; Return as a list of all the possible completions of String in the -;;; list of string-tables Tables. -;;; -(defun find-all-completions (string tables) - (do ((table tables (cdr table)) - (res () - (merge 'list (find-ambiguous string (car table)) - res #'string-lessp))) - ((null table) res))) - -(defcommand "Help on Parse" (p) - "Display help for parse in progress. - If there are a limited number of options then display them." - "Display the *Parse-Help* and any possibly completions of the current - input." - (declare (ignore p)) - (let ((help (typecase *parse-help* - (list (unless *parse-help* (error "There is no parse help.")) - (apply #'format nil *parse-help*)) - (string *parse-help*) - (t (error "Parse help is not a string or list: ~S" *parse-help*)))) - (input (region-to-string *parse-input-region*))) - (cond - ((eq *parse-type* :keyword) - (let ((strings (find-all-completions input *parse-string-tables*))) - (with-pop-up-display (s :height (+ (length strings) 2)) - (write-line help s) - (cond (strings - (write-line "Possible completions of what you have typed:" s) - (dolist (string strings) - (write-line string s))) - (t - (write-line - "There are no possible completions of what you have typed." s)))))) - ((and (eq *parse-type* :file) (not (zerop (length input)))) - (let ((pns (ambiguous-files (region-to-string *parse-input-region*) - *parse-default*))) - (declare (list pns)) - (with-pop-up-display(s :height (+ (length pns) 2)) - (write-line help s) - (cond (pns - (write-line "Possible completions of what you have typed:" s) - (dolist (pn pns) - (format s " ~A~25T ~A~%" (file-namestring pn) - (directory-namestring pn)))) - (t - (write-line - "There are no possible completions of what you have typed." s)))))) - (t - (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting)) - (insert-string m help) - (insert-character m #\newline)))))) - -(defun file-completion-action (typein) - (declare (simple-string typein)) - (when (zerop (length typein)) (editor-error)) - (multiple-value-bind - (result win) - (complete-file typein - :defaults (directory-namestring *parse-default*) - :ignore-types (value ignore-file-types)) - (when result - (delete-region *parse-input-region*) - (insert-string (region-start *parse-input-region*) - (namestring result))) - (when (and (not win) (value beep-on-ambiguity)) - (editor-error)))) - -(defcommand "Complete Keyword" (p) - "Trys to complete the text being read in the echo area as a string in - *parse-string-tables*" - "Complete the keyword being parsed as far as possible. - If it is ambiguous and ``Beep On Ambiguity'' true beep." - (declare (ignore p)) - (let ((typein (region-to-string *parse-input-region*))) - (declare (simple-string typein)) - (case *parse-type* - (:keyword - (multiple-value-bind - (prefix key value field ambig) - (complete-string typein *parse-string-tables*) - (declare (ignore value field)) - (when prefix - (delete-region *parse-input-region*) - (insert-string (region-start *parse-input-region*) prefix) - (when (eq key :ambiguous) - (let ((point (current-point))) - (move-mark point (region-start *parse-input-region*)) - (unless (character-offset point ambig) - (buffer-end point))))) - (when (and (or (eq key :ambiguous) (eq key :none)) - (value beep-on-ambiguity)) - (editor-error)))) - (:file - (file-completion-action typein)) - (t - (editor-error "Cannot complete input for this prompt."))))) - -(defun field-separator-p (x) - (plusp (character-attribute :parse-field-separator x))) - -(defcommand "Complete Field" (p) - "Complete a field in a parse. - Fields are defined by the :field separator attribute, - the text being read in the echo area as a string in *parse-string-tables*" - "Complete a field in a keyword. - If it is ambiguous and ``Beep On Ambiguity'' true beep. Fields are - separated by characters having a non-zero :parse-field-separator attribute, - and this command should only be bound to characters having that attribute." - (let ((typein (region-to-string *parse-input-region*))) - (declare (simple-string typein)) - (case *parse-type* - (:string - (self-insert-command p)) - (:file - (file-completion-action typein)) - (:keyword - (let ((point (current-point))) - (unless (blank-after-p point) - (insert-character point *last-character-typed*))) - (multiple-value-bind - (prefix key value field ambig) - (complete-string typein *parse-string-tables*) - (declare (ignore value ambig)) - (when (eq key :none) (editor-error "No possible completion.")) - (delete-region *parse-input-region*) - (let ((new-typein (if (and (eq key :unique) (null field)) - (subseq prefix 0 field) - (concatenate 'string - (subseq prefix 0 field) - (string *last-character-typed*))))) - (insert-string (region-start *parse-input-region*) new-typein)))) - (t - (editor-error "Cannot complete input for this prompt."))))) - - -(defvar *echo-area-history* (make-ring 10) - "This ring-buffer contains strings which were previously input in the - echo area.") - -(defvar *echo-history-pointer* 0 - "This is our current position to the ring during a historical exploration.") - -(defcommand "Confirm Parse" (p) - "Terminate echo-area input. - If the input is invalid then an editor-error will signalled." - "If no input has been given, exits the recursive edit with the default, - otherwise calls the verification function." - (declare (ignore p)) - (let* ((string (region-to-string *parse-input-region*)) - (empty (zerop (length string)))) - (declare (simple-string string)) - (if empty - (when *parse-default* (setq string *parse-default*)) - (when (or (zerop (ring-length *echo-area-history*)) - (string/= string (ring-ref *echo-area-history* 0))) - (ring-push string *echo-area-history*))) - (multiple-value-bind (res flag) - (funcall *parse-verification-function* string) - (unless (or res flag) (editor-error)) - (exit-recursive-edit res)))) - -(defcommand "Previous Parse" (p) - "Rotate the echo-area history forward. - If current input is non-empty and different from what is on the top - of the ring then push it on the ring before inserting the new input." - "Pop the *echo-area-history* ring buffer." - (let ((length (ring-length *echo-area-history*)) - (p (or p 1))) - (declare (simple-string current)) - (when (zerop length) (editor-error)) - (cond - ((eq (last-command-type) :echo-history) - (let ((base (mod (+ *echo-history-pointer* p) length))) - (delete-region *parse-input-region*) - (insert-string (region-end *parse-input-region*) - (ring-ref *echo-area-history* base)) - (setq *echo-history-pointer* base))) - (t - (let ((current (region-to-string *parse-input-region*)) - (base (mod (if (minusp p) p (1- p)) length))) - (delete-region *parse-input-region*) - (insert-string (region-end *parse-input-region*) - (ring-ref *echo-area-history* base)) - (when (and (plusp (length current)) - (string/= (ring-ref *echo-area-history* 0) current)) - (ring-push current *echo-area-history*) - (incf base)) - (setq *echo-history-pointer* base)))) - (setf (last-command-type) :echo-history))) - -(defcommand "Next Parse" (p) - "Rotate the echo-area history backward. - If current input is non-empty and different from what is on the top - of the ring then push it on the ring before inserting the new input." - "Push the *echo-area-history* ring buffer." - (previous-parse-command (- (or p 1)))) - -(defcommand "Illegal" (p) - "This signals an editor-error. - It is useful for making commands locally unbound." - "Just signals an editor-error." - (declare (ignore p)) - (editor-error)) - -(defcommand "Beginning Of Parse" (p) - "Moves to immediately after the prompt when in the echo area." - "Move the point of the echo area buffer to *parse-starting-mark*." - (declare (ignore p)) - (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*)) - -(defcommand "Echo Area Delete Previous Character" (p) - "Delete the previous character. - Don't let the luser rub out the prompt." - "Signal an editor-error if we would nuke the prompt, - otherwise do a normal delete." - (with-mark ((tem (buffer-point *echo-area-buffer*))) - (unless (character-offset tem (- (or p 1))) (editor-error)) - (when (mark< tem *parse-starting-mark*) (editor-error)) - (delete-previous-character-command p))) - -(defcommand "Echo Area Kill Previous Word" (p) - "Kill the previous word. - Don't let the luser rub out the prompt." - "Signal an editor-error if we would mangle the prompt, otherwise - do a normal kill-previous-word." - (with-mark ((tem (buffer-point *echo-area-buffer*))) - (unless (word-offset tem (- (or p 1))) (editor-error)) - (when (mark< tem *parse-starting-mark*) (editor-error)) - (kill-previous-word-command p))) - -(proclaim '(special *kill-ring*)) - -(defcommand "Kill Parse" (p) - "Kills any input so far." - "Kills *parse-input-region*." - (declare (ignore p)) - (if (end-line-p (current-point)) - (kill-region *parse-input-region* :kill-backward) - (ring-push (delete-and-save-region *parse-input-region*) - *kill-ring*))) - -(defcommand "Insert Parse Default" (p) - "Inserts the default for the parse in progress. - The text is inserted at the point." - "Inserts *parse-default* at the point of the *echo-area-buffer*. - If there is no default an editor-error is signalled." - (declare (ignore p)) - (unless *parse-default* (editor-error)) - (insert-string (buffer-point *echo-area-buffer*) *parse-default*)) - -(defcommand "Echo Area Backward Character" (p) - "Go back one character. - Don't let the luser move into the prompt." - "Signal an editor-error if we try to go into the prompt, otherwise - do a backward-character command." - (backward-character-command p) - (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*) - (beginning-of-parse-command ()) - (editor-error))) - -(defcommand "Echo Area Backward Word" (p) - "Go back one word. - Don't let the luser move into the prompt." - "Signal an editor-error if we try to go into the prompt, otherwise - do a backward-word command." - (backward-word-command p) - (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*) - (beginning-of-parse-command ()) - (editor-error))) diff --git a/hemlock/ed-integrity.lisp b/hemlock/ed-integrity.lisp deleted file mode 100644 index 84696d40acf0f31775ef4883b883963f085e0836..0000000000000000000000000000000000000000 --- a/hemlock/ed-integrity.lisp +++ /dev/null @@ -1,156 +0,0 @@ -;;; -*- Package: hemlock; Log: hemlock.log; Mode: Lisp -*- - -;;; This stuff can be used for testing tty redisplay. There are four -;;; commands that, given "Setup Tty Buffer", that test -;;; HI::COMPUTE-TTY-CHANGES: "Two Deletes", "Two Inserts", "One Delete One -;;; Insert", and "One Insert One Delete. Each can be called with an -;;; argument to generate a grand total of eight screen permutations. -;;; "Setup Tty Buffer" numbers the lines of the main window 0 through 19 -;;; inclusively. -;;; -;;; "Setup for Debugging" and "Cleanup for Debugging" were helpful in -;;; conjunction with some alternate versions of COMPUTE-TTY-CHANGES and -;;; TTY-SMART-WINDOW-REDISPLAY. When something went wrong with on - -(in-package 'ed) - - -(proclaim '(special hemlock-internals::*debugging-tty-redisplay* - hemlock-internals::*testing-delete-queue* - hemlock-internals::*testing-insert-queue* - hemlock-internals::*testing-moved* - hemlock-internals::*testing-writes*)) - - -(defcommand "Setup Tty Buffer" (p) - "Clear buffer and insert numbering strings 0..19." - "Clear buffer and insert numbering strings 0..19." - (declare (ignore p)) - (delete-region (buffer-region (current-buffer))) - (let ((point (current-point))) - (dotimes (i 20) - (insert-string point (prin1-to-string i)) - (insert-character point #\newline)) - (buffer-start point))) - -(defcommand "Setup for Debugging" (p) - "Set *debugging-tty-redisplay* to t, and some other stuff to nil." - "Set *debugging-tty-redisplay* to t, and some other stuff to nil." - (declare (ignore p)) - (setf hi::*debugging-tty-redisplay* t) - (setf hi::*testing-delete-queue* nil) - (setf hi::*testing-insert-queue* nil) - (setf hi::*testing-moved* nil) - (setf hi::*testing-writes* nil)) - -(defcommand "Cleanup for Debugging" (p) - "Set *debugging-tty-redisplay* to nil." - "Set *debugging-tty-redisplay* to nil." - (declare (ignore p)) - (setf hi::*debugging-tty-redisplay* nil)) - -;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, 5, 10, 11, 12, -;;; 13, and 14. With argument, 3..7 and 12..14. -;;; -(defcommand "Two Deletes" (p) - "At line 3, delete 3 lines. At line 3+4, delete 5 lines. - With an argument, switch the number deleted." - "At line 3, delete 3 lines. At line 3+4, delete 5 lines. - With an argument, switch the number deleted." - (multiple-value-bind (dnum1 dnum2) - (if p (values 5 3) (values 3 5)) - (let ((point (current-point))) - (move-mark point (window-display-start (current-window))) - (line-offset point 3) - (with-mark ((end point :left-inserting)) - (line-offset end dnum1) - (delete-region (region point end)) - (line-offset point 4) - (line-offset (move-mark end point) dnum2) - (delete-region (region point end)))))) - - -;;; Given "Setup Tty Buffer", opens two blank lines between 2 and 3, and -;;; opens four blank lines between 6 and 7, leaving line numbered 13 at -;;; the bottom. With argument, four lines between 2 and 3, two lines -;;; between 6 and 7, and line 13 at the bottom of the window. -;;; -(defcommand "Two Inserts" (p) - "At line 3, open 2 lines. At line 3+2+4, open 4 lines. - With an argument, switch the number opened." - "At line 3, open 2 lines. At line 3+2+4, open 4 lines. - With an argument, switch the number opened." - (multiple-value-bind (onum1 onum2) - (if p (values 4 2) (values 2 4)) - (let ((point (current-point))) - (move-mark point (window-display-start (current-window))) - (line-offset point 3) - (dotimes (i onum1) - (insert-character point #\newline)) - (line-offset point 4) - (dotimes (i onum2) - (insert-character point #\newline))))) - - -;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, and 5, and -;;; opens five lines between lines numbered 9 and 10, leaving line numbered -;;; 17 on the bottom. With an argument, deletes lines numbered 3, 4, 5, 6, -;;; and 7, and opens three lines between 11 and 12, creating two blank lines -;;; at the end of the screen. -;;; -(defcommand "One Delete One Insert" (p) - "At line 3, delete 3 lines. At line 3+4, open 5 lines. - With an argument, switch the number of lines affected." - "At line 3, delete 3 lines. At line 3+4, open 5 lines. - With an argument, switch the number of lines affected." - (multiple-value-bind (dnum onum) - (if p (values 5 3) (values 3 5)) - (let ((point (current-point))) - (move-mark point (window-display-start (current-window))) - (line-offset point 3) - (with-mark ((end point :left-inserting)) - (line-offset end dnum) - (delete-region (region point end)) - (line-offset point 4) - (dotimes (i onum) - (insert-character point #\newline)))))) - -;;; Given "Setup Tty Buffer", opens three blank lines between lines numbered -;;; 2 and 3, and deletes lines numbered 7, 8, 9, 10, and 11, leaving two -;;; blank lines at the bottom of the window. With an argument, opens five -;;; blank lines between lines numbered 2 and 3, and deletes lines 7, 8, and -;;; 9, leaving line 17 at the bottom of the window. -;;; -(defcommand "One Insert One Delete" (p) - "At line 3, open 3 lines. At line 3+3+4, delete 5 lines. - With an argument, switch the number of lines affected." - "At line 3, open 3 lines. At line 3+3+4, delete 5 lines. - With an argument, switch the number of lines affected." - (multiple-value-bind (onum dnum) - (if p (values 5 3) (values 3 5)) - (let ((point (current-point))) - (move-mark point (window-display-start (current-window))) - (line-offset point 3) - (dotimes (i onum) - (insert-character point #\newline)) - (line-offset point 4) - (with-mark ((end point :left-inserting)) - (line-offset end dnum) - (delete-region (region point end)))))) - - -;;; This could be thrown away, but I'll leave it here. When I was testing -;;; the problem of generating EQ screen image lines due to faulty -;;; COMPUTE-TTY-CHANGES, this was a convenient command to get the editor -;;; back under control. -;;; -(defcommand "Fix Screen Image Lines" (p) - "" - "" - (declare (ignore p)) - (let* ((device (hi::device-hunk-device (hi::window-hunk (current-window)))) - (lines (hi::tty-device-lines device)) - (columns (hi::tty-device-columns device)) - (screen-image (hi::tty-device-screen-image device))) - (dotimes (i lines) - (setf (svref screen-image i) (hi::make-si-line columns))))) diff --git a/hemlock/edit-defs.lisp b/hemlock/edit-defs.lisp deleted file mode 100644 index e73ffe48c3bb4f81b4133269b8530063dff1e9e8..0000000000000000000000000000000000000000 --- a/hemlock/edit-defs.lisp +++ /dev/null @@ -1,331 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Editing DEFMACRO and DEFUN definitions. Also, has directory translation -;;; code for moved and/or different sources. -;;; -;;; This file is not portable, but if the last function is replaced with its -;;; commented-out original definition, the file will be portable. - -(in-package 'hemlock) - - -;;; Directory translation for definition editing commands. - -(defvar *definition-directory-translation-table* - (make-string-table) - "Hemlock string table for translating directory namestrings to other ones, so - a function defined in /x/y/z/.../file.ext will actually be looked for in - /whatever/.../file.ext.") - -(defun add-definition-dir-translation (dir1 dir2) - "Takes two directory namestrings and causes the first to be mapped to - the second. This is used in commands like \"Edit Definition\". - Successive uses of this push into a list of translations that will - be tried in order of traversing the list." - (push (pathname dir2) - (getstring (directory-namestring dir1) - *definition-directory-translation-table*))) - -(defun delete-definition-dir-translation (directory) - "Deletes the mapping of directory to all other directories for definition - editing commands." - (delete-string (directory-namestring directory) - *definition-directory-translation-table*)) - - -(defcommand "Add Definition Directory Translation" (p) - "Prompts for two directory namestrings and causes the first to be mapped to - the second for definition editing commands. Longer (more specific) directory - specifications are match before shorter (more general) ones. Successive - uses of this push into a list of translations that will be tried in order - of traversing the list." - "Prompts for two directory namestrings and causes the first to be mapped to - the second for definition editing commands." - (declare (ignore p)) - (let* ((dir1 (prompt-for-file :prompt "Preimage dir1: " - :help "directory namestring." - :must-exist nil)) - (dir2 (prompt-for-file :prompt "Postimage dir2: " - :help "directory namestring." - :must-exist nil))) - (add-definition-dir-translation dir1 dir2))) - -(defcommand "Delete Definition Directory Translation" (p) - "Prompts for a directory namestring and deletes it from the directory - translation table for the definition editing commands." - "Prompts for a directory namestring and deletes it from the directory - translation table for the definition editing commands." - (declare (ignore p)) - (delete-definition-dir-translation - (prompt-for-file :prompt "Directory: " - :help "directory namestring." - :must-exist nil))) - - - -;;; Definition Editing Commands. - -;;; These commands use a slave Lisp to determine the file the function is -;;; defined in. They do a synchronous evaluation of DEFIITION-EDITING-INFO. -;;; Then, in the editor Lisp, GO-TO-DEFINITION possibly translates the file -;;; name, finds the file, and tries to search for the defining form. - - -;;; For the "Go to Definition" search pattern, we just use " " as the initial -;;; pattern, so we can make a search pattern. Invocation of the command alters -;;; the search pattern. - -(defvar *go-to-def-pattern* - (new-search-pattern :string-insensitive :forward " ")) - -(defvar *last-go-to-def-string* "") -(proclaim '(simple-string *last-go-to-def-string*)) - -;;; GET-DEFINITION-PATTERN takes a type and a name. It returns a search -;;; pattern for finding the defining form for name using -;;; *go-to-def-pattern* and *last-go-to-def-string* destructively. The -;;; pattern contains a trailing space to avoid finding functions earlier -;;; in the file with the function's name as a prefix. This is not necessary -;;; with type :command since the name is terminated with a ". -;;; -(defun get-definition-pattern (type name) - (declare (simple-string name)) - (let ((string (case type - ((:function :unknown-function) - (concatenate 'simple-string "(defun " name " ")) - ((:macro :unknown-macro) - (concatenate 'simple-string "(defmacro " name " ")) - (:command - (concatenate 'simple-string - "(defcommand \"" - (nsubstitute #\space #\- - (subseq name 0 (- (length name) 8)) - :test #'char=) - "\""))))) - (declare (simple-string string)) - (cond ((string= string *last-go-to-def-string*) - *go-to-def-pattern*) - (t (setf *last-go-to-def-string* string) - (new-search-pattern :string-insensitive :forward - string *go-to-def-pattern*))))) - -(defhvar "Editor Definition Info" - "When this is non-nil, the editor Lisp is used to determine definition - editing information; otherwise, the slave Lisp is used." - :value nil) - -(defcommand "Goto Definition" (p) - "Go to the current function/macro's definition. If it isn't defined by a - DEFUN or DEFMACRO form, then the defining file is simply found. If the - function is not compiled, then it is looked for in the current buffer." - "Go to the current function/macro's definition." - (declare (ignore p)) - (let ((point (current-point))) - (pre-command-parse-check point) - (with-mark ((mark1 point) - (mark2 point)) - (unless (backward-up-list mark1) (editor-error)) - (form-offset (move-mark mark2 (mark-after mark1)) 1) - (let ((fun-name (region-to-string (region mark1 mark2)))) - (get-def-info-and-go-to-it fun-name))))) - -(defcommand "Edit Definition" (p) - "Prompts for function/macro's definition name and goes to it for editing." - "Prompts for function/macro's definition name and goes to it for editing." - (declare (ignore p)) - (let ((fun-name (prompt-for-string - :prompt "Name: " - :help "Symbol name of function."))) - (get-def-info-and-go-to-it fun-name))) - -(defun get-def-info-and-go-to-it (fun-name) - (let ((in-editor-p (value editor-definition-info)) - (info (value current-eval-server))) - (if (or in-editor-p - (not info)) - (multiple-value-bind (pathname type name) - (in-lisp - (definition-editing-info fun-name)) - (unless in-editor-p - (message "Editing definition from editor Lisp ...")) - (go-to-definition pathname type name)) - (let ((results (eval-form-in-server - info - (format nil "(ed::definition-editing-info ~S)" - fun-name)))) - (go-to-definition (read-from-string (first results)) ;file - (read-from-string (second results)) ;type - (read-from-string (third results))))))) ;name - -;;; "Edit Command Definition" is a hack due to creeping evolution in -;;; GO-TO-DEFINITION. We specify :function type and a name with "-COMMAND" -;;; instead of :command type and the real command name because this causes -;;; the right pattern to be created for searching. We could either specify -;;; that you always edit command definitions with this command (breaking -;;; "Go to Definition" for commands called as functions), fixing the code, -;;; or we can hack this command so everything works. -;;; -(defcommand "Edit Command Definition" (p) - "Prompts for command definition name and goes to it for editing." - "Prompts for command definition name and goes to it for editing." - (multiple-value-bind - (name command) - (if p - (multiple-value-bind (key cmd) - (prompt-for-key :prompt "Edit command bound to: ") - (declare (ignore key)) - (values (command-name cmd) cmd)) - (prompt-for-keyword (list *command-names*) - :prompt "Command to edit: ")) - (go-to-definition (fun-defined-from-pathname (command-function command)) - :function - (concatenate 'simple-string name "-COMMAND")))) - -;;; GO-TO-DEFINITION tries to find name in file with a search pattern based -;;; on type (defun or defmacro). File may be translated to another source -;;; file, and if type is a function that cannot be found, we try to find a -;;; command by an appropriate name. -;;; -(defun go-to-definition (file type name) - (let ((pattern (get-definition-pattern type name))) - (cond - (file - (setf file (go-to-definition-file file)) - (let* ((buffer (find-file-command nil file)) - (point (buffer-point buffer)) - (name-len (length name))) - (declare (fixnum name-len)) - (with-mark ((def-mark point)) - (buffer-start def-mark) - (unless (find-pattern def-mark pattern) - (if (and (or (eq type :function) (eq type :unknown-function)) - (> name-len 7) - (string= name "COMMAND" :start1 (- name-len 7))) - (let ((prev-search-str *last-go-to-def-string*)) - (unless (find-pattern def-mark - (get-definition-pattern :command name)) - (editor-error "~A is not defined with ~S or ~S, ~ - but this is the defined-in file." - (string-upcase name) prev-search-str - *last-go-to-def-string*))) - (editor-error "~A is not defined with ~S, ~ - but this is the defined-in file." - (string-upcase name) *last-go-to-def-string*))) - (if (eq buffer (current-buffer)) - (push-buffer-mark (copy-mark point))) - (move-mark point def-mark)))) - (t - (when (or (eq type :unknown-function) (eq type :unknown-macro)) - (with-mark ((m (buffer-start-mark (current-buffer)))) - (unless (find-pattern m pattern) - (editor-error - "~A is not compiled and not defined in current buffer with ~S" - (string-upcase name) *last-go-to-def-string*)) - (let ((point (current-point))) - (push-buffer-mark (copy-mark point)) - (move-mark point m)))))))) - -;;; GO-TO-DEFINITION-FILE takes a pathname and translates it to another -;;; according to "Add Definition Directory Translation". Take the first -;;; probe-able translation, or probe file if no translations are found. -;;; If no existing file is found, an editor error is signaled. -;;; -(defun go-to-definition-file (file) - (multiple-value-bind (unmatched-dir new-dirs file-name) - (maybe-translate-definition-file file) - (loop - (when (null new-dirs) - (unless (probe-file file) - (if unmatched-dir - (editor-error "Cannot find file ~S or any of its translations." - file) - (editor-error "Cannot find file ~S." file))) - (return file)) - (let ((f (translate-definition-file unmatched-dir (pop new-dirs) - file-name))) - (when (probe-file f) - (setf file f) - (return f)))))) - -;;; MAYBE-TRANSLATE-DEFINITION-FILE tries each directory subsequence from the -;;; most specific to the least looking a user defined translation. At the end -;;; of the file there is a commented out version of this function that is -;;; portable (no "/" monkeying around), but it only checks the entire directory -;;; string for a translation. This returns the portion of the input directory -;;; sequence that was not matched (to be merged with the mapping of the matched -;;; portion), the list of post image directories, and the file name. -;;; -(defun maybe-translate-definition-file (file) - (let* ((dirs (pathname-directory file)) - (len (length dirs)) - (i len)) - (declare (simple-vector dirs) - (fixnum len i)) - (loop - (when (zerop i) (return nil)) - (let ((new-dirs (getstring (directory-namestring - (make-pathname :defaults "/" - :directory (subseq dirs 0 i))) - *definition-directory-translation-table*))) - (when new-dirs - (return (values (subseq dirs i len) new-dirs - (file-namestring file))))) - (decf i)))) - -;;; TRANSLATE-DEFINITION-FILE creates a directory sequence from unmatched-dir -;;; and new-dir, creating a translated pathname for GO-TO-DEFINITION. A -;;; portable version of this is described at the end of this file. -;;; -(defun translate-definition-file (unmatched-dir new-dir file-name) - (make-pathname :defaults "/" - :device (pathname-device new-dir) - :directory (concatenate 'simple-vector - (pathname-directory new-dir) - unmatched-dir) - :name file-name)) - - -;;; DEFINITION-EDITING-INFO runs in a slave Lisp and returns the pathname -;;; that the global definition of the symbol whose name is string is defined -;;; in. -;;; -(defun definition-editing-info (string) - (let ((symbol (read-from-string string))) - (check-type symbol symbol) - (let ((macro (macro-function symbol)) - (name (symbol-name symbol))) - (if macro - (let ((file (fun-defined-from-pathname macro))) - (if file - (values file :macro name) - (values nil :unknown-macro name))) - (if (fboundp symbol) - (let ((file (fun-defined-from-pathname symbol))) - (if file - (values file :function name) - (values nil :unknown-function name))) - (error "~S is not a function." symbol)))))) - - -#| -;;; Using this version of MAYBE-TRANSLATE-DEFINITION-FILE makes everything -;;; portable. TRANSLATE-DEFINITION-FILE should be rewritten to simply do -;;; (merge-pathnames new-dir file-name). - -;;; This older version does not match longer, more specific directory specs -;;; like the above one. This one only matches complete directory specs. -(defun maybe-translate-definition-file (file) - (let ((new-dir (getstring (directory-namestring file) - *definition-directory-translation-table*))) - (if new-dir - (values (make-array 0) new-dir (file-namestring file))))) -|# - diff --git a/hemlock/eval-server.lisp b/hemlock/eval-server.lisp deleted file mode 100644 index 00b18161aaed5df926a478f691adf33a67037737..0000000000000000000000000000000000000000 --- a/hemlock/eval-server.lisp +++ /dev/null @@ -1,981 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains code for connecting to eval servers and some command -;;; level stuff too. -;;; -;;; Written by William Lott. -;;; - -(in-package "HEMLOCK") - - - -;;;; Structures. - -(defstruct (server-info (:print-function print-server-info)) - name ; String name of this server. - wire ; Wire connected to this server. - notes ; List of note objects for operations - ; which have not yet completed. - slave-info ; Ts-Info used in "Slave Lisp" buffer - ; (formerly the "Lisp Listener" buffer). - slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*. - background-info ; Ts-Info structure of typescript we use in - ; "background" buffer. - background-buffer ; Buffer "background" typescript is in. - (errors ; Array of errors while compiling - (make-array 16 - :adjustable t - :fill-pointer 0)) - error-index) ; Index of current error. -;;; -(defun print-server-info (obj stream n) - (declare (ignore n)) - (format stream "#<Server-info for ~A>" (server-info-name obj))) - - -(defstruct (error-info (:print-function print-error-info)) - buffer ; Buffer this error is for. - message ; Error Message - line ; Pointer to message in log buffer. - region) ; Region of faulty text -;;; -(defun print-error-info (obj stream n) - (declare (ignore n)) - (format stream "#<Error: ~A>" (error-info-message obj))) - - -(defvar *server-names* (make-string-table) - "A string-table of the name of all Eval servers and their corresponding - server-info structures.") - -(defvar *abort-operations* nil - "T iff we should ignore any operations sent to us.") - -(defvar *inside-operation* nil - "T iff we are currenly working on an operation. A catcher for the tag - abort-operation will be established whenever this is T.") - -(defconstant *slave-connect-wait* 300) - -;;; Used internally for communications. -;;; -(defvar *newly-created-slave* nil) -(defvar *compiler-wire* nil) -(defvar *compiler-error-stream* nil) -(defvar *compiler-note* nil) - - - -;;;; Hemlock Variables - -(defhvar "Current Eval Server" - "The Server-Info object for the server currently used for evaluation and - compilation." - :value nil) - -(defhvar "Current Compile Server" - "The Server-Info object for the server currently used for compilation - requests." - :value nil) - -(defhvar "Current Package" - "This variable holds the name of the package currently used for Lisp - evaluation and compilation. If it is Nil, the value of *Package* is used - instead." - :value nil) - -(defhvar "Slave Utility" - "This is the pathname of the utility to fire up slave Lisps. It defaults - to /usr/misc/.lisp/bin/lisp." - :value "/usr/misc/.lisp/bin/lisp") - -(defhvar "Slave Utility Switches" - "These are additional switches to pass to the Slave Utility. - For example, (list \"-core\" <core-file-name>). The -slave - switch and the editor name are always supplied, and they should - not be present in this variable." - :value nil) - -(defhvar "Ask About Old Servers" - "When set (the default), Hemlock will prompt for an existing server's name - in preference to prompting for a new slave's name and creating it." - :value t) - -(defhvar "Confirm Slave Creation" - "When set (the default), Hemlock always confirms a slave's creation for - whatever reason." - :value t) - - - -;;;; Slave destruction. - -;;; WIRE-DIED -- Internal. -;;; -;;; The routine is called whenever a wire dies. We roll through all the -;;; servers looking for any that use this wire and nuke them with server-died. -;;; -(defun wire-died (wire) - (let ((servers nil)) - (do-strings (name info *server-names*) - (declare (ignore name)) - (when (eq wire (server-info-wire info)) - (push info servers))) - (dolist (server servers) - (server-died server)))) - -;;; SERVER-DIED -- Internal. -;;; -;;; Clean up the server. Remove any references to it from variables, etc. -;;; -(defun server-died (server) - (let ((name (server-info-name server))) - (delete-string name *server-names*) - (message "Server ~A just died." name)) - (when (server-info-wire server) - (let ((fd (wire:wire-fd (server-info-wire server)))) - (system:invalidate-descriptor fd) - (mach:unix-close fd)) - (setf (server-info-wire server) nil)) - (when (server-info-slave-info server) - (ts-buffer-wire-died (server-info-slave-info server)) - (setf (server-info-slave-info server) nil)) - (when (server-info-background-info server) - (ts-buffer-wire-died (server-info-background-info server)) - (setf (server-info-background-info server) nil)) - (clear-server-errors server) - (when (eq server (variable-value 'current-eval-server :global)) - (setf (variable-value 'current-eval-server :global) nil)) - (when (eq server (variable-value 'current-compile-server :global)) - (setf (variable-value 'current-compile-server :global) nil)) - (dolist (buffer *buffer-list*) - (dolist (var '(current-eval-server current-compile-server server-info)) - (when (and (hemlock-bound-p var :buffer buffer) - (eq (variable-value var :buffer buffer) server)) - (delete-variable var :buffer buffer))))) - -;;; SERVER-CLEANUP -- Internal. -;;; -;;; This routine is called as a buffer delete hook. It takes care of any -;;; per-buffer cleanup that is necessary. It clears out all references to the -;;; buffer from server-info structures and that any errors that refer to this -;;; buffer are finalized. -;;; -(defun server-cleanup (buffer) - (let ((info (if (hemlock-bound-p 'server-info :buffer buffer) - (variable-value 'server-info :buffer buffer)))) - (when info - (when (eq buffer (server-info-slave-buffer info)) - (setf (server-info-slave-buffer info) nil) - (setf (server-info-slave-info info) nil)) - (when (eq buffer (server-info-background-buffer info)) - (setf (server-info-background-buffer info) nil) - (setf (server-info-background-info info) nil)))) - (do-strings (string server *server-names*) - (declare (ignore string)) - (clear-server-errors server - #'(lambda (error) - (eq (error-info-buffer error) buffer))))) -;;; -(add-hook delete-buffer-hook 'server-cleanup) - -;;; CLEAR-SERVER-ERRORS -- Public. -;;; -;;; Clears all known errors for the given server and resets it so more can -;;; accumulate. -;;; -(defun clear-server-errors (server &optional test-fn) - "This clears compiler errors for server cleaning up any pointers for GC - purposes and allowing more errors to register." - (let ((array (server-info-errors server)) - (current nil)) - (dotimes (i (fill-pointer array)) - (let ((error (aref array i))) - (when (or (null test-fn) - (funcall test-fn error)) - (let ((region (error-info-region error))) - (when (regionp region) - (delete-mark (region-start region)) - (delete-mark (region-end region)))) - (setf (aref array i) nil)))) - (let ((index (server-info-error-index server))) - (when index - (setf current - (or (aref array index) - (find-if-not #'null array - :from-end t - :end current))))) - (delete nil array) - (setf (server-info-error-index server) - (position current array)))) - - - -;;;; Slave creation. - -;;; INITIALIZE-SERVER-STUFF -- Internal. -;;; -;;; Reinitialize stuff when a core file is saved. -;;; -(defun initialize-server-stuff () - (clrstring *server-names*)) - - -(defvar *editor-name* nil "Name of this editor.") -(defvar *accept-connections* nil - "When set, allow slaves to connect to the editor.") - -;;; GET-EDITOR-NAME -- Internal. -;;; -;;; Pick a name for the editor. Names consist of machine-name:port-number. If -;;; in ten tries we can't get an unused port, choak. We don't save the result -;;; of WIRE:CREATE-REQUEST-SERVER because we don't think the editor needs to -;;; ever kill the request server, and we can always inhibit connection with -;;; "Accept Connections". -;;; -(defun get-editor-name () - (if *editor-name* - *editor-name* - (let ((random-state (make-random-state t))) - (dotimes (tries 10 (error "Could not create an internet listener.")) - (let ((port (+ 2000 (random 10000 random-state)))) - (when (handler-case (wire:create-request-server - port - #'(lambda (wire addr) - (declare (ignore addr)) - (values *accept-connections* - #'(lambda () (wire-died wire))))) - (error () nil)) - (return (setf *editor-name* - (format nil "~A:~D" (machine-instance) port))))))))) - - -;;; MAKE-BUFFERS-FOR-TYPESCRIPT -- Internal. -;;; -;;; This function returns no values because it is called remotely for value by -;;; connecting slaves. Though we know the system will propagate nil back to -;;; the slave, we indicate here that nil is meaningless. -;;; -(defun make-buffers-for-typescript (slave-name background-name) - "Make the interactive and background buffers slave-name and background-name. - If either is nil, then prompt the user." - (multiple-value-bind (slave-name background-name) - (if (and slave-name background-name) - (values slave-name background-name) - (pick-slave-buffer-names)) - (let* ((slave-buffer (or (getstring slave-name *buffer-names*) - (make-buffer slave-name :modes '("Lisp")))) - (background-buffer (or (getstring background-name *buffer-names*) - (make-buffer background-name - :modes '("Lisp")))) - (server-info (make-server-info :name slave-name - :wire wire:*current-wire* - :slave-buffer slave-buffer - :background-buffer background-buffer)) - (slave-info (typescriptify-buffer slave-buffer server-info - wire:*current-wire*)) - (background-info (typescriptify-buffer background-buffer server-info - wire:*current-wire*))) - (setf (server-info-slave-info server-info) slave-info) - (setf (server-info-background-info server-info) background-info) - (setf (getstring slave-name *server-names*) server-info) - (unless (variable-value 'current-eval-server :global) - (setf (variable-value 'current-eval-server :global) server-info)) - (wire:remote-value - wire:*current-wire* - (made-buffers-for-typescript (wire:make-remote-object slave-info) - (wire:make-remote-object background-info))) - (setf *newly-created-slave* server-info) - (values)))) - - -;;; CREATE-SLAVE -- Public. -;;; -(defun create-slave (&optional 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. Name is - the name of the interactive buffer. If name is nil, this generates a name. - If name is supplied, and a buffer with that name already exists, this - signals an error. In case the slave never connects, this will eventually - timeout and signal an editor-error." - (when (and name (getstring name *buffer-names*)) - (editor-error "Buffer ~A is already in use." name)) - (multiple-value-bind (slave background) - (if name - (values name (format nil "Background ~A" name)) - (pick-slave-buffer-names)) - (when (value confirm-slave-creation) - (setf slave (prompt-for-string - :prompt "New slave name? " - :help "Enter the name to use for the newly created slave." - :default slave - :default-string slave)) - (setf background (format nil "Background ~A" slave)) - (when (getstring slave *buffer-names*) - (editor-error "Buffer ~A is already in use." slave)) - (when (getstring background *buffer-names*) - (editor-error "Buffer ~A is already in use." background))) - (message "Spawning slave ... ") - (unless (ext:run-program (namestring (truename (value slave-utility))) - `("-slave" ,(get-editor-name) - ,@(if slave (list "-slave-buffer" slave)) - ,@(if background - (list "-background-buffer" background)) - ,@(value slave-utility-switches)) - :wait nil - :output "/dev/null" - :if-output-exists :append) - (editor-error "Could not start slave.")) - (let ((*accept-connections* t) - (*newly-created-slave* nil)) - (dotimes (i *slave-connect-wait* - (editor-error "Client Lisp is still unconnected. ~ - You must use \"Accept Slave Connections\" to ~ - allow the slave to connect at this point.")) - (system:serve-event 1) - (when *newly-created-slave* - (message "DONE") - (return *newly-created-slave*)))))) - -;;; MAYBE-CREATE-SERVER -- Internal interface. -;;; -(defun maybe-create-server () - "If there is an existing server and \"Ask about Old Servers\" is set, then - prompt for a server's name and return that server's info. Otherwise, - create a new server." - (if (value ask-about-old-servers) - (multiple-value-bind (first-server-name first-server-info) - (do-strings (name info *server-names*) - (return (values name info))) - (if first-server-info - (multiple-value-bind - (name info) - (prompt-for-keyword (list *server-names*) - :prompt "Existing server name: " - :default first-server-name - :default-string first-server-name - :help - "Enter the name of an existing eval server." - :must-exist t) - (declare (ignore name)) - (or info (create-slave))) - (create-slave))) - (create-slave))) - - -(defvar *next-slave-index* 0 - "Number to use when creating the next slave.") - -;;; PICK-SLAVE-BUFFER-NAMES -- Internal. -;;; -;;; Return two unused names to use for the slave and background buffers. -;;; -(defun pick-slave-buffer-names () - (loop - (let ((slave (format nil "Slave ~D" (incf *next-slave-index*))) - (background (format nil "Background Slave ~D" *next-slave-index*))) - (unless (or (getstring slave *buffer-names*) - (getstring background *buffer-names*)) - (return (values slave background)))))) - - - -;;;; Slave selection. - -;;; GET-CURRENT-EVAL-SERVER -- Public. -;;; -(defun get-current-eval-server (&optional errorp) - "Returns the server-info struct for the current eval server. If there is - none, and errorp is non-nil, then signal an editor error. If there is no - current server, and errorp is nil, then create one, prompting the user for - confirmation. Also, set the current server to be the newly created one." - (let ((info (value current-eval-server))) - (cond (info) - (errorp - (editor-error "No current eval server.")) - (t - (setf (value current-eval-server) (maybe-create-server)))))) - -;;; GET-CURRENT-COMPILE-SERVER -- Public. -;;; -;;; If a current compile server is defined, return it, otherwise return the -;;; current eval server using get-current-eval-server. -;;; -(defun get-current-compile-server (&optional errorp) - "Returns the server-info struct for the current compile server. If there is - no current compile server, return the current eval server." - (or (value current-compile-server) - (get-current-eval-server errorp))) - - - -;;;; Server Manipulation commands. - -(defcommand "Select Slave" (p) - "Switch to the current slave's buffer. When given an argument, create a new - slave." - "Switch to the current slave's buffer. When given an argument, create a new - slave." - (let* ((info (if p (create-slave) (get-current-eval-server))) - (slave (server-info-slave-buffer info))) - (unless slave - (editor-error "The current eval server doesn't have a slave buffer!")) - (change-to-buffer slave))) - -(defcommand "Select Background" (p) - "Switch to the current slave's background buffer. When given an argument, use - the current compile server instead of the current eval server." - "Switch to the current slave's background buffer. When given an argument, use - the current compile server instead of the current eval server." - (let* ((info (if p - (get-current-compile-server t) - (get-current-eval-server t))) - (background (server-info-background-buffer info))) - (unless background - (editor-error "The current ~A server doesn't have a background buffer!" - (if p "compile" "eval"))) - (change-to-buffer background))) - -(defcommand "Kill Slave" (p) - "This aborts any operations in the slave, tells the slave to QUIT, and shuts - down the connection to the specified eval server. This makes no attempt to - assure the eval server actually dies." - "This aborts any operations in the slave, tells the slave to QUIT, and shuts - down the connection to the specified eval server. This makes no attempt to - assure the eval server actually dies." - (declare (ignore p)) - (let ((default (and (value current-eval-server) - (server-info-name (value current-eval-server))))) - (multiple-value-bind - (name info) - (prompt-for-keyword - (list *server-names*) - :prompt "Kill Slave: " - :help "Enter the name of the eval server you wish to destroy." - :must-exist t - :default default - :default-string default) - (declare (ignore name)) - (let ((wire (server-info-wire info))) - (when wire - (ext:send-character-out-of-band (wire:wire-fd wire) #\N) - (wire:remote wire (ext:quit)) - (wire:wire-force-output wire))) - (server-died info)))) - -(defcommand "Kill Slave and Buffers" (p) - "This is the same as \"Kill Slave\", but it also deletes the slaves - interaction and background buffers." - "This is the same as \"Kill Slave\", but it also deletes the slaves - interaction and background buffers." - (declare (ignore p)) - (let ((default (and (value current-eval-server) - (server-info-name (value current-eval-server))))) - (multiple-value-bind - (name info) - (prompt-for-keyword - (list *server-names*) - :prompt "Kill Slave: " - :help "Enter the name of the eval server you wish to destroy." - :must-exist t - :default default - :default-string default) - (declare (ignore name)) - (let ((wire (server-info-wire info))) - (when wire - (ext:send-character-out-of-band (wire:wire-fd wire) #\N) - (wire:remote wire (ext:quit)) - (wire:wire-force-output wire))) - (let ((buffer (server-info-slave-buffer info))) - (when buffer (delete-buffer-if-possible buffer))) - (let ((buffer (server-info-background-buffer info))) - (when buffer (delete-buffer-if-possible buffer))) - (server-died info)))) - -(defcommand "Accept Slave Connections" (p) - "This causes Hemlock to accept slave connections and displays the port of - the editor's connections request server. This is suitable for use with the - Lisp's -slave switch. Given an argument, this inhibits slave connections." - "This causes Hemlock to accept slave connections and displays the port of - the editor's connections request server. This is suitable for use with the - Lisp's -slave switch. Given an argument, this inhibits slave connections." - (let ((accept (not p))) - (setf *accept-connections* accept) - (message "~:[Inhibiting~;Accepting~] connections to ~S" - accept (get-editor-name)))) - - - -;;;; Slave initialization junk. - -(defvar *original-beep-function* nil - "Handle on original beep function.") - -(defvar *original-gc-notify-before* nil - "Handle on original before-GC notification function.") - -(defvar *original-gc-notify-after* nil - "Handle on original after-GC notification function.") - -(defvar *original-terminal-io* nil - "Handle on original *terminal-io* so we can restore it.") - -(defvar *original-standard-input* nil - "Handle on original *standard-input* so we can restore it.") - -(defvar *original-standard-output* nil - "Handle on original *standard-output* so we can restore it.") - -(defvar *original-error-output* nil - "Handle on original *error-output* so we can restore it.") - -(defvar *original-debug-io* nil - "Handle on original *debug-io* so we can restore it.") - -(defvar *original-query-io* nil - "Handle on original *query-io* so we can restore it.") - -(defvar *original-trace-output* nil - "Handle on original *trace-output* so we can restore it.") - -(defvar *background-io* nil - "Stream connected to the editor's background buffer in case we want to use it - in the future.") - -;;; CONNECT-STREAM -- internal -;;; -;;; Run in the slave to create a new stream and connect it to the supplied -;;; buffer. Returns the stream. -;;; -(defun connect-stream (remote-buffer) - (let ((stream (make-ts-stream wire:*current-wire* remote-buffer))) - (wire:remote wire:*current-wire* - (ts-buffer-set-stream remote-buffer - (wire:make-remote-object stream))) - stream)) - -;;; MADE-BUFFERS-FOR-TYPESCRIPT -- Internal Interface. -;;; -;;; Run in the slave by the editor with the two buffers' info structures, -;;; actually remote-objects in the slave. Does any necessary stream hacking. -;;; Return nil to make sure no weird objects try to go back over the wire -;;; since the editor calls this in the slave for value. The editor does this -;;; for synch'ing, not for values. -;;; -(defun made-buffers-for-typescript (slave-info background-info) - (macrolet ((frob (symbol new-value) - `(setf ,(intern (concatenate 'simple-string - "*ORIGINAL-" - (subseq (string symbol) 1))) - ,symbol - ,symbol ,new-value))) - (let ((wire wire:*current-wire*)) - (frob system:*beep-function* - #'(lambda (&optional stream) - (declare (ignore stream)) - (wire:remote-value wire (beep)))) - (frob ext:*gc-notify-before* - #'(lambda (bytes-in-use) - (wire:remote wire - (slave-gc-notify-before - slave-info - (format nil - "~%[GC threshold exceeded with ~:D bytes in use. ~ - Commencing GC.]~%" - bytes-in-use))) - (wire:wire-force-output wire))) - (frob ext:*gc-notify-after* - #'(lambda (bytes-retained bytes-freed new-trigger) - (wire:remote wire - (slave-gc-notify-after - slave-info - (format nil - "[GC completed with ~:D bytes retained and ~:D ~ - bytes freed.]~%[GC will next occur when at least ~ - ~:D bytes are in use.]~%" - bytes-retained bytes-freed new-trigger))) - (wire:wire-force-output wire)))) - (frob *terminal-io* (connect-stream slave-info)) - (frob *standard-input* (make-synonym-stream '*terminal-io*)) - (frob *standard-output* *standard-input*) - (frob *error-output* *standard-input*) - (frob *debug-io* *standard-input*) - (frob *query-io* *standard-input*) - (frob *trace-output* *standard-input*)) - (setf *background-io* (connect-stream background-info)) - nil) - -;;; SLAVE-GC-NOTIFY-BEFORE and SLAVE-GC-NOTIFY-AFTER -- internal -;;; -;;; These two routines are run in the editor by the slave's gc notify routines. -;;; -(defun slave-gc-notify-before (remote-ts message) - (let ((ts (wire:remote-object-value remote-ts))) - (ts-buffer-output-string ts message t) - (message "~A is GC'ing." (buffer-name (ts-data-buffer ts))) - (system:beep))) -(defun slave-gc-notify-after (remote-ts message) - (let ((ts (wire:remote-object-value remote-ts))) - (ts-buffer-output-string ts message t) - (message "~A is done GC'ing." (buffer-name (ts-data-buffer ts))) - (system:beep))) - -;;; EDITOR-DIED -- internal -;;; -;;; Run in the slave when the editor goes belly up. -;;; -(defun editor-died () - (macrolet ((frob (symbol) - (let ((orig (intern (concatenate 'simple-string - "*ORIGINAL-" - (subseq (string symbol) 1))))) - `(when ,orig - (setf ,symbol ,orig))))) - (frob system:*beep-function*) - (frob ext:*gc-notify-before*) - (frob ext:*gc-notify-after*) - (frob *terminal-io*) - (frob *standard-input*) - (frob *standard-output*) - (frob *error-output*) - (frob *debug-io*) - (frob *query-io*) - (frob *trace-output*)) - (setf *background-io* nil) - (format t "~2&Connection to editor died.~%") - (ext:quit)) - -;;; START-SLAVE -- internal -;;; -;;; Initiate the process by which a lisp becomes a slave. -;;; -(defun start-slave (editor) - (declare (simple-string editor)) - (let ((seperator (position #\: editor :test #'char=))) - (unless seperator - (error "Editor name ~S invalid. ~ - Must be of the form \"MachineName:PortNumber\"." - editor)) - (let ((machine (subseq editor 0 seperator)) - (port (parse-integer editor :start (1+ seperator)))) - (format t "Connecting to ~A:~D~%" machine port) - (connect-to-editor machine port)))) - -;;; CONNECT-TO-EDITOR -- internal -;;; -;;; Do the actual connect to the editor. -;;; -(defun connect-to-editor (machine port - &optional - (slave (find-eval-server-switch "slave-buffer")) - (background (find-eval-server-switch - "background-buffer"))) - (let ((wire (wire:connect-to-remote-server machine port 'editor-died))) - (ext:add-oob-handler (wire:wire-fd wire) - #\B - #'(lambda () - (system:without-hemlock - (system:with-interrupts - (break "Software Interrupt"))))) - (ext:add-oob-handler (wire:wire-fd wire) - #\T - #'(lambda () - (when lisp::*in-top-level-catcher* - (throw 'lisp::top-level-catcher nil)))) - (ext:add-oob-handler (wire:wire-fd wire) - #\A - #'abort) - (ext:add-oob-handler (wire:wire-fd wire) - #\N - #'(lambda () - (setf *abort-operations* t) - (when *inside-operation* - (throw 'abort-operation - (if debug::*in-the-debugger* - :was-in-debugger))))) - (wire:remote-value wire - (make-buffers-for-typescript slave background)))) - - -;;;; Eval server evaluation functions. - -(defvar *eval-form-stream* - (make-two-way-stream - (lisp::make-stream - :in #'(lambda (&rest junk) - (declare (ignore junk)) - (error "You cannot read when handling an eval_form request."))) - (make-broadcast-stream))) - -;;; SERVER-EVAL-FORM -- Public. -;;; Evaluates the given form (which is a string to be read from in the given -;;; package) and returns the results as a list. -;;; -(defun server-eval-form (package form) - (declare (simple-string package form)) - (handler-bind - ((error #'(lambda (condition) - (wire:remote wire:*current-wire* - (eval-form-error (format nil "~A~&" condition))) - (return-from server-eval-form nil)))) - (let ((*package* (if package - (lisp::package-or-lose package) - *package*)) - (*terminal-io* *eval-form-stream*)) - (stringify-list (multiple-value-list (eval (read-from-string form))))))) - - -;;; DO-OPERATION -- Internal. -;;; Checks to see if we are aborting operations. If not, do the operation -;;; wrapping it with operation-started and operation-completed calls. Also -;;; deals with setting up *terminal-io* and *package*. -;;; -(defmacro do-operation ((note package terminal-io) &body body) - `(let ((aborted t) - (*terminal-io* (if ,terminal-io - (wire:remote-object-value ,terminal-io) - *terminal-io*)) - (*package* (maybe-make-package ,package))) - (unwind-protect - (unless *abort-operations* - (when (eq :was-in-debugger - (catch 'abort-operation - (let ((*inside-operation* t)) - (wire:remote wire:*current-wire* - (operation-started ,note)) - (wire:wire-force-output wire:*current-wire*) - ,@body - (setf aborted nil)))) - (format t - "~&[Operation aborted. ~ - You are no longer in this instance of the debugger.]~%"))) - (wire:remote wire:*current-wire* - (operation-completed ,note aborted)) - (wire:wire-force-output wire:*current-wire*)))) - - -;;; unique-thingie is a unique eof-value for READ'ing. Its a parameter, so -;;; we can reload the file. -;;; -(defparameter unique-thingie (gensym) - "Used as eof-value in reads to check for the end of a file.") - -;;; SERVER-EVAL-TEXT -- Public. -;;; -;;; Evaluate all the forms read from text in the given package, and send the -;;; results back. The error handler bound does not handle any errors. It -;;; simply notifies the client that an error occurred and then returns. -;;; -(defun server-eval-text (note package text terminal-io) - (do-operation (note package terminal-io) - (with-input-from-string (stream text) - (let ((last-pos 0)) - (handler-bind - ((error - #'(lambda (condition) - (wire:remote wire:*current-wire* - (lisp-error note last-pos - (file-position stream) - (format nil "~A~&" condition)))))) - (loop - (let ((form (read stream nil unique-thingie))) - (when (eq form unique-thingie) - (return nil)) - (let* ((values (stringify-list (multiple-value-list (eval form)))) - (pos (file-position stream))) - (wire:remote wire:*current-wire* - (eval-text-result note last-pos pos values)) - (setf last-pos pos))))))))) - -(defun stringify-list (list) - (mapcar #'prin1-to-string list)) -#| -(defun stringify-list (list) - (mapcar #'(lambda (thing) - (with-output-to-string (stream) - (write thing - :stream stream :radix nil :base 10 :circle t - :pretty nil :level nil :length nil :case :upcase - :array t :gensym t))) - list)) -|# - - -;;;; Eval server compilation stuff. - -;;; DO-COMPILER-OPERATION -- Internal. -;;; -;;; Useful macro that does the operation with *compiler-note* and -;;; *compiler-wire* bound. -;;; -(defmacro do-compiler-operation ((note package terminal-io error) &body body) - `(let ((*compiler-note* ,note) - (*compiler-error-stream* ,error) - (*compiler-wire* wire:*current-wire*) - (clc:*compiler-notification-function* #'compiler-note-in-editor)) - (do-operation (*compiler-note* ,package ,terminal-io) - (unwind-protect - (handler-bind ((error #'compiler-error-handler)) - ,@body) - (when *compiler-error-stream* - (force-output *compiler-error-stream*)))))) - -;;; COMPILER-NOTIFICATION -- Internal. -;;; -;;; DO-COMPILER-OPERATION binds clc:*compiler-notification-function to this, so -;;; interesting observations in the compilation can be propagated back to the -;;; editor. If there is a notification point defined, we send information -;;; about the position and kind of error. The actual error text is written out -;;; using typescript operations. -;;; -;;; Start and End are the compiler's best guess at the file position where the -;;; error occurred. Function is the symbolic name of the function in which the -;;; error occurred. We PRIN1 this to a string because sending the symbol back -;;; to the editor could easily result in the editor trying to fetch a symbol -;;; off the wire into a non-existing package. We expect packages to exist in -;;; the developing Lisp environment that are missing in the editor's Lisp. -;;; -(defun compiler-note-in-editor (severity function) - (when *compiler-wire* - (force-output *compiler-error-stream*) - (multiple-value-bind (start end) - (clc:current-form-position) - (wire:remote *compiler-wire* - (compiler-error *compiler-note* start end - (prin1-to-string function) - severity))) - (wire:wire-force-output *compiler-wire*))) - -;;; COMPILER-ERROR-HANDLER -- Internal. -;;; -;;; The error handler function for the compiler interfaces. -;;; DO-COMPILER-OPERATION binds this as an error handler while evaluating the -;;; compilation form. -;;; -(defun compiler-error-handler (condition) - (when *compiler-wire* - (multiple-value-bind (start end) - (clc:current-form-position) - (wire:remote *compiler-wire* - (lisp-error *compiler-note* start end - (format nil "~A~&" condition)))))) - - - - -;;; SERVER-COMPILE-TEXT -- Public. -;;; -;;; Similar to server-eval-text, except that the stuff is compiled. -;;; -(defun server-compile-text (note package text defined-from - terminal-io error-output) - (let ((error-output (if error-output - (wire:remote-object-value error-output)))) - (do-compiler-operation (note package terminal-io error-output) - (with-input-from-string (input-stream text) - (terpri error-output) - (compile-from-stream input-stream - :error-stream error-output - :defined-from-pathname defined-from))))) - -;;; SERVER-COMPILE-FILE -- Public. -;;; -;;; Compiles the file sending error info back to the editor. -;;; -(defun server-compile-file (note package input output error lap - load terminal background) - (macrolet ((frob (x) - `(if (wire:remote-object-p ,x) - (wire:remote-object-value ,x) - ,x))) - (let ((error-stream (frob background))) - (do-compiler-operation (note package terminal error-stream) - (compile-file (frob input) - :output-file (frob output) - :error-file (frob error) - :lap-file (frob lap) - :load load - :errors-to-terminal error-stream))))) - - -;;;; Other random eval server stuff. - -;;; MAYBE-MAKE-PACKAGE -- Internal. -;;; -;;; Returns a package for a name. Creates it if it doesn't already exist. -;;; -(defun maybe-make-package (name) - (cond ((null name) *package*) - ((find-package name)) - (t - (wire:remote-value (ts-stream-wire *terminal-io*) - (ts-buffer-output-string - (ts-stream-typescript *terminal-io*) - (format nil "~&Creating package ~A.~%" name) - t)) - (make-package name)))) - -;;; SERVER-SET-PACKAGE -- Public. -;;; -;;; Serves package setting requests. It simply sets -;;; *package* to an already existing package or newly created one. -;;; -(defun server-set-package (package) - (setf *package* (maybe-make-package package))) - -;;; SERVER-ACCEPT-OPERATIONS -- Public. -;;; -;;; Start accepting operations again. -;;; -(defun server-accept-operations () - (setf *abort-operations* nil)) - - - -;;;; Command line switches. - -;;; FIND-EVAL-SERVER-SWITCH -- Internal. -;;; -;;; This is special to the switches supplied by CREATE-SLAVE and fetched by -;;; CONNECT-EDITOR-SERVER, so we can use STRING=. -;;; -(defun find-eval-server-switch (string) - (let ((switch (find string ext:*command-line-switches* - :test #'string= - :key #'ext:cmd-switch-name))) - (if switch - (or (ext:cmd-switch-value switch) - (car (ext:cmd-switch-words switch)))))) - - -(defun slave-switch-demon (switch) - (let ((editor (ext:cmd-switch-arg switch))) - (unless editor - (error "Editor to connect to unspesified.")) - (start-slave editor))) -;;; -(defswitch "slave" 'slave-switch-demon) -(defswitch "slave-buffer") -(defswitch "background-buffer") - - -(defun edit-switch-demon (switch) - (declare (ignore switch)) -#| (let ((arg (or (ext:cmd-switch-value switch) - (car (ext:cmd-switch-words switch))))) - (when (stringp arg) (setq *editor-name* arg)))|# - (let ((initp (not (ext:get-command-line-switch "noinit")))) - (if (stringp (car ext:*command-line-words*)) - (ed (car ext:*command-line-words*) :init initp) - (ed nil :init initp)))) -;;; -(defswitch "edit" 'edit-switch-demon) diff --git a/hemlock/filecoms.lisp b/hemlock/filecoms.lisp deleted file mode 100644 index 443c9c0895c7e36258e2569ac414acf4b6f05656..0000000000000000000000000000000000000000 --- a/hemlock/filecoms.lisp +++ /dev/null @@ -1,1039 +0,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.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). -;;; ********************************************************************** -;;; -;;; This file contains file/buffer manipulating commands. -;;; -(in-package "HEMLOCK") - - - -;;;; PROCESS-FILE-OPTIONS. - -(defvar *mode-option-handlers* () - "Do not modify this; use Define-File-Option instead.") - -(defvar *file-type-hooks* () - "Do not modify this; use Define-File-Type-Hook instead.") - -(defun trim-subseq (string start end) - (declare (simple-string string)) - (string-trim '(#\Space #\Tab) (subseq string start end))) - -;;; PROCESS-FILE-OPTIONS checks the first line of buffer for the file options -;;; indicator "-*-". IF it finds this, then it enters a do-file-options block. -;;; If any parsing errors occur while picking out options, we return from this -;;; block. Staying inside this function at this point, allows us to still set -;;; a major mode if no file option specified one. -;;; -;;; We also cater to old style mode comments: -;;; -*- Lisp -*- -;;; -*- Text -*- -;;; This kicks in if we find no colon on the file options line. -;;; -(defun process-file-options (buffer &optional - (pathname (buffer-pathname buffer))) - "Checks for file options and invokes handlers if there are any. If no - \"Mode\" mode option is specified, then this tries to invoke the appropriate - file type hook." - (let* ((string - (line-string (mark-line (buffer-start-mark buffer)))) - (found (search "-*-" string)) - (no-major-mode t) - (type (if pathname (pathname-type pathname)))) - (declare (simple-string string)) - (when found - (block do-file-options - (let* ((start (+ found 3)) - (end (search "-*-" string :start2 start))) - (unless end - (loud-message "No closing \"-*-\". Aborting file options.") - (return-from do-file-options)) - (cond - ((find #\: string :start start :end end) - (do ((opt-start start (1+ semi)) colon semi) - (nil) - (setq colon (position #\: string :start opt-start :end end)) - (unless colon - (loud-message "Missing \":\". Aborting file options.") - (return-from do-file-options)) - (setq semi (or (position #\; string :start colon :end end) end)) - (let* ((option (nstring-downcase - (trim-subseq string opt-start colon))) - (handler (assoc option *mode-option-handlers* - :test #'string=))) - (declare (simple-string option)) - (cond - (handler - (let ((result (funcall (cdr handler) buffer - (trim-subseq string (1+ colon) semi)))) - (when (string= option "mode") - (setq no-major-mode (not result))))) - (t (message "Unknown file option: ~S" option))) - (when (= semi end) (return nil))))) - (t - ;; Old style mode comment. - (setq no-major-mode nil) - (funcall (cdr (assoc "mode" *mode-option-handlers* :test #'string=)) - buffer (trim-subseq string start end))))))) - (when (and no-major-mode type) - (let ((hook (assoc (string-downcase type) *file-type-hooks* - :test #'string=))) - (when hook (funcall (cdr hook) buffer type)))))) - - - -;;;; File options and file type hooks. - -(defmacro define-file-option (name lambda-list &body body) - "Define-File-Option Name (Buffer Value) {Form}* - Defines a new file option to be user in the -*- line at the top of a file. - The body is evaluated with Buffer bound to the buffer the file has been read - into and Value to the string argument to the option." - (let ((name (string-downcase name))) - `(setf (cdr (or (assoc ,name *mode-option-handlers* :test #'string=) - (car (push (cons ,name nil) *mode-option-handlers*)))) - #'(lambda ,lambda-list ,@body)))) - -(define-file-option "Mode" (buffer str) - (let ((seen-major-mode-p nil) - (lastpos 0)) - (loop - (let* ((pos (position #\, str :start lastpos)) - (substr (trim-subseq str lastpos pos))) - (cond ((getstring substr *mode-names*) - (cond ((mode-major-p substr) - (when seen-major-mode-p - (loud-message - "Major mode already processed. Using ~S now." - substr)) - (setf seen-major-mode-p t) - (setf (buffer-major-mode buffer) substr)) - (t - (setf (buffer-minor-mode buffer substr) t)))) - (t - (loud-message "~S is not a defined mode -- ignored." substr))) - (unless pos - (return seen-major-mode-p)) - (setf lastpos (1+ pos)))))) - - -(defmacro define-file-type-hook (type-list (buffer type) &body body) - "Define-File-Type-Hook ({Type}*) (Buffer Type) {Form}* - Define some code to be evaluated when a file having one of the specified - Types is read by a file command. Buffer is bound to the buffer the - file is in, and Type is the actual type read." - (let ((fun (gensym)) (str (gensym))) - `(flet ((,fun (,buffer ,type) ,@body)) - (dolist (,str ',(mapcar #'string-downcase type-list)) - (setf (cdr (or (assoc ,str *file-type-hooks* :test #'string=) - (car (push (cons ,str nil) *file-type-hooks*)))) - #',fun))))) - -(define-file-type-hook ("pas" "pasmac" "macro" "defs" "spc" "bdy") - (buffer type) - (declare (ignore type)) - (setf (buffer-major-mode buffer) "Pascal")) - -(define-file-type-hook ("lisp" "slisp" "l" "lsp" "mcl") (buffer type) - (declare (ignore type)) - (setf (buffer-major-mode buffer) "Lisp")) - -(define-file-type-hook ("txt" "text" "tx") (buffer type) - (declare (ignore type)) - (setf (buffer-major-mode buffer) "Text")) - - - -;;;; Support for file hacking commands: - -(defhvar "Pathname Defaults" - "This variable contains a pathname which is used to supply defaults - when we don't have anything better." - :value (pathname "gazonk.del")) - -(defhvar "Last Resort Pathname Defaults" - "This variable contains a pathname which is used to supply defaults when - we don't have anything better, but unlike \"Pathname Defaults\", this is - never set to some buffer's pathname." - :value (pathname "gazonk")) - -(defhvar "Last Resort Pathname Defaults Function" - "This variable contains a function that is called when a default pathname is - needed, the buffer has no pathname, and the buffer's name is not entirely - composed of alphanumerics. The default value is a function that simply - returns \"Last Resort Pathname Defaults\". The function must take a buffer - as an argument, and it must return some pathname." - :value #'(lambda (buffer) - (declare (ignore buffer)) - (merge-pathnames (value last-resort-pathname-defaults) - (value pathname-defaults)))) - -(defun buffer-default-pathname (buffer) - "Returns \"Buffer Pathname\" if it is bound. If it is not, and buffer's name - is composed solely of alphnumeric characters, then return a pathname formed - from the buffer's name. If the buffer's name has other characters in it, - then return the value of \"Last Resort Pathname Defaults Function\" called - on buffer." - (or (buffer-pathname buffer) - (if (every #'alphanumericp (the simple-string (buffer-name buffer))) - (merge-pathnames (make-pathname :name (buffer-name buffer)) - (value pathname-defaults)) - (funcall (value last-resort-pathname-defaults-function) buffer)))) - - -(defun pathname-to-buffer-name (pathname) - "Returns a simple-string using components from pathname." - (let ((pathname (pathname pathname))) - (concatenate 'simple-string - (file-namestring pathname) - " " - (directory-namestring pathname)))) - - - -;;;; File hacking commands. - -(defcommand "Process File Options" (p) - "Reprocess this buffer's file options." - "Reprocess this buffer's file options." - (declare (ignore p)) - (process-file-options (current-buffer))) - -(defcommand "Insert File" (p &optional pathname (buffer (current-buffer))) - "Inserts a file which is prompted for into the current buffer at the point. - The prefix argument is ignored." - "Inserts the file named by Pathname into Buffer at the point." - (declare (ignore p)) - (let* ((pn (or pathname - (prompt-for-file :default (buffer-default-pathname buffer) - :prompt "Insert File: " - :help "Name of file to insert"))) - (point (buffer-point buffer)) - ;; start and end will be deleted by undo stuff - (start (copy-mark point :right-inserting)) - (end (copy-mark point :left-inserting)) - (region (region start end))) - (setv pathname-defaults pn) - (push-buffer-mark (copy-mark end)) - (read-file pn end) - (make-region-undo :delete "Insert File" region))) - -(defcommand "Write Region" (p &optional pathname) - "Writes the current region to a file. " - "Writes the current region to a file. " - (declare (ignore p)) - (let ((region (current-region)) - (pn (or pathname - (prompt-for-file :prompt "File to Write: " - :help "The name of the file to write the region to. " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil)))) - (write-file region pn) - (message "~A written." (namestring (truename pn))))) - - - -;;;; Visiting and reverting files. - -(defcommand "Visit File" (p &optional pathname (buffer (current-buffer))) - "Replaces the contents of Buffer with the file Pathname. The prefix - argument is ignored. The buffer is set to be writable, so its region - can be deleted." - "Replaces the contents of the current buffer with the text in the file - which is prompted for. The prefix argument is, of course, ignored p times." - (declare (ignore p)) - (when (and (buffer-modified buffer) - (prompt-for-y-or-n :prompt "Buffer is modified, save it? ")) - (save-file-command () buffer)) - (let ((pn (or pathname - (prompt-for-file :prompt "Visit File: " - :must-exist nil - :help "Name of file to visit." - :default (buffer-default-pathname buffer))))) - (setf (buffer-writable buffer) t) - (read-buffer-file pn buffer) - (let ((n (pathname-to-buffer-name (buffer-pathname buffer)))) - (unless (getstring n *buffer-names*) - (setf (buffer-name buffer) n)) - (warn-about-visit-file-buffers buffer)))) - -(defun warn-about-visit-file-buffers (buffer) - (let ((buffer-pn (buffer-pathname buffer))) - (dolist (b *buffer-list*) - (unless (eq b buffer) - (let ((bpn (buffer-pathname b))) - (when (equal bpn buffer-pn) - (message "Buffer ~A also contains ~A." - (buffer-name b) (namestring buffer-pn)) - (return))))))) - - -(defhvar "Revert File Confirm" - "If this is true, Revert File will prompt before reverting." - :value t) - -(defcommand "Revert File" (p) - "Unless in Save Mode, reads in the last saved version of the file in - the current buffer. When in Save Mode, reads in the last checkpoint or - the last saved version, whichever is more recent. An argument will always - force Revert File to use the last saved version. In either case, if the - buffer has been modified and \"Revert File Confirm\" is true, then Revert - File will ask for confirmation beforehand. An attempt is made to maintain - the point's relative position." - "With an argument reverts to the last saved version of the file in the - current buffer. Without, reverts to the last checkpoint or last saved - version, whichever is more recent." - (let* ((buffer (current-buffer)) - (buffer-pn (buffer-pathname buffer)) - (point (current-point)) - (lines (1- (count-lines (region (buffer-start-mark buffer) point))))) - (multiple-value-bind (revert-pn used-checkpoint) - (if p buffer-pn (revert-pathname buffer)) - (unless revert-pn - (editor-error "No file associated with buffer to revert to!")) - (when (or (not (value revert-file-confirm)) - (not (buffer-modified buffer)) - (prompt-for-y-or-n - :prompt - "Buffer contains changes, are you sure you want to revert? " - :help (list - "Reverting the file will undo any changes by reading in the last ~ - ~:[saved version~;checkpoint file~]." used-checkpoint) - :default t)) - (read-buffer-file revert-pn buffer) - (when used-checkpoint - (setf (buffer-modified buffer) t) - (setf (buffer-pathname buffer) buffer-pn) - (message "Reverted to checkpoint file ~A." (namestring revert-pn))) - (unless (line-offset point lines) - (buffer-end point)))))) - -;;; REVERT-PATHNAME -- Internal -;;; -;;; If in Save Mode, return either the checkpoint pathname or the buffer -;;; pathname whichever is more recent. Otherwise return the buffer-pathname -;;; if it exists. If neither file exists, return NIL. -;;; -(defun revert-pathname (buffer) - (let* ((buffer-pn (buffer-pathname buffer)) - (buffer-pn-date (file-write-date buffer-pn)) - (checkpoint-pn (get-checkpoint-pathname buffer)) - (checkpoint-pn-date (file-write-date checkpoint-pn))) - (cond (checkpoint-pn-date - (if (> checkpoint-pn-date (or buffer-pn-date 0)) - (values checkpoint-pn t) - (values buffer-pn nil))) - (buffer-pn-date (values buffer-pn nil)) - (t (values nil nil))))) - - - -;;;; Find file. - -(defcommand "Find File" (p &optional pathname) - "Visit a file in its own buffer. - If the file is already in some buffer, select that buffer, - otherwise make a new buffer with the same name as the file and - read the file into it." - "Make a buffer containing the file Pathname current, creating a buffer - if necessary. The buffer is returned." - (declare (ignore p)) - (let* ((pn (or pathname - (prompt-for-file - :prompt "Find File: " - :must-exist nil - :help "Name of file to read into its own buffer." - :default (buffer-default-pathname (current-buffer))))) - (buffer (find-file-buffer pn))) - (change-to-buffer buffer) - buffer)) - -(defun find-file-buffer (pathname) - "Return a buffer assoicated with the file Pathname, reading the file into a - new buffer if necessary. The second value is T if we created a buffer, NIL - otherwise. If the file has already been read, we check to see if the file - has been modified on disk since it was read, giving the user various - recovery options." - (let* ((pathname (pathname pathname)) - (trial-pathname (or (probe-file pathname) - (merge-pathnames pathname (default-directory)))) - (found (find trial-pathname (the list *buffer-list*) - :key #'buffer-pathname :test #'equal))) - (cond ((not found) - (let* ((name (pathname-to-buffer-name trial-pathname)) - (buffer (getstring name *buffer-names*)) - (use (if buffer - (prompt-for-buffer - :prompt "Buffer to use: " - :help - "Buffer name in use; give another buffer name, or confirm to reuse." - :default buffer :must-exist nil) - (make-buffer name))) - (buffer (if (stringp use) (make-buffer use) use))) - (when (and (buffer-modified buffer) - (prompt-for-y-or-n :prompt - "Buffer is modified, save it? ")) - (save-file-command () buffer)) - (read-buffer-file pathname buffer) - (values buffer (stringp use)))) - ((check-disk-version-consistent pathname found) - (values found nil)) - (t - (read-buffer-file pathname found) - (values found nil))))) - -;;; Check-Disk-Version-Consistent -- Internal -;;; -;;; Check that Buffer contains a valid version of the file Pathname, -;;; harrassing the user if not. We return true if the buffer is O.K., and -;;; false if the file should be read. -;;; -(defun check-disk-version-consistent (pathname buffer) - (let ((ndate (file-write-date pathname)) - (odate (buffer-write-date buffer))) - (cond ((not (and ndate odate (/= ndate odate))) - t) - ((buffer-modified buffer) - (beep) - (clear-input) - (command-case (:prompt (list - "File has been changed on disk since it was read and you have made changes too!~ - ~%Read in the disk version of ~A? [Y] " (namestring pathname)) - :help - "The file in disk has been changed since Hemlock last saved it, meaning that - someone else has probably overwritten it. Since the version read into Hemlock - has been changed as well, the two versions may have inconsistent changes. If - this is the case, it would be a good idea to save your changes in another file - and compare the two versions. - - Type one of the following commands:") - ((:confirm :yes) - "Prompt for a file to write the buffer out to, then read in the disk version." - (write-buffer-file - buffer - (prompt-for-file - :prompt "File to save changes in: " - :help (list "Save buffer ~S to this file before reading ~A." - (buffer-name buffer) (namestring pathname)) - :must-exist nil - :default (buffer-default-pathname buffer))) - nil) - (:no - "Change to the buffer without reading the new version." - t) - (#\R - "Read in the new version, clobbering the changes in the buffer." - nil))) - (t - (not (prompt-for-yes-or-no :prompt - (list - "File has been changed on disk since it was read.~ - ~%Read in the disk version of ~A? " - (namestring pathname)) - :help - "Type Y to read in the new version or N to just switch to the buffer." - :default t)))))) - - -(defhvar "Read File Hook" - "These functions are called when a file is read into a buffer. Each function - must take two arguments -- the buffer the file was read into and whether the - file existed (non-nil) or not (nil).") - -(defun read-buffer-file (pathname buffer) - "Delete the buffer's region, and uses READ-FILE to read pathname into it. - If the file exists, set the buffer's write date to the file's; otherwise, - MESSAGE that this is a new file and set the buffer's write date to nil. - Move buffer's point to the beginning, set the buffer unmodified. If the - file exists, set the buffer's pathname to the probed pathname; else, set it - to pathname merged with DEFAULT-DIRECTORY. Set \"Pathname Defaults\" to the - same thing. Process the file options, and then invoke \"Read File Hook\"." - (delete-region (buffer-region buffer)) - (let* ((pathname (pathname pathname)) - (probed-pathname (probe-file pathname))) - (cond (probed-pathname - (read-file probed-pathname (buffer-point buffer)) - (setf (buffer-write-date buffer) (file-write-date probed-pathname))) - (t - (message "(New File)") - (setf (buffer-write-date buffer) nil))) - (buffer-start (buffer-point buffer)) - (setf (buffer-modified buffer) nil) - (let ((stored-pathname (or probed-pathname - (merge-pathnames pathname (default-directory))))) - (setf (buffer-pathname buffer) stored-pathname) - (setf (value pathname-defaults) stored-pathname) - (process-file-options buffer stored-pathname) - (invoke-hook read-file-hook buffer probed-pathname)))) - - - -;;;; File writing. - -(defhvar "Add Newline at EOF on Writing File" - "This controls whether WRITE-BUFFER-FILE adds a newline at the end of the - file when it ends at the end of a non-empty line. When set, this may be - :ask-user and WRITE-BUFFER-FILE will prompt; otherwise, just add one and - inform the user. When nil, never add one and don't ask." - :value :ask-user) - -(defhvar "Keep Backup Files" - "When set, .BAK files will be saved upon file writing. This defaults to nil." - :value nil) - -(defhvar "Write File Hook" - "These functions are called when a buffer has been written. Each function - must take the buffer as an argument.") - -(defun write-buffer-file (buffer pathname) - "Write's buffer to pathname. This assumes pathname is somehow related to - the buffer's pathname, and if the buffer's write date is not the same as - pathname's, then this prompts the user for confirmation before overwriting - the file. This consults \"Add Newline at EOF on Writing File\" and - interacts with the user if necessary. This sets \"Pathname Defaults\", and - the buffer is marked unmodified. The buffer's pathname and write date are - updated, and the buffer is renamed according to the new pathname if possible. - This invokes \"Write File Hook\"." - (let ((buffer-pn (buffer-pathname buffer))) - (let ((date (buffer-write-date buffer)) - (file-date (when (probe-file pathname) (file-write-date pathname)))) - (when (and buffer-pn date file-date - (equal (make-pathname :version nil :defaults buffer-pn) - (make-pathname :version nil :defaults pathname)) - (/= date file-date)) - (unless (prompt-for-yes-or-no :prompt (list - "File has been changed on disk since it was read.~%Overwrite ~A anyway? " - (namestring buffer-pn)) - :help - "Type No to abort writing the file or Yes to overwrite the disk version." - :default nil) - (editor-error "Write aborted.")))) - (let ((val (value add-newline-at-eof-on-writing-file))) - (when val - (let ((end (buffer-end-mark buffer))) - (unless (start-line-p end) - (when (if (eq val :ask-user) - (prompt-for-y-or-n - :prompt - (list "~A~%File does not have a newline at EOF, add one? " - (buffer-name buffer)) - :default t) - t) - (insert-character end #\newline) - (message "Added newline at EOF.")))))) - (setv pathname-defaults pathname) - (write-file (buffer-region buffer) pathname) - (let ((tn (truename pathname))) - (message "~A written." (namestring tn)) - (setf (buffer-modified buffer) nil) - (unless (equal tn buffer-pn) - (setf (buffer-pathname buffer) tn)) - (setf (buffer-write-date buffer) (file-write-date tn)) - (let ((name (pathname-to-buffer-name tn))) - (unless (getstring name *buffer-names*) - (setf (buffer-name buffer) name))))) - (invoke-hook write-file-hook buffer)) - -(defcommand "Write File" (p &optional pathname (buffer (current-buffer))) - "Writes the contents of Buffer, which defaults to the current buffer to - the file named by Pathname. The prefix argument is ignored." - "Prompts for a file to write the contents of the current Buffer to. - The prefix argument is ignored." - (declare (ignore p)) - (write-buffer-file - buffer - (or pathname - (prompt-for-file :prompt "Write File: " - :must-exist nil - :help "Name of file to write to" - :default (buffer-default-pathname buffer))))) - -(defcommand "Save File" (p &optional (buffer (current-buffer))) - "Writes the contents of the current buffer to the associated file. If there - is no associated file, once is prompted for." - "Writes the contents of the current buffer to the associated file." - (declare (ignore p)) - (when (or (buffer-modified buffer) - (prompt-for-y-or-n - :prompt "Buffer is unmodified, write it anyway? " - :default t)) - (write-buffer-file - buffer - (or (buffer-pathname buffer) - (prompt-for-file :prompt "Save File: " - :help "Name of file to write to" - :default (buffer-default-pathname buffer) - :must-exist nil))))) - -(defhvar "Save All Files Confirm" - "When non-nil, prompts for confirmation before writing each modified buffer." - :value t) - -(defcommand "Save All Files" (p) - "Saves all modified buffers in their associated files. - If a buffer has no associated file it is ignored even if it is modified.." - "Saves each modified buffer that has a file." - (declare (ignore p)) - (let ((saved-count 0)) - (dolist (b *buffer-list*) - (let ((pn (buffer-pathname b)) - (name (buffer-name b))) - (when - (and (buffer-modified b) - pn - (or (not (value save-all-files-confirm)) - (prompt-for-y-or-n - :prompt (list - "Write ~:[buffer ~A as file ~S~;file ~*~S~], ~ - Y or N: " - (string= (pathname-to-buffer-name pn) name) - name (namestring pn)) - :default t))) - (write-buffer-file b pn) - (incf saved-count)))) - (if (zerop saved-count) - (message "No files were saved.") - (message "Saved ~S file~:P." saved-count)))) - -(defcommand "Save All Files and Exit" (p) - "Save all modified buffers in their associated files and exit; - a combination of \"Save All Files\" and \"Exit Hemlock\"." - "Do a save-all-files-command and then an exit-hemlock." - (declare (ignore p)) - (save-all-files-command ()) - (exit-hemlock)) - -(defcommand "Backup File" (p) - "Write the buffer to a file without changing the associated name." - "Write the buffer to a file without changing the associated name." - (declare (ignore p)) - (let ((file (prompt-for-file :prompt "Backup to File: " - :help - "Name of a file to backup the current buffer in." - :default (buffer-default-pathname (current-buffer)) - :must-exist nil))) - (write-file (buffer-region (current-buffer)) file) - (message "~A written." (namestring (truename file))))) - - - -;;;; Buffer hacking commands: - -(defvar *buffer-history* () - "A list of buffers, in order from most recently to least recently selected.") - -(defun previous-buffer () - "Returns some previously selected buffer that is not the current buffer. - Returns nil if no such buffer exists." - (let ((b (car *buffer-history*))) - (or (if (eq b (current-buffer)) (cadr *buffer-history*) b) - (find-if-not #'(lambda (x) - (or (eq x (current-buffer)) - (eq x *echo-area-buffer*))) - (the list *buffer-list*))))) - -;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by -;;; "Circulate Buffers" even if it has never been before. -;;; -(defun add-buffer-history-hook (buffer) - (let ((ele (last *buffer-history*)) - (new-stuff (list buffer))) - (if ele - (setf (cdr ele) new-stuff) - (setf *buffer-history* new-stuff)))) -;;; -(add-hook make-buffer-hook 'add-buffer-history-hook) - -;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer. -;;; -(defun delete-buffer-history-hook (buffer) - (setq *buffer-history* (delq buffer *buffer-history*))) -;;; -(add-hook delete-buffer-hook 'delete-buffer-history-hook) - -(defun change-to-buffer (buffer) - "Switches to buffer in the current window maintaining *buffer-history*." - (setq *buffer-history* - (cons (current-buffer) (delq (current-buffer) *buffer-history*))) - (setf (current-buffer) buffer) - (setf (window-buffer (current-window)) buffer)) - -(defun delete-buffer-if-possible (buffer) - "Deletes a buffer if at all possible. If buffer is the only buffer, other - than the echo area, signals an error. Otherwise, find some recently current - buffer, and make all of buffer's windows display this recent buffer. If - buffer is current, set the current buffer to be this recently current - buffer." - (let ((new-buf (flet ((frob (b) - (or (eq b buffer) (eq b *echo-area-buffer*)))) - (or (find-if-not #'frob (the list *buffer-history*)) - (find-if-not #'frob (the list *buffer-list*)))))) - (unless new-buf - (error "Cannot delete only buffer ~S." buffer)) - (dolist (w (buffer-windows buffer)) - (setf (window-buffer w) new-buf)) - (when (eq buffer (current-buffer)) - (setf (current-buffer) new-buf))) - (delete-buffer buffer)) - - -(defvar *create-buffer-count* 0) - -(defcommand "Create Buffer" (p &optional buffer-name) - "Create a new buffer. If a buffer with the specified name already exists, - then go to it." - "Create or go to the buffer with the specifed name." - (declare (ignore p)) - (let ((name (or buffer-name - (prompt-for-buffer :prompt "Create Buffer: " - :default-string - (format nil "Buffer ~D" - (incf *create-buffer-count*)) - :must-exist nil)))) - (if (bufferp name) - (change-to-buffer name) - (change-to-buffer (or (getstring name *buffer-names*) - (make-buffer name)))))) - -(defcommand "Select Buffer" (p) - "Select a different buffer. - The buffer to go to is prompted for." - "Select a different buffer. - The buffer to go to is prompted for." - (declare (ignore p)) - (let ((buf (prompt-for-buffer :prompt "Select Buffer: " - :default (previous-buffer)))) - (when (eq buf *echo-area-buffer*) - (editor-error "Cannot select Echo Area buffer.")) - (change-to-buffer buf))) - - -(defvar *buffer-history-ptr* () - "The successively previous buffer to the current buffer.") - -(defcommand "Select Previous Buffer" (p) - "Select the buffer selected before this one. If called repeatedly - with an argument, select the successively previous buffer to the - current one leaving the buffer history as it is." - "Select the buffer selected before this one." - (if p - (circulate-buffers-command nil) - (let ((b (previous-buffer))) - (unless b (editor-error "No previous buffer.")) - (change-to-buffer b) - ;; - ;; If the pointer goes to nil, then "Circulate Buffers" will keep doing - ;; "Select Previous Buffer". - (setf *buffer-history-ptr* (cddr *buffer-history*)) - (setf (last-command-type) :previous-buffer)))) - -(defcommand "Circulate Buffers" (p) - "Advance through buffer history, selecting successively previous buffer." - "Advance through buffer history, selecting successively previous buffer." - (declare (ignore p)) - (if (and (eq (last-command-type) :previous-buffer) - *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER. - (let ((b (pop *buffer-history-ptr*))) - (when (eq b (current-buffer)) - (setf b (pop *buffer-history-ptr*))) - (unless b - (setf *buffer-history-ptr* - (or (cdr *buffer-history*) *buffer-history*)) - (setf b (car *buffer-history*))) - (setf (current-buffer) b) - (setf (window-buffer (current-window)) b) - (setf (last-command-type) :previous-buffer)) - (select-previous-buffer-command nil))) - - -(defcommand "Buffer Not Modified" (p) - "Make the current buffer not modified." - "Make the current buffer not modified." - (declare (ignore p)) - (setf (buffer-modified (current-buffer)) nil) - (message "Buffer marked as unmodified.")) - -(defcommand "Check Buffer Modified" (p) - "Say whether the buffer is modified or not." - "Say whether the current buffer is modified or not." - (declare (ignore p)) - (clear-echo-area) - (message "Buffer ~S ~:[is not~;is~] modified." - (buffer-name (current-buffer)) (buffer-modified (current-buffer)))) - -(defcommand "Set Buffer Read-Only" (p) - "Toggles the read-only flag for the current buffer." - "Toggles the read-only flag for the current buffer." - (declare (ignore p)) - (let ((buffer (current-buffer))) - (message "Buffer ~S is now ~:[read-only~;writable~]." - (buffer-name buffer) - (setf (buffer-writable buffer) (not (buffer-writable buffer)))))) - -(defcommand "Kill Buffer" (p &optional buffer-name) - "Prompts for a buffer to delete. - If the buffer is modified, then let the user save the file before doing so. - When deleting the current buffer, prompts for a new buffer to select. If - a buffer other than the current one is deleted then any windows into it - are deleted." - "Delete buffer Buffer-Name, doing sensible things if the buffer is displayed - or current." - (declare (ignore p)) - (let ((buffer (if buffer-name - (getstring buffer-name *buffer-names*) - (prompt-for-buffer :prompt "Kill Buffer: " - :default (current-buffer))))) - (if (not buffer) - (editor-error "No buffer named ~S" buffer-name)) - (if (and (buffer-modified buffer) - (prompt-for-y-or-n :prompt "Save it first? ")) - (save-file-command () buffer)) - (if (eq buffer (current-buffer)) - (let ((new (prompt-for-buffer :prompt "New Buffer: " - :default (previous-buffer) - :help "Buffer to change to after the current one is killed."))) - (when (eq new buffer) - (editor-error "You must select a different buffer.")) - (dolist (w (buffer-windows buffer)) - (setf (window-buffer w) new)) - (setf (current-buffer) new)) - (dolist (w (buffer-windows buffer)) - (delete-window w))) - (delete-buffer buffer))) - -(defcommand "Rename Buffer" (p) - "Change the current buffer's name. - The name, which is prompted for, defaults to the name of the associated - file." - "Change the name of the current buffer." - (declare (ignore p)) - (let* ((buf (current-buffer)) - (pn (buffer-pathname buf)) - (name (if pn (pathname-to-buffer-name pn) (buffer-name buf))) - (new (prompt-for-string :prompt "New Name: " - :help "Give a new name for the current buffer" - :default name))) - (multiple-value-bind (entry foundp) (getstring new *buffer-names*) - (cond ((or (not foundp) (eq entry buf)) - (setf (buffer-name buf) new)) - (t (editor-error "Name ~S already in use." new)))))) - - -(defcommand "Insert Buffer" (p) - "Insert the contents of a buffer. - The name of the buffer to insert is prompted for." - "Prompt for a buffer to insert at the point." - (declare (ignore p)) - (let ((point (current-point)) - (region (buffer-region (prompt-for-buffer - :default (previous-buffer) - :help - "Type the name of a buffer to insert.")))) - ;; - ;; start and end will be deleted by undo stuff - (let ((save (region (copy-mark point :right-inserting) - (copy-mark point :left-inserting)))) - (push-buffer-mark (copy-mark point)) - (insert-region point region) - (make-region-undo :delete "Insert Buffer" save)))) - - - -;;;; File utility commands: - -(defcommand "Directory" (p) - "Do a directory into a pop-up window. If an argument is supplied, then - dot files are listed too (as with ls -a). Prompts for a pathname which - may contain wildcards in the name and type." - "Do a directory into a pop-up window." - (let* ((dpn (value pathname-defaults)) - (pn (prompt-for-file - :prompt "Directory: " - :help "Pathname to do directory on." - :default (make-pathname :device (pathname-device dpn) - :directory (pathname-directory dpn)) - :must-exist nil))) - (setf (value pathname-defaults) (merge-pathnames pn dpn)) - (with-pop-up-display (s) - (print-directory pn s :all p)))) - -(defcommand "Verbose Directory" (p) - "Do a directory into a pop-up window. If an argument is supplied, then - dot files are listed too (as with ls -a). Prompts for a pathname which - may contain wildcards in the name and type." - "Do a directory into a pop-up window." - (let* ((dpn (value pathname-defaults)) - (pn (prompt-for-file - :prompt "Verbose Directory: " - :help "Pathname to do directory on." - :default (make-pathname :device (pathname-device dpn) - :directory (pathname-directory dpn)) - :must-exist nil))) - (setf (value pathname-defaults) (merge-pathnames pn dpn)) - (with-pop-up-display (s) - (print-directory pn s :verbose t :all p)))) - - - -;;;; Change log stuff: - -(define-file-option "Log" (buffer value) - (defhvar "Log File Name" - "The name of the file for the change log for the file in this buffer." - :buffer buffer :value value)) - -(defhvar "Log Entry Template" - "The format string used to generate the template for a change-log entry. - Three arguments are given: the file, the date (create if available, now - otherwise) and the file author, or NIL if not available. The last \"@\" - is deleted and the point placed where it was." - :value "~A, ~A, Edit by ~:[???~;~:*~:(~A~)~].~% @~2%") - -(defmode "Log" - :major-p t - :setup-function - #'(lambda (buffer) - (setf (buffer-minor-mode buffer "Fill") t)) - :cleanup-function - #'(lambda (buffer) - (setf (buffer-minor-mode buffer "Fill") nil))) - -(defhvar "Fill Prefix" "The fill prefix in Log mode." - :value " " :mode "Log") - -(define-file-type-hook ("log") (buffer type) - (declare (ignore type)) - (setf (buffer-major-mode buffer) "Log")) - -(defun universal-time-to-string (ut) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time ut) - (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~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))) - -(defvar *back-to-@-pattern* (new-search-pattern :character :backward #\@)) -(defcommand "Log Change" (p) - "Make an entry in the change-log file for this buffer. - Saves the file in the current buffer if it is modified, then finds the file - specified in the \"Log\" file option, adds the template for a change-log - entry at the beginning, then does a recursive edit, saving the log file on - exit." - "Find the change-log file as specified by \"Log File Name\" and edit it." - (declare (ignore p)) - (unless (hemlock-bound-p 'log-file-name) - (editor-error "No log file defined.")) - (let* ((buffer (current-buffer)) - (pathname (buffer-pathname buffer))) - (when (or (buffer-modified buffer) (null pathname)) - (save-file-command ())) - (unwind-protect - (progn - (find-file-command nil (merge-pathnames - (value log-file-name) - (buffer-default-pathname buffer))) - (let ((point (current-point))) - (buffer-start point) - (with-output-to-mark (s point :full) - (format s (value log-entry-template) - (namestring pathname) - (universal-time-to-string - (or (file-write-date pathname) - (get-universal-time))) - (file-author pathname))) - (when (find-pattern point *back-to-@-pattern*) - (delete-characters point 1))) - (do-recursive-edit) - (when (buffer-modified (current-buffer)) (save-file-command ()))) - (if (member buffer *buffer-list* :test #'eq) - (change-to-buffer buffer) - (editor-error "Old buffer has been deleted."))))) - - - -;;;; Window hacking commands: - -(defcommand "Next Window" (p) - "Change the current window to be the next window and the current buffer - to be it's buffer." - "Go to the next window. - If the next window is the bottom window then wrap around to the top window." - (declare (ignore p)) - (let* ((next (next-window (current-window))) - (buffer (window-buffer next))) - (setf (current-buffer) buffer (current-window) next))) - -(defcommand "Previous Window" (p) - "Change the current window to be the previous window and the current buffer - to be it's buffer." - "Go to the previous window. - If the Previous window is the top window then wrap around to the bottom." - (declare (ignore p)) - (let* ((previous (previous-window (current-window))) - (buffer (window-buffer previous))) - (setf (current-buffer) buffer (current-window) previous))) - -(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))) - -(defcommand "New Window" (p) - "Make a new window and go to it. - The window will display the same buffer as the current one." - "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)) - :ask-user t))) - (unless new (editor-error "Could not make a new window.")) - (setf (current-window) new))) - -(defcommand "Delete Window" (p) - "Delete the current window, going to the previous window." - "Delete the window we are in, going to the previous window." - (declare (ignore p)) - (let ((window (current-window))) - (previous-window-command ()) - (when (eq (current-window) window) - (editor-error "Cannot delete current window.")) - (delete-window window))) - -(defcommand "Line to Top of Window" (p) - "Move current line to top of window." - "Move current line to top of window." - (declare (ignore p)) - (with-mark ((mark (current-point))) - (move-mark (window-display-start (current-window)) (line-start mark)))) - -(defcommand "Delete Next Window" (p) - "Deletes the next window on display." - "Deletes then next window on display." - (declare (ignore p)) - (if (eq (next-window (current-window)) - (current-window)) - (editor-error "Cannot delete only window") - (delete-window (next-window (current-window))))) - -(defcommand "Line to Center of Window" (p) - "Moves current line to the center of the window." - "Moves current line to the center of the window." - (declare (ignore p)) - (center-window (current-window) (current-point))) diff --git a/hemlock/files.lisp b/hemlock/files.lisp deleted file mode 100644 index 1c94de5aa0405f9ca7d780b9b756d887e722b3fe..0000000000000000000000000000000000000000 --- a/hemlock/files.lisp +++ /dev/null @@ -1,200 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock File manipulation functions. -;;; Written by Skef Wholey, Horribly Hacked by Rob MacLachlan. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(read-file write-file)) - - - -;;; Read-File: - -(defun read-file (pathname mark) - "Inserts the contents of the file named by Pathname at the Mark." - (with-mark ((mark mark :left-inserting)) - (let* ((tn (truename pathname)) - (name (namestring tn)) - (alien ()) - (size 0)) - (declare (fixnum size)) - (multiple-value-bind (fd err) (mach:unix-open name mach:o_rdonly 0) - (if (not (null fd)) - (multiple-value-bind (res dev ino mode nlnk uid gid rdev len) - (mach:unix-fstat fd) - (declare (ignore ino mode nlnk uid gid rdev)) - (setq err ()) - (if (null res) - (setq err dev) - (multiple-value-bind (gr addr) - (mach::vm_allocate lisp::*task-self* - 0 len t) - (gr-error 'mach::vm_allocate gr 'read-file) - (setq alien (lisp::fixnum-to-sap addr)) - (setq size len) - (multiple-value-bind - (bytes err3) - (mach:unix-read fd (lisp::fixnum-to-sap addr) len) - (if (or (null bytes) (not (eq len bytes))) - (setq err err3))))) - (mach:unix-close fd))) - (if err (error "Reading file ~A, unix error ~A." - name (mach:get-unix-error-msg err))) - (when (zerop size) (return-from read-file nil)) - (let* ((sap alien) - (first-line (mark-line mark)) - (buffer (line-%buffer first-line)) - (index (%primitive find-character sap 0 size #\newline))) - (modifying-buffer buffer) - (let* ((len (or index size)) - (chars (make-string len))) - (%primitive byte-blt sap 0 chars 0 len) - (insert-string mark chars)) - (when index - (insert-character mark #\newline) - (do* ((old-index (1+ (the fixnum index)) (1+ (the fixnum index))) - (index (%primitive find-character sap old-index size - #\newline) - (%primitive find-character sap old-index size - #\newline)) - (number (+ (line-number first-line) line-increment) - (+ number line-increment)) - (previous first-line)) - ((not index) - (let* ((length (- size old-index)) - (chars (make-string length)) - (line (mark-line mark))) - (declare (fixnum length)) - (%primitive byte-blt sap old-index chars 0 length) - (insert-string mark chars) - (setf (line-next previous) line) - (setf (line-previous line) previous) - (do ((line line (line-next line)) - (number number (+ number line-increment))) - ((null line)) - (declare (fixnum number)) - (setf (line-number line) number)))) - (declare (fixnum number old-index)) - (let ((line (make-line - :previous previous - :%buffer buffer - :number number - :chars (%primitive sap+ sap old-index) - :buffered-p - (the fixnum (- (the fixnum index) old-index))))) - (setf (line-next previous) line) - (setq previous line))) nil)))))) - - -;;; Hackish stuff for disgusting speed: - -(defun read-buffered-line (line) - (let* ((len (line-buffered-p line)) - (chars (make-string len))) - (%primitive byte-blt (line-%chars line) 0 chars 0 len) - (setf (line-buffered-p line) nil) - (setf (line-chars line) chars))) - - - -;;; Write-File: - -(defun write-file (region pathname &key - (keep-backup (value ed::keep-backup-files)) - access) - "Writes the characters in the Region to the file named by Pathname. - Region is written using a stream opened with :if-exists :rename-and-delete, - but keep-backup, when supplied as non-nil, causes :rename to be supplied - instead of :rename-and-delete. Access is an implementation dependent value - that is suitable for setting pathname's access or protection bits." - (let ((if-exists-action (if keep-backup - :rename - :rename-and-delete))) - (with-open-file (file pathname :direction :output :element-type 'string-char - :if-exists if-exists-action) - (close-line) - (fast-write-file region file)) - (when access - (multiple-value-bind - (winp code) - ;; Must do a TRUENAME in case the file has never been written. - ;; It may have Common Lisp syntax that Unix can't handle. - ;; If this is ever moved to the beginning of this function to use - ;; Unix CREAT to create the file protected initially, they TRUENAME - ;; will signal an error, and LISP::PREDICT-NAME will have to be used. - (mach:unix-chmod (namestring (truename pathname)) access) - (unless winp - (error "Could not set access code: ~S" - (mach:get-unix-error-msg code))))))) - -(ext:def-c-variable "vm_page_size" int) - -(defvar *vm-page-size* (system:alien-access vm_page_size) - "Size, in bytes, of each VM page.") - -(defun fast-write-file (region file) - (let* ((start (region-start region)) - (start-line (mark-line start)) - (start-charpos (mark-charpos start)) - (end (region-end region)) - (end-line (mark-line end)) - (end-charpos (mark-charpos end))) - (if (eq start-line end-line) - (write-string (line-chars start-line) file - :start start-charpos :end end-charpos) - (let* ((first-length (- (line-length start-line) start-charpos)) - (length (+ first-length end-charpos 1))) - (do ((line (line-next start-line) (line-next line))) - ((eq line end-line)) - (incf length (1+ (line-length line)))) - (let ((bytes (* *vm-page-size* - (ceiling length *vm-page-size*)))) - (system:gr-bind (address) - (mach:vm_allocate system:*task-self* 0 bytes t) - (unwind-protect - (let ((sap (system:int-sap address))) - (macrolet ((chars (line) - `(if (line-buffered-p ,line) - (line-%chars ,line) - (line-chars ,line)))) - (system:%primitive byte-blt - (chars start-line) start-charpos - sap 0 first-length) - (system:%primitive 8bit-system-set - sap first-length #\newline) - (let ((offset (1+ first-length))) - (do ((line (line-next start-line) - (line-next line))) - ((eq line end-line)) - (let ((end (+ offset (line-length line)))) - (system:%primitive byte-blt - (chars line) 0 - sap offset end) - (system:%primitive 8bit-system-set - sap end #\newline) - (setf offset (1+ end)))) - (unless (zerop end-charpos) - (system:%primitive byte-blt - (chars end-line) 0 - sap offset - (+ offset end-charpos))))) - (multiple-value-bind - (okay errno) - (mach:unix-write (system:fd-stream-fd file) - sap 0 length) - (unless okay - (error "Could not write ~S: ~A" - file - (mach:get-unix-error-msg errno)))) - (system:gr-call mach:vm_deallocate system:*task-self* - address bytes))))))))) diff --git a/hemlock/fill.lisp b/hemlock/fill.lisp deleted file mode 100644 index 3733b034d956b9478df716d5f5d44d4fe46cf2a1..0000000000000000000000000000000000000000 --- a/hemlock/fill.lisp +++ /dev/null @@ -1,738 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; -;;; This file contains the implementation of Auto Fill Mode. Also, -;;; paragraph and region filling stuff is here. -;;; - -(in-package "HEMLOCK") - - -;;; Fill Mode should be defined with some transparent bindings (linefeed and -;;; return) but with some that are not (space), so until this is possible, we -;;; kludge this effect by altering Auto Fill Linefeed and Auto Fill Return. -(defmode "Fill") - - - -;;;; -- Variables -- - -(defhvar "Fill Column" - "Used to determine at what column to force text to the next line." - :value 75) - -(defhvar "Fill Prefix" - "String to put before each line when filling." - :value ()) - -(defhvar "Auto Fill Space Indent" - "When non-nil, uses \"Indent New Comment Line\" to break lines instead of - \"New Line\". However, if there is a fill prefix, it is still preferred." - :value nil) - - - -;;;; -- New Attributes -- - -(defattribute "Paragraph Delimiter" - "is a character that delimits a paragraph by beginning a line." - '(mod 2) - 0) - - -;;; (setf (character-attribute :paragraph-delimiter #\@) 1) -;;; (setf (character-attribute :paragraph-delimiter #\\) 1) -;;; (setf (character-attribute :paragraph-delimiter #\/) 1) -;;; (setf (character-attribute :paragraph-delimiter #\-) 1) -;;; (setf (character-attribute :paragraph-delimiter #\') 1) -;;; (setf (character-attribute :paragraph-delimiter #\.) 1) -;;; These are useful for making certain text formatting command lines -;;; delimit paragraphs. Anyway, this is what EMACS documentation states, -;;; and #\' and #\. are always paragraph delimiters (don't ask me). - -(setf (character-attribute :paragraph-delimiter #\space) 1) -(setf (character-attribute :paragraph-delimiter #\linefeed) 1) -(setf (character-attribute :paragraph-delimiter #\formfeed) 1) -(setf (character-attribute :paragraph-delimiter #\tab) 1) -(setf (character-attribute :paragraph-delimiter #\newline) 1) - - - -(defattribute "Sentence Closing Char" - "is a delimiting character that may follow a sentence terminator - such as quotation marks and parentheses." - '(mod 2) - 0) - - -(setf (character-attribute :sentence-closing-char #\") 1) -(setf (character-attribute :sentence-closing-char #\') 1) -(setf (character-attribute :sentence-closing-char #\)) 1) -(setf (character-attribute :sentence-closing-char #\]) 1) -(setf (character-attribute :sentence-closing-char #\|) 1) -(setf (character-attribute :sentence-closing-char #\>) 1) - - - -;;;; -- Commands -- - -(defcommand "Auto Fill Mode" (p) - "Breaks lines between words at the right margin. - A positive argument turns Fill mode on, while zero or a negative - argument turns it off. With no arguments, it is toggled. When space - is typed, text that extends past the right margin is put on the next - line. The right column is controlled by Fill Column." - "Determine if in Fill mode or not and set the mode accordingly." - (setf (buffer-minor-mode (current-buffer) "Fill") - (if p - (plusp p) - (not (buffer-minor-mode (current-buffer) "Fill"))))) - - -;;; This command should not have a transparent binding since it sometimes does -;;; not insert a spaces, and transparency would propagate to "Self Insert". -(defcommand "Auto Fill Space" (p) - "Insert space and a CRLF if text extends past margin. - If arg is 0, then may break line but will not insert the space. - If arg is positive, then inserts that many spaces without filling." - "Insert space and CRLF if text extends past margin. - If arg is 0, then may break line but will not insert the space. - If arg is positive, then inserts that many spaces without filling." - (let ((point (current-point))) - (check-fill-prefix (value fill-prefix) (value fill-column) point) - (cond ((and p (plusp p)) - (dotimes (x p) (insert-character point #\space))) - ((and p (zerop p)) (%auto-fill-space point nil)) - (t (%auto-fill-space point t))))) - - -(defcommand "Auto Fill Linefeed" (p) - "Does an immediate CRLF inserting Fill Prefix if it exists." - "Does an immediate CRLF inserting Fill Prefix if it exists." - (declare (ignore p)) - (let ((point (current-point))) - (check-fill-prefix (value fill-prefix) (value fill-column) point) - (%auto-fill-space point nil) - ;; The remainder of this function should go away when - ;; transparent key bindings are per binding instead of - ;; per mode. - (multiple-value-bind (command t-bindings) - (get-command #\linefeed :current) - (declare (ignore command)) ;command is this one, so don't invoke it - (dolist (c t-bindings) (funcall *invoke-hook* c p))) - (indent-new-line-command nil))) - - - -(defcommand "Auto Fill Return" (p) - "Does an Auto Fill Space with a prefix argument of 0 - followed by a newline." - "Does an Auto Fill Space with a prefix argument of 0 - followed by a newline." - (declare (ignore p)) - (let ((point (current-point))) - (check-fill-prefix (value fill-prefix) (value fill-column) point) - (%auto-fill-space point nil) - ;; The remainder of this function should go away when - ;; transparent key bindings are per binding instead of - ;; per mode. - (multiple-value-bind (command t-bindings) - (get-command #\return :current) - (declare (ignore command)) ;command is this one, so don't invoke it - (dolist (c t-bindings) (funcall *invoke-hook* c p))) - (new-line-command nil))) - - - -(defcommand "Fill Paragraph" (p) - "Fill this or next paragraph. - Point stays fixed, but text may move past it due to filling. - A paragraph is delimited by a blank line, a line beginning with a - special character (@,\,-,',and .), or it is begun with a line with at - least one whitespace character starting it. Prefixes are ignored or - skipped over before determining if a line starts or delimits a - paragraph." - "Fill this or next paragraph. - Point stays fixed, but text may move past it due to filling." - (let* ((prefix (value fill-prefix)) - (prefix-len (length prefix)) - (column (if p (abs p) (value fill-column))) - (point (current-point))) - (with-mark ((m point)) - (let ((paragraphp (paragraph-offset m 1))) - (unless (or paragraphp - (and (last-line-p m) - (end-line-p m) - (not (blank-line-p (mark-line m))))) - (editor-error)) - ;; - ;; start and end get deleted by the undo cleanup function - (let ((start (copy-mark m :right-inserting)) - (end (copy-mark m :left-inserting))) - (%fill-paragraph-start start prefix prefix-len) - (let* ((region (region start end)) - (undo-region (copy-region region))) - (fill-region region prefix column) - (make-region-undo :twiddle "Fill Paragraph" region undo-region))))))) - - -(defcommand "Fill Region" (p) - "Fill text from point to mark." - "Fill text from point to mark." - (declare (ignore p)) - (let* ((region (current-region)) - (prefix (value fill-prefix)) - (column (if p (abs p) (value fill-column)))) - (check-fill-prefix prefix column (current-point)) - (check-region-query-size region) - (fill-region-by-paragraphs region prefix column))) - - - -(defcommand "Set Fill Column" (p) - "Set Fill Column to current column or argument. - If argument is provided use its absolute value." - "Set Fill Column to current column or argument. - If argument is provided use its absolute value." - (let ((new-column (or (and p (abs p)) - (mark-column (current-point))))) - (defhvar "Fill Column" "This buffer's fill column" - :value new-column :buffer (current-buffer)) - (message "Fill Column = ~D" new-column))) - - -(defcommand "Set Fill Prefix" (p) - "Define Fill Prefix from the current line. - All of the current line up to point is the prefix. This may be - turned off by placing point at the beginning of a line when setting." - "Define Fill Prefix from the current line. - All of the current line up to point is the prefix. This may be - turned off by placing point at the beginning of a line when setting." - (declare (ignore p)) - (let ((point (current-point))) - (with-mark ((mark point)) - (line-start mark) - (let ((val (if (mark/= mark point) (region-to-string (region mark point))))) - (defhvar "Fill Prefix" "This buffer's fill prefix" - :value val :buffer (current-buffer)) - (message "Fill Prefix now ~:[empty~;~:*~S~]" val))))) - - -;;;; -- Auto Filling -- - -;;; %AUTO-FILL-SPACE takes a point and an argument indicating -;;; whether it should insert a space or not. If point is past Fill -;;; Column then text is filled. Usually the else clause of the if -;;; will be executed. If the then clause is executed, then the first -;;; branch of the COND will usually be executed. The first branch -;;; handles the case of the end of a word extending past Fill Column -;;; while the second handles whitespace preceded by non-whitespace -;;; extending past the Fill Column. The last branch is for those who -;;; like to whitespace out a blank line. - -(defun %auto-fill-space (point insertp) - "Insert space, but CRLF if text extends past margin. - If arg is 0, then may break line but will not insert the space. - If arg is positive, then inserts that many spaces without filling." - (if (> (mark-column point) (value fill-column)) - (with-mark ((mark1 point :left-inserting)) - (let ((not-all-blank (reverse-find-attribute mark1 :whitespace #'zerop)) - (prefix (value fill-prefix)) - (column (value fill-column))) - (cond ((and not-all-blank (mark= point mark1)) - (%auto-fill-word-past-column point mark1 insertp prefix column)) - ((and not-all-blank (same-line-p mark1 point)) - (delete-region (region mark1 point)) - (if (> (mark-column point) column) - (%auto-fill-word-past-column point mark1 insertp prefix column) - (%filling-set-next-line point nil prefix))) - (t - (line-start mark1 (mark-line point)) - (delete-region (region mark1 point)) - (%filling-set-next-line point nil prefix))))) - (if insertp (insert-character point #\space)))) - - - -;;; %AUTO-FILL-WORD-PAST-COLUMN takes a point, a second mark that is -;;; mark= at the end of some word, and an indicator of whether a space -;;; should be inserted or not. First, point is moved before the previous -;;; "word." If the word is effectively the only word on the line, it -;;; should not be moved down to the next line as it will leave a blank -;;; line. The third branch handles when the typing began in the middle of -;;; some line (that is, right in front of some word). Note that the else -;;; clause is the usual case. - -(defun %auto-fill-word-past-column (point mark1 insertp prefix column) - (let ((point-moved-p (reverse-find-attribute point :whitespace))) - (with-mark ((mark2 point :left-inserting)) - (cond ((or (not point-moved-p) - (%auto-fill-blank-before-p point prefix)) - (move-mark point mark1) - (%filling-set-next-line point nil prefix)) - ((%auto-fill-line-as-region-p point mark2 column) - (if (and insertp - (not (or (end-line-p mark1) - (whitespace-attribute-p (next-character mark1))))) - (insert-character mark1 #\space)) - (auto-fill-line-as-region point (move-mark mark2 point) prefix column) - (move-mark point mark1) - (if (and insertp (end-line-p point)) - (insert-character point #\space))) - ((not (or (end-line-p mark1) - (whitespace-attribute-p (next-character mark1)))) - (insert-character mark1 #\space) - (%filling-set-next-line point nil prefix) - (mark-after point) - (%auto-fill-clean-previous-line mark1 mark2)) - (t - (%filling-set-next-line point insertp prefix) - (%auto-fill-clean-previous-line mark1 mark2)))))) - - - -;;; AUTO-FILL-LINE-AS-REGION basically grabs a line as a region and fills -;;; it. However, it knows about comments and makes auto filling a comment -;;; line as a region look the same as a typical "back up a word and break -;;; the line." When there is a comment, then region starts where the -;;; comment starts instead of the beginning of the line, but the presence -;;; of a prefix overrides all this. - -(defun auto-fill-line-as-region (point mark prefix column) - (let* ((start (value comment-start)) - (begin (value comment-begin)) - (end (value comment-end))) - (line-start mark) - (cond ((and (not prefix) start (to-line-comment mark start)) - (fill-region (region mark (line-end point)) - (gen-comment-prefix mark start begin) - column) - (when end - (line-start point) - (do () - ((mark>= mark point)) - (if (not (to-comment-end mark end)) (insert-string mark end)) - (line-offset mark 1 0)))) - (t (fill-region (region mark (line-end point)) prefix column))))) - - - -(defun %auto-fill-blank-before-p (point prefix) - "is true if whitespace only precedes point except for the prefix." - (or (blank-before-p point) - (with-mark ((temp point)) - (reverse-find-attribute temp :whitespace #'zerop) - (<= (mark-column temp) (length prefix))))) - - - -;;; %AUTO-FILL-LINE-AS-REGION-P determines if the line point and mark2 -;;; sit on is so long that it might as well be filled as if it were a -;;; region. Mark2 is mark= to point at the beginning of the last word on -;;; the line and is then moved over the whitespace before point. If the -;;; word end prior the last word on the line is on the same line and not -;;; before column, then fill the line as a region. - -(defun %auto-fill-line-as-region-p (point mark2 column) - (reverse-find-attribute mark2 :whitespace #'zerop) - (and (same-line-p mark2 point) - (> (mark-column mark2) column))) - - - -(defun %auto-fill-clean-previous-line (mark1 mark2) - (when (line-offset mark1 -1) - (line-end mark1) - (move-mark mark2 mark1) - (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) - (same-line-p mark1 mark2)) - (line-start mark1 (mark-line mark2))) - (delete-region (region mark1 mark2)))) - - - -;;; %FILLING-SET-NEXT-LINE gets a new blank line and sets it up with the -;;; prefix and places the point correctly. The argument point must alias -;;; (current-point). - -(defun %filling-set-next-line (point insertp prefix) - (cond ((and (value auto-fill-space-indent) (not prefix)) - (indent-new-comment-line-command nil)) - (t (new-line-command nil) - (if prefix (insert-string point prefix)))) - (if (not (find-attribute point :whitespace)) (line-end point)) - (if insertp (insert-character point #\space))) - - - -;;;; -- Paragraph Filling -- - - -;;; %FILL-PARAGRAPH-START takes a mark that has just been moved -;;; forward over some paragraph. After moving to the beginning of it, we -;;; place the mark appropriately for filling the paragraph as a region. - -(defun %fill-paragraph-start (mark prefix prefix-len) - (paragraph-offset mark -1) - (skip-prefix-if-here mark prefix prefix-len) - (if (text-blank-line-p mark) - (line-offset mark 1 0) - (line-start mark))) - - - -;;;; -- Region Filling -- - - -;;; FILL-REGION-BY-PARAGRAPHS finds paragraphs and uses region filling -;;; primitives to fill them. Tmark2 is only used for the first paragraph; we -;;; need a mark other than start in case start is in the middle of a paragraph -;;; instead of between two. -;;; -(defun fill-region-by-paragraphs (region &optional - (prefix (value fill-prefix)) - (column (value fill-column))) - "Finds paragraphs in region and fills them as distinct regions using - FILL-REGION." - (with-mark ((start (region-start region) :left-inserting)) - (with-mark ((tmark1 start :left-inserting) - (tmark2 start :left-inserting)) ;only used for first para. - (let ((region (region (copy-mark (region-start region)) ;deleted by undo. - (copy-mark (region-end region)))) - (undo-region (copy-region region)) - (end (region-end region)) - (prefix-len (length prefix)) - (paragraphp (paragraph-offset tmark1 1))) - (when paragraphp - (%fill-paragraph-start (move-mark tmark2 tmark1) prefix prefix-len) - (if (mark>= tmark2 start) (move-mark start tmark2)) - (cond ((mark>= tmark1 end) - (fill-region-aux start end prefix prefix-len column)) - (t - (fill-region-aux start tmark1 prefix prefix-len column) - (do ((paragraphp (mark-paragraph start tmark1) - (mark-paragraph start tmark1))) - ((not paragraphp)) - (if (mark> start end) - (return) - (cond ((mark>= tmark1 end) - (fill-region-aux start end prefix - prefix-len column) - (return)) - (t (fill-region-aux start tmark1 - prefix prefix-len column)))))))) - (make-region-undo :twiddle "Fill Region" region undo-region))))) - -(defun fill-region (region &optional - (prefix (value fill-prefix)) - (column (value fill-column))) - "Fills a region using the given prefix and column." - (let ((prefix (if (and prefix (string= prefix "")) () prefix))) - (with-mark ((start (region-start region) :left-inserting)) - (check-fill-prefix prefix column start) - (fill-region-aux start (region-end region) - prefix (length prefix) column)))) - - - -;;; FILL-REGION-AUX grinds over a region between fill-mark and -;;; end-mark deleting blank lines and filling lines. For each line, the -;;; extra whitespace between words is collapsed to one space, and at the -;;; end and beginning of the line it is deleted. We do not return after -;;; realizing that fill-mark is after end-mark if the line needs to be -;;; broken; it may be the case that there are several filled line lengths -;;; of material before end-mark on the current line. - -(defun fill-region-aux (fill-mark end-mark prefix prefix-len column) - (if (and (start-line-p fill-mark) prefix) - (fill-region-prefix-line fill-mark prefix prefix-len)) - (with-mark ((mark1 fill-mark :left-inserting) - (cmark fill-mark :left-inserting)) - (do ((collapse-p t)) - (nil) - (line-end fill-mark) - (line-start (move-mark mark1 fill-mark)) - (skip-prefix-if-here mark1 prefix prefix-len) - (cond ((mark>= fill-mark end-mark) - (if (mark= fill-mark end-mark) - (fill-region-clear-eol fill-mark)) - (cond ((> (mark-column end-mark) column) - (when collapse-p - (fill-region-collapse-whitespace cmark end-mark) - (setf collapse-p nil)) - (fill-region-break-line fill-mark prefix - prefix-len end-mark column)) - (t (return)))) - ((blank-after-p mark1) - (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len) - (cond ((mark< fill-mark end-mark) - (if prefix - (fill-region-prefix-line fill-mark prefix prefix-len)) - (fill-region-clear-bol fill-mark) - (move-mark cmark fill-mark)) - (t (return))) - (setf collapse-p t)) - (t (fill-region-clear-eol fill-mark) - (if collapse-p (fill-region-collapse-whitespace cmark fill-mark)) - (cond ((> (mark-column fill-mark) column) - (fill-region-break-line fill-mark prefix - prefix-len end-mark column) - (setf collapse-p nil)) - (t (fill-region-get-next-line fill-mark column - prefix prefix-len end-mark) - (move-mark cmark fill-mark) - (setf collapse-p t)))))) - (move-mark fill-mark end-mark))) - - - -;;; FILL-REGION-BREAK-LINE breaks lines as close to the low side -;;; column as possible. The first branch handles a word lying across -;;; column while the second takes care of whitespace passing column. If -;;; FILL-REGION-WORD-PAST-COLUMN encountered a single word stretching over -;;; column, it would leave an extra opened line that needs to be cleaned up -;;; or filled up. - -(defun fill-region-break-line (fill-mark prefix prefix-length - end-mark column) - (with-mark ((mark1 fill-mark :left-inserting)) - (move-to-column mark1 column) - (cond ((not (whitespace-attribute-p (next-character mark1))) - (if (not (find-attribute mark1 :whitespace)) - (line-end mark1)) - (move-mark fill-mark mark1) - (if (eq (fill-region-word-past-column fill-mark mark1 prefix) - :handled-oversized-word) - (if (mark>= fill-mark end-mark) - (delete-characters (line-start fill-mark) - prefix-length) - (delete-characters fill-mark 1)))) - (t (move-mark fill-mark mark1) - (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) - (same-line-p mark1 fill-mark)) - (line-start mark1 (mark-line fill-mark))) - ;; forward find must move mark because of cond branch we are in. - (find-attribute fill-mark :whitespace #'zerop) - (unless (same-line-p mark1 fill-mark) - (line-end fill-mark (mark-line mark1))) - (delete-region (region mark1 fill-mark)) - (insert-character fill-mark #\newline) - (if prefix (insert-string fill-mark prefix)))))) - - - -;;; FILL-REGION-WORD-PAST-COLUMN takes a point and a second mark that -;;; is mark= at the end of some word. First, point is moved before the -;;; previous "word." If the word is effectively the only word on the line, -;;; it should not be moved down to the next line as it will leave a blank -;;; line. - -(defun fill-region-word-past-column (point mark1 prefix) - (with-mark ((mark2 (copy-mark point :left-inserting))) - (let ((point-moved-p (reverse-find-attribute point :whitespace)) - (hack-for-fill-region :handled-normal-case)) - (cond ((or (not point-moved-p) - (%auto-fill-blank-before-p point prefix)) - (setf hack-for-fill-region :handled-oversized-word) - (move-mark point mark1) - (fill-region-set-next-line point prefix)) - (t (fill-region-set-next-line point prefix) - (%auto-fill-clean-previous-line mark1 mark2))) - hack-for-fill-region))) - -(defun fill-region-set-next-line (point prefix) - (insert-character point #\newline) - (if prefix (insert-string point prefix)) - (if (not (find-attribute point :whitespace)) (line-end point))) - - - -;;; FILL-REGION-GET-NEXT-LINE gets another line when the current one -;;; is short of the fill column. It cleans extraneous whitespace from the -;;; beginning of the next line to fill. To save typical redisplay the -;;; length of the first word is added to the ending column of the current -;;; line to see if it extends past the fill column; if it does, then the -;;; fill-mark is left on the new line instead of merging the new line with -;;; the current one. The fill-mark is left after a prefix (if there is one) -;;; on a new line, before the first word brought up to the current line, or -;;; after the end mark. - -(defun fill-region-get-next-line (fill-mark column prefix prefix-len end-mark) - (let ((prev-end-pos (mark-column fill-mark)) - (two-spaces-p (fill-region-insert-two-spaces-p fill-mark))) - (with-mark ((tmark fill-mark :left-inserting)) - (fill-region-find-next-line fill-mark prefix prefix-len end-mark) - (move-mark tmark fill-mark) - (cond ((mark< fill-mark end-mark) - (skip-prefix-if-here tmark prefix prefix-len) - (fill-region-clear-bol tmark) - (let ((beginning-pos (mark-column tmark))) - (find-attribute tmark :whitespace) - (cond ((> (+ prev-end-pos (if two-spaces-p 2 1) - (- (mark-column tmark) beginning-pos)) - column) - (if prefix - (fill-region-prefix-line fill-mark prefix prefix-len))) - (t - (if (and prefix - (%line-has-prefix-p fill-mark prefix prefix-len)) - (delete-characters fill-mark prefix-len)) - (delete-characters fill-mark -1) - (insert-character fill-mark #\space) - (if two-spaces-p (insert-character fill-mark #\space)))))) - (t - (mark-after fill-mark)))))) - - - -;;; FILL-REGION-FIND-NEXT-LINE finds the next non-blank line, modulo -;;; fill prefixes, and deletes the intervening lines. Fill-mark is left at -;;; the beginning of the next line. - -(defun fill-region-find-next-line (fill-mark prefix prefix-len end-mark) - (line-offset fill-mark 1 0) - (when (mark< fill-mark end-mark) - (skip-prefix-if-here fill-mark prefix prefix-len) - (if (blank-after-p fill-mark) - (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len) - (line-start fill-mark)))) - - - -;;; FILL-REGION-DELETE-BLANK-LINES deletes the blank line mark is on -;;; and all successive blank lines. Mark is left at the beginning of the -;;; first non-blank line by virtue of its placement and region deletions. - -(defun fill-region-delete-blank-lines (mark end-mark prefix prefix-len) - (line-start mark) - (with-mark ((tmark mark :left-inserting)) - (do ((linep (line-offset tmark 1 0) (line-offset tmark 1 0))) - ((not linep) - (move-mark tmark end-mark) - (delete-region (region mark tmark))) - (skip-prefix-if-here tmark prefix prefix-len) - (when (mark>= tmark end-mark) - (move-mark tmark end-mark) - (delete-region (region mark tmark)) - (return)) - (unless (blank-after-p tmark) - (line-start tmark) - (delete-region (region mark tmark)) - (return))))) - - - -;;; FILL-REGION-CLEAR-BOL clears the initial whitespace on a line -;;; known to be non-blank. Note that the fill prefix is not considered, so -;;; the mark must have been moved over it already if there is one. - -(defun fill-region-clear-bol (mark) - (with-mark ((tmark mark :left-inserting)) - (find-attribute tmark :whitespace #'zerop) - (unless (mark= mark tmark) - (delete-region (region mark tmark))))) - - - -;;; FILL-REGION-COLLAPSE-WHITESPACE deletes extra whitespace between -;;; blocks of non-whitespace characters from mark1 to mark2. Tabs are -;;; converted into a single space. Mark2 must be on the same line as mark1 -;;; since there is no concern of newlines, prefixes on a new line, blank -;;; lines between blocks of non-whitespace characters, etc. - -(defun fill-region-collapse-whitespace (mark1 mark2) - (with-mark ((tmark mark1 :left-inserting)) - ;; skip whitespace at beginning of line or single space between words - (find-attribute mark1 :whitespace #'zerop) - (unless (mark>= mark1 mark2) - (do () - (nil) - (if (not (find-attribute mark1 :whitespace)) ;not end of buffer - (return)) - (if (mark>= mark1 mark2) (return)) - (if (char/= (next-character mark1) #\space) - ;; since only on one line, must be tab or space - (setf (next-character mark1) #\space)) - (move-mark tmark mark1) - (if (mark= (mark-after mark1) mark2) (return)) - (let ((char (next-character mark1))) - (when (and (fill-region-insert-two-spaces-p tmark) - (char= char #\space)) - ;; if at the end of a sentence, don't blow away the second space - (if (mark= (mark-after mark1) mark2) - (return) - (setf char (next-character mark1)))) - (when (whitespace-attribute-p char) ;more whitespace than necessary - (find-attribute (move-mark tmark mark1) :whitespace #'zerop) - (if (mark>= tmark mark2) (move-mark tmark mark2)) - (delete-region (region mark1 tmark)))))))) - - - -;;; FILL-REGION-CLEAR-EOL must check the result of -;;; REVERSE-FIND-ATTRIBUTE because if fill-mark did not move, then we are -;;; only whitespace away from the beginning of the buffer. - -(defun fill-region-clear-eol (fill-mark) - (with-mark ((mark1 fill-mark :left-inserting)) - (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) - (same-line-p mark1 fill-mark)) - (line-start mark1 (mark-line fill-mark))) - (delete-region (region mark1 fill-mark)))) - - - -(defun fill-region-prefix-line (fill-mark prefix prefix-length) - (if (%line-has-prefix-p fill-mark prefix prefix-length) - (character-offset fill-mark prefix-length) - (insert-string fill-mark prefix))) - - - -(defun %line-has-prefix-p (mark prefix prefix-length) - (declare (simple-string prefix)) - (if (>= (line-length (mark-line mark)) prefix-length) - (string= prefix (the simple-string (line-string (mark-line mark))) - :end2 prefix-length))) - - - -;;; FILL-REGION-INSERT-TWO-SPACES-P returns true if a sentence -;;; terminator is followed by any number of "closing characters" such as -;;; ",',),etc. If there is a sentence terminator at the end of the current -;;; line, it must be assumed to be the end of a sentence as opposed to an -;;; abbreviation. Why? Because EMACS does, and besides, what would Lisp -;;; code be without heuristics. - -(defun fill-region-insert-two-spaces-p (mark) - (do ((n 0 (1+ n))) - ((not (sentence-closing-char-attribute-p (previous-character mark))) - (cond ((sentence-terminator-attribute-p (previous-character mark)) - (character-offset mark n)) - (t (character-offset mark n) nil))) - (mark-before mark))) - - - -(defun check-fill-prefix (prefix column mark) - (when prefix - (insert-character mark #\newline) - (insert-character mark #\newline) - (mark-before mark) - (insert-string mark prefix) - (let ((pos (mark-column mark))) - (declare (simple-string prefix)) - (mark-after mark) - (delete-characters mark (- (+ (length prefix) 2))) - (if (>= pos column) - (editor-error - "The fill prefix length is longer than the fill column."))))) diff --git a/hemlock/font.lisp b/hemlock/font.lisp deleted file mode 100644 index 0fb8d3aa4aa120b27b697c5f9d57ca45f09f87cf..0000000000000000000000000000000000000000 --- a/hemlock/font.lisp +++ /dev/null @@ -1,119 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; Modified by Bill Chiles toward Hemlock running under X. -;;; -;;; This file contains various functions that make up the user interface to -;;; fonts. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(font-mark delete-font-mark delete-line-font-marks move-font-mark - window-font)) -;;; Default-font used to be in the above list, but when I cleaned up the way -;;; Hemlock compiles, a name conflict occurred because "Default Font" is a -;;; Hemlock variable. It is now exported by the export list in rompsite.lisp. - -(defvar *default-font-family* (make-font-family)) - - - -;;;; Creating, Deleting, and Moving. - -(defun font-mark (line charpos font &optional (kind :right-inserting)) - "Returns a font on line at charpos with font. Font marks must be permanent - marks." - (unless (or (eq kind :right-inserting) (eq kind :left-inserting)) - (error "A Font-Mark must be :left-inserting or :right-inserting.")) - (unless (and (>= font 0) (< font font-map-size)) - (error "Font number ~S out of range." font)) - (let ((new (internal-make-font-mark line charpos kind font))) - (new-font-mark new line) - (push new (line-marks line)) - new)) - -(defun delete-font-mark (font-mark) - "Deletes a font mark." - (check-type font-mark font-mark) - (let ((line (mark-line font-mark))) - (when line - (setf (line-marks line) (delq font-mark (line-marks line))) - (nuke-font-mark font-mark line) - (setf (mark-line font-mark) nil)))) - -(defun delete-line-font-marks (line) - "Deletes all font marks on line." - (dolist (m (line-marks line)) - (when (fast-font-mark-p m) - (delete-font-mark m)))) - -(defun move-font-mark (font-mark new-position) - "Moves font mark font-mark to location of mark new-position." - (check-type font-mark font-mark) - (let ((old-line (mark-line font-mark)) - (new-line (mark-line new-position))) - (nuke-font-mark font-mark old-line) - (move-mark font-mark new-position) - (new-font-mark font-mark new-line) - font-mark)) - -(defun nuke-font-mark (mark line) - (new-font-mark mark line)) - -(defun new-font-mark (mark line) - (declare (ignore mark)) - (let ((buffer (line-%buffer line)) - (number (line-number line))) - (when (bufferp buffer) - (dolist (w (buffer-windows buffer)) - (setf (window-tick w) (1- (buffer-modified-tick buffer))) - (let ((first (cdr (window-first-line w)))) - (unless (or (> (line-number (dis-line-line (car first))) number) - (> number - (line-number - (dis-line-line (car (window-last-line w)))))) - (do ((dl first (cdr dl))) - ((or (null dl) - (eq (dis-line-line (car dl)) line)) - (when dl - (setf (dis-line-old-chars (car dl)) :font-change)))))))))) - - - -;;;; Referencing and setting font ids. - -(defun window-font (window font) - "Returns a font id for window and font." - (svref (font-family-map (bitmap-hunk-font-family (window-hunk window))) font)) - -(defun %set-window-font (window font font-object) - (unless (and (>= font 0) (< font font-map-size)) - (error "Font number ~S out of range." font)) - (setf (bitmap-hunk-trashed (window-hunk window)) :font-change) - (let ((family (bitmap-hunk-font-family (window-hunk window)))) - (when (eq family *default-font-family*) - (setq family (copy-font-family family)) - (setf (font-family-map family) (copy-seq (font-family-map family))) - (setf (bitmap-hunk-font-family (window-hunk window)) family)) - (setf (svref (font-family-map family) font) font-object))) - -(defun default-font (font) - "Returns the font id for font out of the default font family." - (svref (font-family-map *default-font-family*) font)) - -(defun %set-default-font (font font-object) - (unless (and (>= font 0) (< font font-map-size)) - (error "Font number ~S out of range." font)) - (dolist (w *window-list*) - (when (eq (bitmap-hunk-font-family (window-hunk w)) *default-font-family*) - (setf (bitmap-hunk-trashed (window-hunk w)) :font-change))) - (setf (svref (font-family-map *default-font-family*) font) font-object)) diff --git a/hemlock/gosmacs.lisp b/hemlock/gosmacs.lisp deleted file mode 100644 index d65bc7ddc803b668aaa9b89cb393ee46e7692b0d..0000000000000000000000000000000000000000 --- a/hemlock/gosmacs.lisp +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Package: Hemlock; Log: Hemlock.Log -*- -;;; -;;; Stuff in this file provides some degree of upward compatibility -;;; for incurable Gosling Emacs users. -;;; -(in-package 'hemlock) - -(defcommand "Gosmacs Permute Characters" (p) - "Transpose the two characters before the point." - "Transpose the two characters before the point." - (declare (ignore p)) - (with-mark ((m (current-point) :left-inserting)) - (unless (and (mark-before m) (previous-character m)) - (editor-error "NIB You have addressed a character not in the buffer?")) - (rotatef (previous-character m) (next-character m)))) - -(bind-key "Gosmacs Permute Characters" #\control-t) -(bind-key "Kill Previous Word" #\meta-h) -(bind-key "Replace String" #\meta-r) -(bind-key "Query Replace" #\meta-q) -(bind-key "Fill Paragraph" #\meta-j) -(bind-key "Visit File" '#(#\control-x #\control-r)) -(bind-key "Find File" '#(#\control-x #\control-v)) -(bind-key "Insert File" '#(#\control-x #\control-i)) diff --git a/hemlock/group.lisp b/hemlock/group.lisp deleted file mode 100644 index e962d5259ec31eb03408c4a8b0f39fb0f447b118..0000000000000000000000000000000000000000 --- a/hemlock/group.lisp +++ /dev/null @@ -1,234 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; File group stuff for Hemlock. -;;; Written by Skef Wholey and Rob MacLachlan. -;;; -;;; The "Compile Group" and "List Compile Group" commands in lispeval -;;; also know about groups. -;;; -;;; This file provides Hemlock commands for manipulating groups of files -;;; that make up a larger system. A file group is a set of files whose -;;; names are listed in some other file. At any given time one group of -;;; files is the Active group. The Select Group command makes a group the -;;; Active group, prompting for the name of a definition file if the group -;;; has not been selected before. Once a group has been selected once, the -;;; name of the definition file associated with that group is retained. If -;;; one wishes to change the name of the definition file after a group has -;;; been selected, one should call Select Group with a prefix argument. - -(in-package 'hemlock) - -(defvar *file-groups* (make-string-table) - "A string table of file groups.") - -(defvar *active-file-group* () - "The list of files in the currently active group.") - -(defvar *active-file-group-name* () - "The name of the currently active group.") - - - -;;;; Selecting the active group. - -(defcommand "Select Group" (p) - "Makes a group the active group. With a prefix argument, changes the - definition file associated with the group." - "Makes a group the active group." - (let* ((group-name - (prompt-for-keyword - (list *file-groups*) - :must-exist nil - :prompt "Select Group: " - :help - "Type the name of the file group you wish to become the active group.")) - (old (getstring group-name *file-groups*)) - (pathname - (if (and old (not p)) - old - (prompt-for-file :must-exist t - :prompt "From File: " - :default (merge-pathnames - (make-pathname - :name group-name - :type "upd") - (value pathname-defaults)))))) - (setq *active-file-group-name* group-name) - (setq *active-file-group* (nreverse (read-file-group pathname nil))) - (setf (getstring group-name *file-groups*) pathname))) - - -;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames -;;; of the files named in that file. This guy knows about @@ indirection and -;;; ignores empty lines and lines that begin with @ but not @@. A simpler -;;; scheme could be used for non-Spice implementations, but all this hair is -;;; probably useful, so Update format may as well be a standard for this sort -;;; of thing. -;;; -(defun read-file-group (pathname tail) - (with-open-file (file pathname) - (do* ((name (read-line file nil nil) (read-line file nil nil)) - (length (if name (length name)) (if name (length name)))) - ((null name) tail) - (declare (simple-string name)) - (cond ((zerop length)) - ((char= (char name 0) #\@) - (when (and (> length 1) (char= (char name 1) #\@)) - (setq tail (read-file-group - (merge-pathnames (subseq name 2) - pathname) - tail)))) - (t - (push (merge-pathnames (pathname name) pathname) tail)))))) - - - -;;;; DO-ACTIVE-GROUP. - -(defhvar "Group Find File" - "If true, group commands use \"Find File\" to read files, otherwise - non-resident files are read into the \"Group Search\" buffer." - :value nil) - -(defhvar "Group Save File Confirm" - "If true, then the group commands will ask for confirmation before saving - a modified file." :value t) - -(defmacro do-active-group (&rest forms) - "This iterates over the active file group executing forms once for each - file. When forms are executed, the file will be in the current buffer, - and the point will be at the start of the file." - (let ((n-buf (gensym)) - (n-start-buf (gensym)) - (n-save (gensym))) - `(progn - (unless *active-file-group* - (editor-error "There is no active file group.")) - - (let ((,n-start-buf (current-buffer)) - (,n-buf nil)) - (unwind-protect - (dolist (file *active-file-group*) - (catch 'file-not-found - (setq ,n-buf (group-read-file file ,n-buf)) - (with-mark ((,n-save (current-point) :right-inserting)) - (unwind-protect - (progn - (buffer-start (current-point)) - ,@forms) - (move-mark (current-point) ,n-save))) - (group-save-file))) - (if (member ,n-start-buf *buffer-list*) - (setf (current-buffer) ,n-start-buf - (window-buffer (current-window)) ,n-start-buf) - (editor-error "Original buffer deleted!"))))))) - -;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP. -;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't -;;; already been read, to get files in, and then we delete the buffer if it is -;;; newly created and "Group Find File" is false. This lets FIND-FILE-BUFFER -;;; do all the work. We don't actually use the "Find File" command, so the -;;; buffer history isn't affected. -;;; -;;; Search-Buffer is any temporary search buffer left over from the last file -;;; that we want deleted. We don't do the deletion if the buffer is modified. -;;; -(defun group-read-file (name search-buffer) - (unless (probe-file name) - (message "File ~A not found." name) - (throw 'file-not-found nil)) - (multiple-value-bind (buffer created-p) - (find-file-buffer name) - (setf (current-buffer) buffer) - (setf (window-buffer (current-window)) buffer) - - (when (and search-buffer (not (buffer-modified search-buffer))) - (dolist (w (buffer-windows search-buffer)) - (setf (window-buffer w) (current-buffer))) - (delete-buffer search-buffer)) - - (if (and created-p (not (value group-find-file))) - (current-buffer) nil))) - -;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP. -;;; -(defun group-save-file () - (let* ((buffer (current-buffer)) - (pn (buffer-pathname buffer)) - (name (namestring pn))) - (when (and (buffer-modified buffer) - (or (not (value group-save-file-confirm)) - (prompt-for-y-or-n - :prompt (list "Save changes in ~A? " name) - :default t))) - (save-file-command ())))) - - - -;;;; Searching and Replacing commands. - -(defcommand "Group Search" (p) - "Searches the active group for a specified string, which is prompted for." - "Searches the active group for a specified string." - (declare (ignore p)) - (let ((string (prompt-for-string :prompt "Group Search: " - :help "String to search for in active file group" - :default *last-search-string*))) - (get-search-pattern string :forward) - (do-active-group - (do ((won (find-pattern (current-point) *last-search-pattern*) - (find-pattern (current-point) *last-search-pattern*))) - ((not won)) - (character-offset (current-point) won) - (command-case - (:prompt "Group Search: " - :help "Type a character indicating the action to perform." - :change-window nil) - (:no "Search for the next occurrence.") - (:do-all "Go on to the next file in the group." - (return nil)) - ((:exit :yes) "Exit the search." - (return-from group-search-command)) - (:recursive-edit "Enter a recursive edit." - (do-recursive-edit) - (get-search-pattern string :forward))))) - (message "All files in group ~S searched." *active-file-group-name*))) - -(defcommand "Group Replace" (p) - "Replaces one string with another in the active file group." - "Replaces one string with another in the active file group." - (declare (ignore p)) - (let* ((target (prompt-for-string :prompt "Group Replace: " - :help "Target string" - :default *last-search-string*)) - (replacement (prompt-for-string :prompt "With: " - :help "Replacement string"))) - (do-active-group - (query-replace-function nil target replacement - "Group Replace on previous file" t)) - (message "Replacement done in all files in group ~S." - *active-file-group-name*))) - -(defcommand "Group Query Replace" (p) - "Query Replace for the active file group." - "Query Replace for the active file group." - (declare (ignore p)) - (let ((target (prompt-for-string :prompt "Group Query Replace: " - :help "Target string" - :default *last-search-string*))) - (let ((replacement (prompt-for-string :prompt "With: " - :help "Replacement string"))) - (do-active-group - (unless (query-replace-function - nil target replacement "Group Query Replace on previous file") - (return nil))) - (message "Replacement done in all files in group ~S." - *active-file-group-name*)))) diff --git a/hemlock/hemlock.log b/hemlock/hemlock.log deleted file mode 100644 index 3954876575ee34cad264d0093224ff30d79473e5..0000000000000000000000000000000000000000 --- a/hemlock/hemlock.log +++ /dev/null @@ -1,4117 +0,0 @@ -.../systems-work/hemlock/diredcoms.lisp, 08-May-90 15:38:28, Edit by Chiles. - Fixed :help string in file prompt for "Delete File". - -.../hemlock/ts-stream.lisp, 26-Apr-90 17:14:10, Edit by Wlott. - Make %ts-stream-listen try calling server before finally saying that - there is no more input available. - -.../hemlock/files.lisp, 26-Apr-90 18:43:29, Edit by Wlott. - Fixed a bug in write-file in which the first line was being extended with - garbage if it didn't start at the first character. - -.../systems-work/hemlock/lispeval.lisp, 16-Apr-90 14:03:10, Edit by Chiles. - Modified OPERATION-STARTED, OPERATION-COMPLETED, and "List Operations" to - preserve the case of context strings when MESSAGE'ing. I added "The"'s to - sentences which previously capitalized the first word of the context and - lowered the remaining parts of the string. I added periods to sentences in - all these routines. I stopped operation listing from forcing the entire - string to lowercase. The user should get his context as he supplied it. - Many users complained about file names reporting as incorrect due to the old - state of the code. - -.../systems-work/hemlock/lispbuf.lisp, 16-Apr-90 13:41:05, Edit by Chiles. - Fixed doc string for "Current Package" in "package" file option handler. - -/usr2/ch/lisp/lispeval.lisp, 15-Apr-90 19:14:38, Edit by Christopher Hoover. - Sometimes the defined "Current Package" does not exist in the slave, and - sometimes "Current Package" is defined as nil. "Describe Function Call" - points out which reason led to using the default package in the slave. - -.../systems-work/hemlock/shell.lisp, 24-Mar-90 11:58:10, Edit by Chiles. - New file. - -.../systems-work/hemlock/bindings.lisp, 24-Mar-90 11:57:31, Edit by Chiles. - Added bindings for new "Process" mode. - -.../systems-work/hemlock/main.lisp, 22-Mar-90 16:03:27, Edit by Blaine. - Added new hook "Buffer Writable Hook". - -.../systems-work/hemlock/buffer.lisp, 22-Mar-90 15:45:51, Edit by Blaine. - Write BUFFER-WRITABLE and %SET-BUFFER-WRITABLE. - -.../systems-work/hemlock/struct.lisp, 22-Mar-90 15:40:31, Edit by Blaine. - Renamed the writable slot to %writable. Added DEFSETF for BUFFER-WRITABLE. - -.../systems-work/hemlock/completion.lisp, 22-Mar-90 14:51:00, Edit by Chiles. - Picked up Blaine's "Save Completions", "Read Completions", and "Parse Buffer - for Completions". - - I added documentation to "Completion" mode and made the parameter - completion-bucket-size-limit be a Hemlock variable "Completion Bucket Size". - - -.../systems-work/hemlock/buffer.lisp, 19-Mar-90 16:45:01, Edit by Chiles. - Made the BUFFER-MODIFIED SETF'er return the value stored. - -.../systems-work/hemlock/table.lisp, 12-Mar-90 12:43:13, Edit by Chiles. - Made BI-SVPOSITION stop calling IDENTITY on every element. There already was - a test for the key argument being nil, but the author allowed the argument to - default to IDENTITY. Also, it is never called without a key argument anyway - -- gratuitous generality maladjusted. - -.../systems-work/hemlock/mh.lisp, 09-Mar-90 09:03:28, Edit by Chiles. - Fixed bug in REMAIL-MESSAGE resulting from recent changes to the environment - code that made my MH env vars become capitalized when they should have been - lowercase. - -.../systems-work/hemlock/lispeval.lisp, 27-Feb-90 15:03:31, Edit by Chiles. - Modified EVAL-FORM-IN-SERVER to optionally take a package name. It uses the - value of "Current Package" as a default, which it previously always supplied. - EVAL-FORM-IN-SERVER-1 accordingly takes a package argument now. "Describe - Function Call" now first asks the server if the value of "Current Package" - names a package, and if it does not, then this command describes the function - call by reading the name into *package* in the slave. This reasonably - handles the problem of describing a function call with a buffer package that - does not exist in the slave. - -.../systems-work/hemlock/screen.lisp, 27-Feb-90 13:18:16, Edit by Mbb. - Made pop-up displays better count lines when fully buffered. - -.../systems-work/hemlock/lispeval.lisp, 22-Feb-90 11:20:03, Edit by Chiles. - Picked up Williams change to "Lisp Operations", and I documented his peculiar - queue implementation. - -.../systems-work/hemlock/srccom.lisp, 21-Feb-90 13:52:45, Edit by Chiles. - Added "Source Compare Ignore Indentation" and wrote a macro to generate the - line comparison routines that *srccom-line-=* holds. - -.../systems-work/hemlock/searchcoms.lisp, 15-Feb-90 10:17:40, Edit by Chiles. - Fixed a bug in undo'ing replacements. IF two were immediately adjacent, the - second would not be undone. - -.../systems-work/hemlock/command.lisp, 14-Feb-90 14:15:38, Edit by Chiles. - Fixed "Forward Character". - -.../systems-work/hemlock/eval-server.lisp, 10-Feb-90 12:07:29, Edit by Chiles. - Made editor MESSAGE what slave is GC'ing when dumping GC messages behind the - prompt. Also, moved the global frobbing into the two routines that setup and - cleanup stream variables. - -.../systems-work/hemlock/mh.lisp, 09-Feb-90 17:02:43, Edit by Chiles. - Finally fixed bug in PICK-MESSAGES that allowed MH pick to screw us. MH pick - would output "0" when no messages matched a specification, so PICK-MESSAGES - now tests the result of calling MH to invoke "pick". It returns nil whenever - MH returns other than t for correct completion. - -.../systems-work/hemlock/termcap.lisp, 08-Feb-90 20:07:01, Edit by Chiles. - The new fd-streams, which correctly implement unreading characters, pointed - out that this code relied on multiply unreading characters. It no longer - does. - -.../systems-work/hemlock/lisp-lib.lisp, 07-Feb-90 15:50:50, Edit by Chiles. - Modified MERGE-PATHNAMES calls that used strings with dots to merge in types. - This no longer works with the new NAMESTRING/PARSE-NAMESTRING stuff. - -.../systems-work/hemlock/command.lisp, 07-Feb-90 13:52:10, Edit by Chiles. - "Next Line" was opening newlines in the middle of the buffer's last line of - text when the buffer wasn't newline terminated. - -/usr2/mbb/lisp/work/macros.lisp, 07-Feb-90 12:22:54, Edit by Mbb. - Changed how WITH-POP-UP-DISPLAY determines whether to cleanup. It - shouldn't have been cleaning up unless something had really happened, but - it was. - -.../systems-work/hemlock/files.lisp, 31-Jan-90 11:58:15, Edit by Chiles. - Modifed all occurrances of "fdstream" to "fd-stream" to be consistent with - new interface. - -.../systems-work/hemlock/mh.lisp, 26-Jan-90 12:41:47, Edit by Chiles. - Fixed bug leaving a file open every time I called MH-PROFILE-COMPONENT, and - closed the process in MH. - -.../systems-work/hemlock/command.lisp, 24-Jan-90 11:06:13, Edit by Chiles. - Changed "Next Line", "Previous Line", "Next Word", "Previous Word", - "Forward Character", "Backward Character", "Delete Next Character", and - "Delete Previous Character" to work with correctly negative arguments. - -.../systems-work/hemlock/macros.lisp, 24-Jan-90 10:40:00, Edit by Chiles. - Modified WITH-POP-UP-DISPLAY to have a doc string other than "Do Some Shit." - -.../systems-work/hemlock/lispbuf.lisp, 22-Jan-90 15:17:49, Edit by Chiles. - Modified code around *prompt* to adhere to new semantics of its values. - -.../hemlock/mh.lisp, 19-Jan-90 21:00:28, Edit by Wlott. - Changed to use new RUN-PROGRAM return values. - -.../systems-work/hemlock/eval-server.lisp, 19-Jan-90 12:07:06, Edit by Chiles. - Modified DO-OPERATION and the thing that aborts operations to handshake on - whether we were in the debugger when we aborted. If we were, output a - message trying to inform the user that the output in his typescript can be - ignored; he is no longer really in the debugger. - -.../systems-work/hemlock/lispeval.lisp, 18-Jan-90 23:21:55, Edit by Chiles. - Fixed "Abort Operations" to really abort the operations (one more time). - -.../systems-work/hemlock/eval-server.lisp, 18-Jan-90 16:45:24, Edit by Chiles. - Made the -slave switch handler setup *gc-notify-before* and *gc-notify-after* - to do gratuitous output to the editor. - -.../systems-work/hemlock/ts-stream.lisp, 18-Jan-90 16:08:00, Edit by Chiles. - Fixed a bug in WAIT-FOR-TYPESCRIPT-INPUT that incorrectly reported input when - the function was re-entered by handling an event in SERVE-EVENT. - -.../systems-work/hemlock/ts-buf.lisp, 18-Jan-90 12:14:40, Edit by Chiles. - Modified TS-BUFFER-OUTPUT-STRING to take a gratuitous-p optional indicating - output should go behind the prompt. - -.../systems-work/hemlock/morecoms.lisp, 17-Jan-90 21:21:53, Edit by Chiles. - Modified DO-RECURSIVE-EDIT to update the modeline field before possibly - signalling an error in the cleanup forms of the UNWIND-PROTECT. - -.../systems-work/hemlock/ts-buf.lisp, 17-Jan-90 15:25:18, Edit by Chiles. - Removed weird disappearing prompt stuff. Added stuff to help users unwedge - themselves when they get behind the prompt. - -.../systems-work/hemlock/streams.lisp, 16-Jan-90 13:42:19, Edit by William. - Made Hemlock output streams make sure the mark is :left-inserting, but only - when actually doing the output. - -.../systems-work/hemlock/morecoms.lisp, 15-Jan-90 09:07:31, Edit by Chiles. - Modified "Count Lines" and "Count Words" to report lines counted as being in - the active region or after the point. - -.../systems-work/hemlock/eval-server.lisp, 15-Jan-90 13:09:19, Edit by Wlott. - Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT. - - Added tweeking of *standard-output* and friends in addition to - *terminal-io* when connecting to a slave. - - -.../systems-work/hemlock/lispeval.lisp, 15-Jan-90 14:13:56, Edit by Wlott. - Made FILE-COMPILE pay attention to "Remote Compile File". (I must have been - brain-dead the first time through that code...) - -.../systems-work/hemlock/files.lisp, 15-Jan-90 15:21:36, Edit by Wlott. - Changed write-file to be faster. - -.../systems-work/hemlock/srccom.lisp, 13-Jan-90 14:42:07, Edit by Chiles. - Made "Merge Buffers" have an (A)lign window with start of difference display - option in the command loop. I often had to use recursive edit to be able to - position the window to see the difference that was otherwise not visible due - to normal scrolling and redisplay centering the mark. - -.../systems-work/hemlock/srccom.lisp, 13-Jan-90 14:00:25, Edit by Chiles. - Fixed "Compare Buffers" and "Merge Buffers" to test for a nil result when - calling LINE-OFFSET. When buffers weren't terminated with newlines, the old - code would infinitely loop. - -.../systems-work/hemlock/lispmode.lisp, 12-Jan-90 18:29:20, Edit by Chiles. - Modified SCAN-DIRECTION-VALID to check for the ignore region falling off the - end of the line which caused %FORM-OFFSET to infinitely loop. - -.../systems-work/hemlock/ts-stream.lisp, 12-Jan-90 12:47:37, Edit by Wlott. - Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT. - -.../systems-work/hemlock/tty-disp-rt.lisp, 11-Jan-90 19:31:46, Edit by Wlott. - Changed to work with fdstreams. - -.../systems-work/hemlock/rompsite.lisp, 11-Jan-90 16:42:02, Edit by Wlott. - Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT. - -.../systems-work/hemlock/tty-screen.lisp, 09-Jan-90 14:27:17, Edit by Chiles. - When we make a random typeout window, we no longer say the screen image is - trashed. Some uses of pop up displays do output and then prompt inside the - form, and this prompting was causing the main window to be redisplayed since - we said the screen image was trashed. This drew over our pop up display. - -.../systems-work/hemlock/indent.lisp, 08-Jan-90 10:20:48, Edit by Mbb. - Made "Center Line" use the active region. - -.../systems-work/hemlock/bit-screen.lisp, 05-Jan-90 17:07:23, Edit by Mbb. - REVERSE-VIDEO-HOOK-FUN was calling the wrong function. - -.../systems-work/hemlock/eval-server.lisp, 01-Dec-89 17:58:53, Edit by Chiles. - Fixed a bug in SERVER-DIED that prevented it from deleting variables - referencing dead server-infos. - -.../systems-work/hemlock/ts-buf.lisp, 01-Dec-89 17:06:22, Edit by Chiles. - Modified and documented TYPESCRIPTIFY-BUFFER to make a local "Current Eval - Server" variable. - -.../systems-work/hemlock/eval-server.lisp, 01-Dec-89 16:29:25, Edit by Chiles. - GET-CURRENT-EVAL-SERVER cleaned up. "Select Slave" rewritten to no longer - set current eval server. - -.../systems-work/hemlock/eval-server.lisp, 22-Nov-89 15:51:42, Edit by Mbb. - Just someone forgetting the result argument to THROW. The old defmacro - compiler stuff didn't catch this, so it used to pass (and amazingly, work). - -.../systems-work/hemlock/morecoms.lisp, 22-Nov-89 15:31:29, Edit by Mbb. - Somehow, the old "Count Lines" worked. How, I don't know. It had an IF - without a THEN clause, which is required by ClTM. The new DEFMACRO stuff - caught it. - -.../systems-work/hemlock/mh.lisp, 27-Oct-89 11:49:25, Edit by Chiles. - After recently eliminating recursive folder support, "List Folders" continued - to claim it would list all folders recursively. Removed useless code and - bogus doc string. - -.../systems-work/hemlock/diredcoms.lisp, 25-Oct-89 16:15:29, Edit by Chiles. - Picked up Blaine's changes to make "Dired" and "Dired with Pattern" do dot - files with an argument. This propagates to subdirectories. - -.../systems-work/hemlock/lisp-lib.lisp, 25-Oct-89 15:59:19, Edit by Chiles. - Made browser look in new library location. - -.../systems-work/hemlock/lispeval.lisp, 29-Sep-89 15:52:50, Edit by Chiles. - Fixed a bug in "Abort Operations" and documented how it works. - -.../systems-work/hemlock/mh.lisp, 28-Sep-89 15:37:39, Edit by Chiles. - Modified "Headers Delete Message" to be prepared to deal with a list of - message ID's when in a message buffer. - -.../systems-work/hemlock/eval-server.lisp, 22-Sep-89 11:28:02, Edit by Chiles. - Made SERVER-COMPILE-TEXT do a TERPRI on error-output since the background - buffer was incredibly hard to read when compiling single defuns. - -.../systems-work/hemlock/rompsite.lisp, 20-Sep-89 00:39:06, Edit by Chiles. - Installed WITHOUT-HEMLOCK from code:lispinit.lisp. This had to be part of - Hemlock, as it should have been, so expansions of it during compilation of - Hemlock would no longer cause hardwired references to bogus "OLD-HI" symbols. - -.../systems-work/hemlock/doccoms.lisp, 19-Sep-89 20:15:26, Edit by Chiles. -.../clisp-1/systems-work/hemlock/echo.lisp, 19-Sep-89 20:06:56, Edit by Chiles. - Replaced ~C FORMAT directives with ~:C to adhere to new standard. - -/usr2/ch/lisp/echocoms.lisp, 11-Sep-89 21:21:46, Edit by Christopher Hoover. - Made "Complete Field" and "Complete Keyword" do the same thing for - parse types of :file. - -/usr1/lisp/hemlock/searchcoms.lisp, 18-Sep-89 12:56:33, Edit by Chiles. - When we fixed QUERY-REPLACE-LOOP to use a permanent marker for the end mark, - we destroyed the current region effect when the current mark was before the - current point. I fixed this to be a permanent mark that is a copy of the end - mark of the region within which we replace things. - -/usr1/lisp/hemlock/mh.lisp, 15-Sep-89 11:30:56, Edit by Chiles. - Blew away "-recurse" from CHECK-FOLDER-NAME-TABLE. - -/usr1/lisp/hemlock/macros.lisp, 14-Sep-89 12:18:47, Edit by Chiles. - Fixed bug in DO-STRINGS introduced with the new string table stuff a few - months ago. It spliced the result form after a DOTIMES instead inside it, so - RETURN's inside the DO-STRING's returned the result form instead of the - returned values. - -/usr/lisp/hemlock/ts-stream.lisp, 13-Sep-89 19:07:27, Edit by Wlott. - Fixed bug in %TS-STREAM-SOUT that caused the character position to become - confused. - -/usr1/lisp/hemlock/lispeval.lisp, 08-Sep-89 11:59:16, Edit by Chiles. - Changed "Forget Compiler ..." to "Flush ...". - -/usr1/lisp/hemlock/diredcoms.lisp, 03-Sep-89 17:39:07, Edit by Chiles. - Stopped DIRED-DOWN-LINE from moving the mark to the beginning of the line. - -/usr1/lisp/hemlock/macros.lisp, 01-Sep-89 10:50:03, Edit by Chiles. - Proclaimed *buffer-names* special. - -/usr1/lisp/hemlock/rompsite.lisp, 27-Aug-89 12:26:44, Edit by Chiles. - Removed BUILD-HEMLOCK. Created load-hem.lisp. - -/usr1/lisp/nhem/rompsite.lisp, 25-Aug-89 11:17:01, Edit by Chiles. - Added LOAD's for new TCP/eval server files. - - Removed old eval server stuff. - - -/usr1/lisp/nhem/eval-server.lisp, 25-Aug-89 11:16:29, Edit by Chiles. - This is a new file. - -/usr1/lisp/nhem/ts-stream.lisp, 25-Aug-89 09:56:46, Edit by Chiles. - This is a new file. - -/usr1/lisp/nhem/ts.lisp, 24-Aug-89 16:35:30, Edit by Chiles. - Basically a new file for interfacing to the new typescript streams. - -/usr1/lisp/nhem/lispeval.lisp, 24-Aug-89 16:16:25, Edit by Chiles. - This is effectively a new file for use with TCP eval servers. - -/usr1/lisp/nhem/lispbuf.lisp, 24-Aug-89 16:07:34, Edit by Chiles. - Added "Editor" mode to this file. - -/usr1/lisp/nhem/edit-defs.lisp, 24-Aug-89 15:57:28, Edit by Chiles. - Updated definition fetching code to use DO-EVAL-FORM instead of - EVAL_FORM-IN-CLIENT. - -/usr1/lisp/nhem/echo.lisp, 24-Aug-89 15:54:00, Edit by Chiles. - Moved LOUD-MESSAGE here from lispeval.lisp and exported it. - -/usr1/lisp/nhem/bindings.lisp, 24-Aug-89 15:51:31, Edit by Chiles. - Commented out binding for "Abort Typescript Input". - - Added bindings for "Next Compiler Error" and "Previous Compiler Error". - - Changed some names "Process Control ..." to "Typescript Slave ...". - - -/usr1/lisp/hemlock/struct.lisp, 16-Aug-89 15:09:14, Edit by Chiles. - Removed - (:print-function ...) - forms for structures that included another structure and explicitly - specified the included functions print fucntion. It is now in the standard - and our system that these should automatically be inherited. - -/usr1/lisp/nhem/bit-screen.lisp, 28-Jul-89 14:42:20, Edit by Chiles. - Blaine fixed his fix to the "Reverse Video" hook for the new pop-up displays. - -/usr1/lisp/nhem/morecoms.lisp, 28-Jul-89 13:45:33, Edit by Chiles. - Restored old definition of "Capitalize Word" and made it loop until it finds - the first alphabetic character in the word instead of assuming the first - character is capitalizable. - -/usr1/lisp/nhem/filecoms.lisp, 27-Jul-89 10:09:56, Edit by Chiles. - Blaine made "Log Change" check that the initial buffer still exists before - going to it. - -/usr1/lisp/nhem/command.lisp, 26-Jul-89 17:49:32, Edit by Chiles. - Rewrote "Universal Argument", "Argument Digit", "Negative Argument". This - fixes the bug M-- M-1 M-2 yielding -8 instead of -12. Now "Universal - Argument" strips bits off every character it reads, and it no longer goes - through the command loop on repeated C-U input. The other two commands - basically setup to jump into "Universal Argument". This means to things: - 1] You no longer can type minus signs after every C-u. - 2] When typing digits, you cannot invoke any commands bound to - a first digit with modifier bits. This should be no big deal. - -/usr1/lisp/hemlock/syntax.lisp, 14-Jul-89 15:26:51, Edit by Chiles. -/usr1/lisp/hemlock/buffer.lisp, 14-Jul-89 15:17:25, Edit by Chiles. -/usr1/lisp/hemlock/vars.lisp, 14-Jul-89 14:31:34, Edit by Chiles. -/usr1/lisp/hemlock/main.lisp, 14-Jul-89 14:33:27, Edit by Chiles. - Moved *global-variable-names* back to main.lisp from vars.lisp since vars is - loaded before table.lisp which defines MAKE-STRING-TABLE. - - Moved *buffer-names* and *mode-names* back to main.lisp for above reason. - - *command-names* from interp. - - *character-attribute-names from syntax. - - -/usr1/lisp/nhem/font.lisp, 11-Jul-89 15:49:59, Edit by Chiles. - Modified NEW-FONT-MARK to terminate a loop correctly and to stop calling - DIS-LINE-LINE on nil. - -/../victoria/usr2/lisp/hemlock/bit-screen.lisp, 09-Jul-89 15:51:46, Edit by Mbb. - Made REVERSE-VIDEO-HOOK-FUN do the right thing for random typeout - windows. I, uhhhh.., kind of missed this. - - Removed an extraneaous variable binding that was causing a "Bound but not - referenced error." - - -/usr1/lisp/nhem/completion.lisp, 07-Jul-89 13:00:47, Edit by Chiles. - #\' is no longer a completion-wordchar in "Lisp" mode. Just an oversight. - -/usr/lisp/hemlock/rompsite.lisp, 07-Jul-89 16:18:51, Edit by Mbb. - Replaced call to INVOKE-HOOK with DOLIST since this is compiled before - macros.lisp, analogous to using VARIABLE-VALUE instead of VALUE. - -/usr/lisp/hemlock/htext1.lisp, 07-Jul-89 16:06:08, Edit by Mbb. -/usr/lisp/hemlock/htext4.lisp, 07-Jul-89 16:06:08, Edit by Mbb. - Frobbed MOVE-SOME-MARKS in htext1.lisp to allow declarations within the - body. Added declarations using this macro in htext4. Also gratuitously - changed the indentation in htext4 of MOVE-SOME-MARKS (To screw file - comparison.) - -/usr/lisp/hemlock/tty-screen.lisp, 07-Jul-89 14:29:53, Edit by Mbb. - Renamed MAKE-DEVICE to MAKE-TTY-DEVICE. - -/usr/lisp/hemlock/struct.lisp, 07-Jul-89 14:19:16, Edit by Mbb. -/usr/lisp/hemlock/bit-display.lisp, 07-Jul-89 14:15:42, Edit by Mbb. -/usr/lisp/hemlock/tty-display.lisp, 07-Jul-89 14:20:47, Edit by Mbb. - Moved device and hunk stuff into struct.lisp. - -/usr/lisp/hemlock/echo.lisp, 07-Jul-89 11:19:23, Edit by Mbb. - Made PROMPTING-MERGE-PATHNAMES work. It used to choke if - pathname-defaults was NIL. - - Moved definition of hemlock-eof from main.lisp to echo.lisp, where it - belongs. - - -/usr/lisp/hemlock/rompsite.lisp, 06-Jul-89 16:20:13, Edit by Mbb. - Moved constant definition of font-map-size from font.lisp to - rompsite.lisp because SETUP-FONT-FAMILY assumed that it was a special. - -/usr/lisp/hemlock/rompsite.lisp, 06-Jul-89 13:21:21, Edit by Mbb. - Moved definitions of *editor-input*, *last-character-typed*, and - *character-history* from main.lisp to rompsite.lisp, where they belong, - and exported them. - -/usr/lisp/hemlock/window.lisp, 06-Jul-89 13:16:55, Edit by Mbb. - Moved definitions of *current-window* and *window-list* from main.lisp to - window.lisp, exporting *window-list*. - -/usr/lisp/hemlock/interp.lisp, 06-Jul-89 13:09:29, Edit by Mbb. - Moved definitions of *command-names*, *prefix-argument-supplied*, and - *prefix-argument* from main.lisp to interp.lisp, exporting *command-names*. - -/usr/lisp/hemlock/buffer.lisp, 06-Jul-89 12:59:36, Edit by Mbb. - Moved definitions of *buffer-names*, *buffer-list*, *current-buffer*, and - *mode-names* from main.lisp to buffer.lisp, exporting all but - *current-buffer*. - -/usr/lisp/hemlock/vars.lisp, 06-Jul-89 12:09:46, Edit by Mbb. - Moved definition of *global-variable-names* from main.lisp to vars.lisp, - where it belongs, and exported it. - -/usr/lisp/hemlock/syntax.lisp, 06-Jul-89 11:57:48, Edit by Mbb. - Moved *last-character-attibute-requested*, *character-attribute-names*, - *value-of-last-character-attribute-requested*, and *character-attributes* - from main.lisp to syntax.lisp, exporting *character-attribute-names*. - - Proclaimed the following variables special: - (*mode-names* *current-buffer* *last-character-attribute-requested* - *value-of-last-character-attribute-requested*). - - -/usr/lisp/hemlock/struct.lisp, 06-Jul-89 11:48:59, Edit by Mbb. - Removed definitions of now-tick and TICK and put them in htext1.lisp, - exporting now-tick. - -/usr/lisp/hemlock/killcoms.lisp, 06-Jul-89 09:40:29, Edit by Mbb. - Proclaimed the following variable special: *delete-char-region*. - -/usr/lisp/hemlock/echocoms.lisp, 06-Jul-89 09:33:57, Edit by Mbb. - Proclaimed the following variable special: *kill-ring*. - -/usr/lisp/hemlock/window.lisp, 05-Jul-89 16:39:31, Edit by Mbb. - Proclaimed the following variable special: *buffer-list*. - -/usr/lisp/hemlock/tty-screen.lisp, 05-Jul-89 16:37:06, Edit by Mbb. - Proclaimed the following variable special: *parse-starting-mark*. - -/usr/lisp/hemlock/screen.lisp, 05-Jul-89 16:30:31, Edit by Mbb. - Proclaimed the following variable special: *echo-area-buffer*. - -/usr/lisp/hemlock/display.lisp, 05-Jul-89 16:28:18, Edit by Mbb. - Proclaimed the following variable special: *window-list*. - - Moved device and hunk structure definitions to struct.lisp. - - -/usr/lisp/hemlock/hunk-draw.lisp, 05-Jul-89 16:24:18, Edit by Mbb. - Proclaimed the following variables special: - (*default-border-pixmap* *highlight-border-pixmap*). - -/usr/lisp/hemlock/cursor.lisp, 05-Jul-89 16:15:50, Edit by Mbb. - Proclaimed the following variable special: the-sentinel. - -/usr/lisp/hemlock/linimage.lisp, 05-Jul-89 16:12:41, Edit by Mbb. - Proclaimed the following variable special: *character-attributes*. - -/usr/lisp/hemlock/macros.lisp, 05-Jul-89 16:10:00, Edit by Mbb. - Proclaimed the following variable special: *echo-area-stream*. - -/usr/lisp/hemlock/rompsite.lisp, 05-Jul-89 16:02:53, Edit by Mbb. - Proclaimed the following variables special: - (FONT-MAP-SIZE *DEFAULT-FONT-FAMILY* *CURRENT-WINDOW* *INPUT-TRANSCRIPT* - *FOREGROUND-BACKGROUND-XOR* *ECHO-AREA-WINDOW* *BUFFER-NAMES* - HEMLOCK::*CREATED-SLAVE-CONNECTED* *CHARACTER-HISTORY* - *SCREEN-IMAGE-TRASHED*). - -/usr/lisp/hemlock/struct-ed.lisp, 05-Jul-89 15:42:36, Edit by Mbb. -/usr/lisp/hemlock/lispeval.lisp, 05-Jul-89 15:42:36, Edit by Mbb. - Created this file for structures that are only used in the HEMLOCK - package. Moved SERVER-INFO structure from lispeval.lisp to this file. - -/usr/lisp/hemlock/rompsite.lisp, 05-Jul-89 15:34:21, Edit by Mbb. - Moved the package initialization stuff from rompsite.lisp to ctw.lisp, as - this is where it should be. - -/usr2/lisp/hemlock/pop-up-stream.lisp, 05-Jul-89 14:07:55, Edit by Mbb. -/usr2/lisp/hemlock/struct.lisp, 05-Jul-89 14:07:55, Edit by Mbb. - Moved the POP-UP-STREAM structure to struct.lisp. - -/usr1/mbb/lisp/work/screen.lisp, 03-Jul-89 17:05:58, Edit by Mbb. - Made RANDOM-TYPEOUT-CLEANUP clean up the modeline field instead of doing - it in both the tty and bitmap cleanup methods. - -/usr1/mbb/lisp/work/pop-up-stream.lisp, 03-Jul-89 15:53:13, Edit by Mbb. - Made misc methods for line-buffered and full-buffered streams distinct. - FORCE-OUTPUT and FINISH-OUTPUT are now no-ops for full-buffered streams. - -/usr1/mbb/lisp/work/macros.lisp, 03-Jul-89 15:43:19, Edit by Mbb. - Made GET-RANDOM-TYPEOUT-INFO assign distinct misc methods to - full-buffered and line-buffered random-typeout streams. - -/usr1/lisp/nhem/window.lisp, 02-Jul-89 15:54:40, Edit by Chiles. - Added "Maximum Modeline Pathname Length" which defaults to nil. Wrote - BUFFER-PATHNAME-ML-FIELD-FUN. - -/usr1/lisp/nhem/morecoms.lisp, 02-Jul-89 16:09:45, Edit by Chiles. - Made "Defhvar" propagate any existing hooks as well. - -/usr1/lisp/nhem/vars.lisp, 02-Jul-89 15:04:33, Edit by Chiles. -/usr1/lisp/nhem/syntax.lisp, 02-Jul-89 15:02:25, Edit by Chiles. -/usr1/lisp/nhem/main.lisp, 02-Jul-89 14:55:14, Edit by Chiles. -/usr1/lisp/nhem/display.lisp, 02-Jul-89 14:43:59, Edit by Chiles. -/usr1/lisp/nhem/buffer.lisp, 02-Jul-89 14:38:55, Edit by Chiles. - Replaced occurrences of DOLIST used to invoke hook functions with the new - INVOKE-HOOK. - -/usr1/lisp/nhem/window.lisp, 02-Jul-89 15:06:35, Edit by Chiles. -/usr1/lisp/nhem/vars.lisp, 02-Jul-89 15:04:33, Edit by Chiles. -/usr1/lisp/nhem/syntax.lisp, 02-Jul-89 15:02:25, Edit by Chiles. -/usr1/lisp/nhem/searchcoms.lisp, 02-Jul-89 14:59:43, Edit by Chiles. -/usr1/lisp/nhem/screen.lisp, 02-Jul-89 14:58:52, Edit by Chiles. -/usr1/lisp/nhem/rompsite.lisp, 02-Jul-89 14:57:44, Edit by Chiles. -/usr1/lisp/nhem/mh.lisp, 02-Jul-89 14:56:23, Edit by Chiles. -/usr1/lisp/nhem/main.lisp, 02-Jul-89 14:55:14, Edit by Chiles. -/usr1/lisp/nhem/interp.lisp, 02-Jul-89 14:52:04, Edit by Chiles. -/usr1/lisp/nhem/htext1.lisp, 02-Jul-89 14:49:28, Edit by Chiles. -/usr1/lisp/nhem/filecoms.lisp, 02-Jul-89 14:41:23, Edit by Chiles. -/usr1/lisp/nhem/buffer.lisp, 02-Jul-89 14:36:54, Edit by Chiles. -/usr1/lisp/nhem/bit-screen.lisp, 02-Jul-89 14:33:21, Edit by Chiles. - Replaced occurrences of - "invoke-hook* '" - with - "invoke-hook ". - - Replaced occurrences of - "invoke-hook '" - with - "invoke-hook ". - - -/usr1/lisp/nhem/vars.lisp, 02-Jul-89 14:30:55, Edit by Chiles. - Deleted function definition for INVOKE-HOOK. - -/usr1/lisp/nhem/macros.lisp, 02-Jul-89 13:45:37, Edit by Chiles. - Wrote macro INVOKE-HOOK that replaces INVOKE-HOOK* and is exported. - -/usr1/lisp/nhem/bit-screen.lisp, 29-Jun-89 11:26:19, Edit by Chiles. - Fixed INIT-BITMAP-DEVICE to drop any pending events on the floor, so - accidental input while not in Hemlock is ignored. - -/usr1/lisp/nhem/lispeval.lisp, 29-Jun-89 10:54:17, Edit by Chiles. - Made default value for "Remote Compile File" be nil. - -/usr1/lisp/nhem/window.lisp, 29-Jun-89 10:43:26, Edit by Chiles. - Moved the :modifiedp modeline-field to be between the modes and buffer name. - Modified the :modifiedp and :buffer-pathname update functions accordingly. - -/usr1/lisp/nhem/macros.lisp, 29-Jun-89 10:12:25, Edit by Chiles. - Fixed GET-RANDOM-TYPEOUT-INFO: it now supplies "Fundamental" only for the - random typeout buffer's modes, and the delete hook is now a compiled function - instead of interpreted. - -/usr1/lisp/nhem/pop-up-stream.lisp, 28-Jun-89 16:41:56, Edit by Chiles. - Fixed a bug in RANDOM-TYPEOUT-MISC that called redisplay on the pop-up window - when it didn't exist. When the stream is full-buffered, and no previous - random typeout has occurred for a given buffer, the window slot in the stream - is nil. This should be fixed better than I have done. - -/usr1/lisp/nhem/lispmode.lisp, 28-Jun-89 16:38:40, Edit by Chiles. - Added DEFINDENT for WITH-POP-UP-DISPLAY. - -/usr1/mbb/lisp/work/bit-screen.lisp, 22-Jun-89 20:11:59, Edit by Mbb. - The device dependant random-typeout-cleanup methods were fixing up the - modeline, but this is device independant, so I moved it to screen.lisp. - -/usr1/mbb/lisp/work/screen.lisp, 22-Jun-89 19:58:08, Edit by Mbb. - RANDOM-TYPEOUT-CLEANUP now sets the Random Typeout buffer's modeline - field to :normal. Before it lost on a Keep character in a more. - -/usr1/mbb/lisp/work/pop-up-stream.lisp, 22-Jun-89 19:48:12, Edit by Mbb. - Fixed NO-TEXT-PAST-BOTTOM-P to work. It previously choked when there - were no newlines in the buffer. - -/usr1/mbb/lisp/work/rompsite.lisp, 22-Jun-89 19:45:54, Edit by Mbb. - Made END-RANDOM-TYPEOUT do a more-prompt, in case the user didn't give us - a newline on his last line of output. This was previously a bug. - -/usr1/mbb/lisp/work/morecoms.lisp, 22-Jun-89 16:21:43, Edit by Mbb. - Made "Capitalize Word" consistent with "Uppercase Word" and "Lowercase - Word". Someone failed to see how easy this was. - -/usr1/mbb/lisp/work/diredcoms.lisp, 22-Jun-89 13:15:07, Edit by Mbb. -/usr1/mbb/lisp/work/rompsite.lisp, 22-Jun-89 13:18:00, Edit by Mbb. - Moved DIRECTORYP from diredcoms.lisp to rompsite.lisp. This is a - generally useful function. - -/usr1/lisp/nhem/searchcoms.lisp, 22-Jun-89 16:29:05, Edit by Chiles. - Fixed a bug in the termination test of the replacement loop. It used to use - a temporary mark to hold onto the end of the region which lost with multiple - replacements on the last line with the end of the region at the end of the - line. - -/usr1/lisp/nhem/bufed.lisp, 22-Jun-89 16:26:59, Edit by Chiles. - Made DELETE-BUFED-BUFFERS a buffer local hook for the bufed buffer. - -/usr1/mbb/lisp/work/filecoms.lisp, 22-Jun-89 10:43:51, Edit by Mbb. - PATHNAME-TO-BUFFER-NAME now returns a string in the form of - <file-namestring pathname> <directory-namestring> pathname. - - Deleted *name/type-separator-character*. - - -/usr1/mbb/lisp/work/echocoms.lisp, 21-Jun-89 17:05:36, Edit by Mbb. - "Complete Keyword" now only merges with the directory of the default, as - opposed to the whole thing. This makes completion look more like the new - confirmation. - -/usr1/mbb/lisp/work/morecoms.lisp, 21-Jun-89 21:45:05, Edit by Mbb. - Made "List Buffers" tabulate it's output. It looks better that way. - -/usr1/mbb/lisp/work/echo.lisp, 21-Jun-89 15:50:43, Edit by Mbb. - Made FILE-VERIFICATION-FUNCTION allow merging of relative pathnames and - nearly honest-to-goodness UNIX pathnames. Eliminated all file-name and - file-type merging, only merging with default directory. However, if the user - only inputs a directory spec, then he could only mean to pick up the - file-namestring from the defaults. - -/usr1/mbb/lisp/work/mh.lisp, 21-Jun-89 11:36:24, Edit by Mbb. -/usr1/mbb/lisp/work/rompsite.lisp, 21-Jun-89 11:41:52, Edit by Mbb. - I moved MERGE-RELATIVE-PATHNAMES from mh.lisp to rompsite.lisp and - exported it for its general usefulness. - -/usr1/lisp/hemlock/bindings.lisp, 21-Jun-89 13:44:07, Edit by Chiles. - Added bindings for "Completion" mode. - -/usr1/lisp/nhem/mh.lisp, 19-Jun-89 18:58:03, Edit by Chiles. - Modified MH once again to supply nil and nil for the group and account - information to RFS-AUTHENTICATE. - -/usr1/lisp/nhem/bindings.lisp, 19-Jun-89 16:28:48, Edit by Chiles. - Changed binding of "Select Random Typeout Buffer". - -/usr1/lisp/nhem/morecoms.lisp, 19-Jun-89 16:26:21, Edit by Chiles. - "List Buffers" no longer shows random typeout buffers. - -/usr1/mbb/lisp/work/pop-up-stream.lisp, 19-Jun-89 14:02:04, Edit by Mbb. - Made line-buffered-moreing work. A last minute fix before I it went into - the last core broke this. - -/usr1/mbb/lisp/work/pop-up-stream.lisp, 18-Jun-89 13:26:12, Edit by Mbb. - Added :charpos feature to the RANDOM-TYPEOUT-MISC method because format - uses it to implement tabbing. - -/usr1/mbb/lisp/work/lispbuf.lisp, 18-Jun-89 12:19:52, Edit by Mbb. - Made "Editor Describe Function Call" not supply a height to - WITH-POP-UP-DISPLAY. - -/usr1/mbb/lisp/work/spellcoms.lisp, 16-Jun-89 17:47:30, Edit by Mbb. - Added a height specification to the WITH-POP-UP-DISPLAY call in - GET-WORD-CORRECTION so the stream would be line-buffered, and thus visible. - -/usr1/mbb/lisp/work/macros.lisp, 16-Jun-89 17:27:38, Edit by Mbb. -/usr1/mbb/lisp/work/pop-up-stream.lisp, 16-Jun-89 17:27:08, Edit by Mbb. - Added FORCE-OUTPUT and FINISH-OUTPUT functionality to Random Typeout - Streams. - -/usr1/mbb/lisp/work/morecoms.lisp, 16-Jun-89 17:24:15, Edit by Mbb. - Made "Point to here" issue the traditional "I'm afraid I can't let you do - that Dave." message when the usere tries to make the special Random - Typeout window current. - -/usr1/lisp/hemlock/diredcoms.lisp, 16-Jun-89 01:20:44, Edit by Chiles. - Fixed "Copy File" and "Rename File" to no longer think they run in dired - buffers. - -/usr1/lisp/hemlock/bindings.lisp, 16-Jun-89 01:07:54, Edit by Chiles. - Added binding for "Select Random Typeout Buffer". - -/usr1/lisp/hemlock/bindings.lisp, 15-Jun-89 16:59:15, Edit by Chiles. - Defined #\K to be a :keep logical character. - -/usr1/lisp/hemlock/echo.lisp, 15-Jun-89 16:43:16, Edit by Chiles. - Added definition for "Keep" logical character. - -/usr1/lisp/nhem/mh.lisp, 15-Jun-89 13:14:00, Edit by Chiles. - Modified INCORPORATE-NEW-MAIL to better detect mistyped passwords with new MH - error messages. - -/usr/lisp/hemlock/lisp-lib.lisp, 12-Jun-89 14:55:16, Edit by Mbb. - Made "Lisp Library Help" consistent with "Bufed" and other modes that now - use the mode-description mechanism. - -/usr/lisp/hemlock/window.lisp, 07-Jun-89 16:56:02, Edit by Mbb. - Fixed a bug in WINDOW-FOR-HUNK that prevented anyone from making a window - 1 character high. - -/usr/lisp/hemlock/pop-up-stream.lisp, 07-Jun-89 19:10:17, Edit by Mbb. - This file replaces tty-stream.lisp and bit-stream.lisp and does essentially - the same thing, but in a completely different way. - -/usr/lisp/hemlock/display.lisp, 07-Jun-89 18:32:56, Edit by Mbb. - Added two slots to the device structure: random-typeout-full-more and - random-typeout-line-more. These are called from the random typeout - stream output methods to give users a neat scrolling effect on a bitmap, and - on the tty they just clear the window and draw some more lines from the top. - -/usr/lisp/hemlock/display.lisp, 07-Jun-89 18:32:56, Edit by Mbb. - Made %PRINT-DEVICE-HUNK not choke when the hunk has no associated window. - -/usr/lisp/hemlock/mh.lisp, 07-Jun-89 18:30:05, Edit by Mbb. - Made the NEW-MAIL-BUF-DELETE-HOOK ignore buffer so the compiler doesn't - warn that it was "bound but not referenced". - -/usr/lisp/hemlock/bit-screen.lisp, 07-Jun-89 14:52:45, Edit by Mbb. - Made BITMAP-RANDOM-TYPEOUT-SETUP create a psuedo-window to display a random - typeout buffer. Also made BITMAP-RANDOM-TYPEOUT-CLEANUP do the right - thing. Two functions were added to deal with the pseudo-window: - MAKE-TTY-RANDOM-TYPEOUT-WINDOW and CHANGE-TTY-RANDOM-TYPEOUT-WINDOW. - -/usr/lisp/hemlock/tty-screen.lisp, 07-Jun-89 14:26:48, Edit by Mbb. - Made TTY-RANDOM-TYPEOUT-SETUP create a psuedo-window to display a random - typeout-buffer. Also made TTY-RANDOM-TYPEOUT-CLEANUP do the right thing. - Two functions were added to deal with the psuedo-window : - MAKE-BITMAP-RANDOM-TYPEOUT-WINDOW and CHANGE-BITMAP-RANDOM-TYPEOUT-WINDOW. - -/usr/lisp/hemlock/screen.lisp, 07-Jun-89 15:07:50, Edit by Mbb. - Modified PREPARE-FOR-RANDOM-TYPEOUT and RANDOM-TYPEOUT-CLEANUP to - implement the new mechanism. Also added the modeline field definitions - for random typeout buffers. - -/usr1/lisp/nhem/keytran.lisp, 05-Jun-89 12:53:12, Edit by Chiles. - Fixed a bugt in DEFINE-KEYSYM that alwyas ignores shifted characters. - -/usr1/lisp/nhem/rompsite.lisp, 02-Jun-89 11:54:20, Edit by Chiles. - Made FUN-DEFINED-FROM-PATHNAME not string-downcase the file. - -/usr/lisp/hemlock/spellcoms.lisp, 31-May-89 20:46:54, Edit by Mbb. -/usr/lisp/hemlock/searchcoms.lisp, 31-May-89 20:44:59, Edit by Mbb. -/usr/lisp/hemlock/scribe.lisp, 31-May-89 20:44:14, Edit by Mbb. -/usr/lisp/hemlock/register.lisp, 31-May-89 20:42:46, Edit by Mbb. -/usr/lisp/hemlock/morecoms.lisp, 31-May-89 20:41:30, Edit by Mbb. -/usr/lisp/hemlock/mh.lisp, 07-Jun-89 18:30:05, Edit by Mbb. -/usr/lisp/hemlock/lispeval.lisp, 31-May-89 20:36:12, Edit by Mbb. -/usr/lisp/hemlock/lispbuf.lisp, 31-May-89 20:30:34, Edit by Mbb. -/usr/lisp/hemlock/lisp-lib.lisp, 12-Jun-89 14:55:16, Edit by Mbb. -/usr/lisp/hemlock/filecoms.lisp, 31-May-89 20:21:59, Edit by Mbb. -/usr/lisp/hemlock/echocoms.lisp, 31-May-89 20:19:14, Edit by Mbb. -/usr/lisp/hemlock/echo.lisp, 05-Jun-89 15:58:14, Edit by Mbb. -/usr/lisp/hemlock/doccoms.lisp, 31-May-89 20:13:38, Edit by Mbb. -/usr/lisp/hemlock/abbrev.lisp, 31-May-89 19:55:20, Edit by Mbb. - Changed occurences of WITH-RANDOM-TYPEOUT to WITH-POP-UP-DISPLAY. - -/usr1/lisp/nhem/bit-screen.lisp, 31-May-89 21:41:02, Edit by Chiles. - The following functions were modified to accomodate using the extra space at - the bottom of a window when there is no thumb bar: - WRITE-N-EXPOSED-REGIONS - WRITE-ONE-EXPOSED-REGION - HUNK-PROCESS-INPUT - MAYBE-PROMPT-USER-FOR-WINDOW - BITMAP-RANDOM-TYPEOUT-SETUP *** Merge with Blaine. - DEFAULT-CREATE-WINDOW-HOOK - DEFAULT-CREATE-INITIAL-WINDOWS-HOOK - BITMAP-MAKE-WINDOW - SET-HUNK-SIZE - -/usr/lisp/hemlock/macros.lisp, 31-May-89 19:29:21, Edit by Mbb. - Defined the macro WITH-POP-UP-DISPLAY that replaces WITH-RANDOM-TYPEOUT. - The new machanism stuffs output into a real hemlock buffer and a pseudo - window so users can get to it if they need to. - -/usr/lisp/hemlock/rompsite.lisp, 31-May-89 15:35:11, Edit by Mbb. - Rewrote WAIT-FOR-MORE and END-RANDOM-TYPEOUT, and added - MAYBE-KEEP-RANDOM-TYPEOUT-WINDOW, that will finish output and keep the - random typeout window if we're on a bitmap-device. - - Added random-typeout-xevents-mask constant. - - -/usr1/lisp/nhem/hunk-draw.lisp, 31-May-89 14:19:46, Edit by Chiles. - Introduced hunk-thumb-bar-bottom-border, 10, and set hunk-bottom-border to 3. - Modified hunk-draw-bottom-border accordingly. - -/usr1/lisp/nhem/bit-screen.lisp, 31-May-89 10:00:56, Edit by Chiles. - Modified HUNK-PROCESS-INPUT to use extra bits below bottom line and above - thumb bar as part of the bottom line. This should eliminate problems with - mouse scrolling and point-to-here functionality which otherwise would beep - causing the user to move the mouse up a tiny bit. - -/usr1/lisp/nhem/lispbuf.lisp, 26-May-89 14:21:11, Edit by Chiles. - Made "Select Eval Buffer" supply a buffer local delete hook that sets the - special to nil, so Hemlock doesn't hold onto that memory. - -/usr1/lisp/nhem/buffer.lisp, 26-May-89 14:18:50, Edit by Chiles. - Modified MAKE-BUFFER to check the type of the :delete-hook arg. - -/usr1/ch/lisp/complete/table.lisp, 17-Apr-89 18:41:11, Edit by Hoover. - Exported STRING-TABLE-SEPARATOR. - - Fixed a bug in FIND-LONGEST-COMPLETION which made COMPLETE-STRING - think some :COMPLETE completions were :UNIQUE. - - -/usr1/lisp/nhem/mh.lisp, 19-May-89 17:36:03, Edit by Chiles. -/usr1/lisp/nhem/dired.lisp, 19-May-89 17:34:35, Edit by Chiles. - Replaced all %SES-NAMESTRING uses with NAMESTRING. - -/usr1/lisp/nhem/unixcoms.lisp, 17-May-89 11:53:05, Edit by Chiles. - Made SCRIBE-FILE move the buffer's point to the end of the buffer. This - still does not do everything you want: - Queue multiple scribe requests. - Leave a stream around all the time that gets cleaned up when the - buffer is deleted, so it can have a disjoint mark from the buffer's - point. The stream is made whenever the buffer is made. - -/usr1/lisp/nhem/diredcoms.lisp, 15-May-89 17:04:50, Edit by Chiles and MBB. - Added "Dired Information" variable and structure instead of N buffer local - variables. Fixed a couple bugs. Modified "Dired" to correctly handle - file-namestring patterns ... prompts separately with argument. Must prompt - separately because cannot know user's intent and must canonicalize names for - uniqueness when looking up dired buffers. - -/usr1/lisp/nhem/xcoms.lisp, 12-May-89 11:35:24, Edit by Chiles. - Fixed bug in "Stack Window", paren mismatched. - -/usr1/lisp/nhem/struct.lisp, 11-May-89 13:41:38, Edit by Chiles. - Modified font-mark printing to use double quotes instead of ``''. - -/usr1/lisp/nhem/interp.lisp, 11-May-89 13:40:05, Edit by Chiles. - Modified command printing to use double quotes instead of ``''. - -/usr1/lisp/nhem/htext2.lisp, 11-May-89 13:37:22, Edit by Chiles. - Modified line, mark, region, and buffer print functions to use double quotes - instead of Scribe ligatures, ``''. Fixed a bug in mark printing that wrote - its last string to *standard-output* instead of the given stream. - -/usr1/lisp/hemlock/mh.lisp, 05-May-89 17:01:39, Edit by DBM. - Wrote "Message Help", "Headers Help", and "Draft Help". - -/usr1/lisp/hemlock/bindings.lisp, 05-May-89 17:03:56, Edit by Chiles. - Added bindings for "Message Help", "Headers Help", and "Draft Help". - -/usr1/lisp/nhem/dired.lisp, 02-May-89 14:20:43, Edit by Chiles. - Fixed a bug in RENAME-FILE not handling a pattern and directory spec - combination correctly. - -/usr1/lisp/nhem/mh.lisp, 26-Apr-89 14:48:45, Edit by Chiles. - Modified doc strings to work better with "Describe Mode". - -/usr1/lisp/nhem/echo.lisp, 25-Apr-89 15:21:21, Edit by Chiles. - Modified PROMPT-FOR-VAR to call CURRENT-VARIABLE-TABLES. Modified - PROMPT-FOR-FILE to look for the typein in the default directory before - merging with the defaults and taking that potentially non-existent file. - Re-order a bunch of stuff and cleaned up page titles. - -/usr1/lisp/nhem/bindings.lisp, 25-Apr-89 13:18:42, Edit by Chiles. - Removed binding (bind-key "Do Nothing" #\super-leftup :mode "Bufed"). - -/usr1/lisp/nhem/bindings.lisp, 24-Apr-89 15:44:17, Edit by Chiles. - Added "View" mode bindings similar to "Message" mode bindings. - -/usr1/lisp/nhem/morecoms.lisp, 24-Apr-89 14:46:36, Edit by Chiles. - Modified "Generic Pointer Up" and "Point to Here". - -/usr1/lisp/nhem/bufed.lisp, 24-Apr-89 14:41:51, Edit by Chiles. - Modified "Bufed Goto and Quit". - -/usr1/lisp/nhem/interp.lisp, 24-Apr-89 14:09:41, Edit by Chiles. - Modified BIND-KEY to provide a restart before signalling an non-existent - command error. - -/usr1/lisp/nhem/searchcoms.lisp, 20-Apr-89 18:35:53, Edit by Chiles. - Rewrote QUERY-REPLACE-FUNCTION, modifying REPLACE-THAT-CASE and creating - QUERY-REPLACE-LOOP, to clean things up. Fixed bug in return values that - broke "Group Query Replace". - -/usr1/lisp/nhem/spellcoms.lisp, 19-Apr-89 14:40:36, Edit by Chiles. - Modified CORRECT-BUFFER-WORD-END to return values other than nil when end and - start were only one character apart. - -/usr1/lisp/hemlock/diredcoms.lisp, 18-Apr-89 14:23:38, Edit by Chiles. - Modified ARRAY-ELEMENT-FROM-MARK to no longer move the mark argument - since it can correctly count the number of lines in the region anyway. - -/usr1/lisp/nhem/diredcoms.lisp, 18-Apr-89 11:11:21, Edit by Chiles. - Rewrote "View Return" and "View Quit" since they didn't interact correctly. - -/usr1/lisp/nhem/xcoms.lisp, 17-Apr-89 15:48:58, Edit by Chiles. - Fixed bug in "Stack Window". It now signals an editor-error unless the - device is a hi::bitmap-device. This command probably should be deleted since - it is somewhat silly and written only for one person. - -/usr1/lisp/nhem/filecoms.lisp, 12-Apr-89 15:19:52, Edit by Chiles. - Made "Revert File" keep buffer's pathname when reverting to checkpoint file. - -/usr1/lisp/nhem/bindings.lisp, 12-Apr-89 14:48:52, Edit by Chiles. - Added binding for "Select Scribe Warnings". - - Deleted bindings of "Goto Dired Buffer" and "Goto Dired Buffer Quitting". - Added "View" mode bindings for "View Return" and "View Quit". - - -/usr1/lisp/nhem/struct.lisp, 12-Apr-89 14:14:12, Edit by Chiles. - Exported and provided a doc string for BUFFER-DELETE-HOOK. - -/usr1/mbb/lisp/nhem/searchcoms.lisp, 11-Apr-89 13:44:13, Edit by Blaine. - Made "Query Replace" and "Replace String" echo how many occurrences are - replaced. - -/usr1/mbb/lisp/nhem/searchcoms.lisp, 11-Apr-89 13:44:13, Edit by Blaine. - Made the doc-strings for "List Matching Lines", "Delete Matcing Lines", - "Delete Non-matching Lines", "Count Occurrences", "Replace String", and - "Query Replace" indicate that they are sensitive to the active-region. - -/usr1/mbb/lisp/nhem/scribe.lisp, 10-Apr-89 22:30:25, Edit by Blaine. - Wrote the "Select Scribe Warnings", which goes to the buffer named "Scribe - Warnings" if it exists. - -/usr1/mbb/lisp/nhem/lisp-lib.lisp, 10-Apr-89 21:39:51, Edit by Blaine. - Made "Describe Library Entry" and "Desribe Pointer Library Entry" put the - user in view mode instead of normal editing mode. Also added the command - ARRAY-ELEMENT-FROM-POINTER-Y-POS which returns an array element whose index - is determined by the y position, in lines, of the pointer. - -/usr1/mbb/lisp/nhem/bufed.lisp, 10-Apr-89 21:29:20, Edit by Blaine. - Fixed a few bugs in Bufed. Made "Bufed Undelete" replace #\D with #\space. - Made "Bufed Goto and Quit" use the pointer location instead of the - current-point. Also made bufed not move the current-point. - -/usr1/mbb/lisp/nhem/diredcoms.lisp, 11-Apr-89 13:22:44, Edit by Blaine. - Fixed bug in UPDATE-DIRED-BUFFER. I was setting "Dired Buffer Files" inside - of a dotimes when it should have been outside. - - Deleted commands "Goto Dired Buffer" and "Goto Dired Buffer Quitting" in lieu - of "View REturn" and "View Quit". - - Wrote "Dired from Buffer Pathname". - - -/usr1/lisp/nhem/mh.lisp, 10-Apr-89 10:20:42, Edit by Chiles. - Modified SUB-WRITE-MH-SEQUENCE to bind *print-base* to 10 when writing - message ID's. - -/usr1/ch/lisp/spell/spell-build.lisp, 08-Apr-89 16:55:52, Edit by Hoover. - Increased max-entry-count-estimate to 15600 in order to build the new - dictionary. Updated filenames in comments and added a line specifying - compilation dependencies. - - Picked up the latest ispell dictionary and merged in local favorites. - This dictionary is available via anonymous ftp from celray.cs.yale.edu - (128.36.0.25) and locally as /../m/usr/misc/.ispell/src/dict.191. - -/usr1/lisp/nhem/lispmode.lisp, 07-Apr-89 16:25:51, Edit by Chiles. - Added DEFINDENT for WITH-WRITABLE-BUFFER. - -/usr1/lisp/nhem/diredcoms.lisp, 07-Apr-89 16:22:05, Edit by Chiles. - Modifed INITIALIZE-DIRED-BUFFER and "Dired" to beep and blow off the dired - when no entries satisfy the spec. - -/usr1/lisp/nhem/echocoms.lisp, 07-Apr-89 10:49:09, Edit by Chiles. - Added "ps" to "Ignore File Types". - -/usr1/lisp/nhem/mh.lisp, 04-Apr-89 00:16:54, Edit by Chiles. - Wrote GET-STORABLE-MSG-BUF-NAME and used it inside SHOW-HEADERS-MESSAGE and - SHOW-MESSAGE-OFFSET-MSG-BUF. - - Removed variable "Deliver Message Deleting Buffers". I modified - DELIVER-DRAFT-BUFFER-MESSAGE to ignore it. This now also always deletes the - draft buffer, regardless of whether this variable is re-installed. Now the - message buffer is always deleted unless it is kept. "Delete Draft and - Buffer" now also always deletes the message buffer unless it is kept. IF the - variable is re-installed this deletion will be guarded by it as well. - - -/usr1/lisp/nhem/bindings.lisp, 03-Apr-89 12:21:51, Edit by Chiles. - Changed binding of "Define Keyboard Macro Key" to C-x M-(. - -/usr1/lisp/nhem/bindings.lisp, 02-Apr-89 16:44:54, Edit by Chiles. - Fixed mail bindings that got switched up or something, "Next Message", "Next - Undeleted Message", "Previous Message", "Previous Undeleted Message". - -/usr1/lisp/nhem/bindings.lisp, 01-Apr-89 16:38:10, Edit by Chiles. - Bound "Bufed" to C-x C-M-b, and changed some c-'s to control-'s. - -/usr1/lisp/nhem/morecoms.lisp, 31-Mar-89 18:24:30, Edit by Chiles. - Wrote "Generic Pointer Up" to replace "Push Mark/Point to Here" and added - ADD-GENERIC-POINTER-UP-FUNCTION. Modified "Point to Here" in accordance. - -/usr1/lisp/nhem/bufed.lisp, 31-Mar-89 18:34:40, Edit by Chiles. - Fixed "Bufed Goto and Quit". Modified "Bufed" to move point to the beginning - of the buffer. - -/usr1/lisp/nhem/bindings.lisp, 31-Mar-89 18:27:02, Edit by Chiles. - Changed bindings of "Push Mark/Point to Here" to "Generic Pointer Up". - -/usr1/lisp/nhem/mh.lisp, 31-Mar-89 13:40:46, Edit by Chiles. - Fixed a bug in SETUP-REMAIL-DRAFT-BUFFER recently introduced by tweaking - cleanup hooks. THis now makes a dummy "Draft Information" variable. - -/usr1/lisp/nhem/macros.lisp, 29-Mar-89 22:19:57, Edit by Chiles. - Changed error handler to take r and R for restarts instead of P. - -/usr1/lisp/nhem/dired.lisp, 29-Mar-89 21:41:04, Edit by Chiles. - Renamed MAKEDIR to MAKE-DIRECTORY. - -/usr1/lisp/nhem/diredcoms.lisp, 29-Mar-89 17:04:51, Edit by Chiles. - Modified some doc strings and rewrote "Dired Help" to use "Describe Mode". - -/usr1/lisp/nhem/bufed.lisp, 29-Mar-89 16:53:06, Edit by Chiles. - Fixed some documentation and rewrote "Bufed Help" to use "Describe Mode". - -/usr1/lisp/nhem/bindings.lisp, 29-Mar-89 16:45:08, Edit by Chiles. - Added binding for "Bufed Help". - -/usr1/lisp/nhem/bufed.lisp, 29-Mar-89 16:36:53, Edit by Chiles. - Added documentation to mode "Bufed". - -/usr1/lisp/nhem/doccoms.lisp, 29-Mar-89 15:52:11, Edit by Chiles. - Wrote "Describe Mode" and hooked it into "Help". - -/usr1/lisp/nhem/buffer.lisp, 29-Mar-89 11:24:19, Edit by Chiles. - Wrote MODE-DOCUMENTATION and exported it. - -/usr1/lisp/nhem/filecoms.lisp, 28-Mar-89 17:24:47, Edit by Chiles. - Removed "Rename File" and "Delete File". - -/usr1/lisp/nhem/dired.lisp, 28-Mar-89 16:42:27, Edit by Chiles. - Removed "[Yes]" from DELETE-FILE-2 - -/usr1/lisp/nhem/diredcoms.lisp, 28-Mar-89 16:03:16, Edit by Chiles. - Moved "Delete File" here and made it consistent with the new "Copy File" and - "Rename File" in that it calls out to the dired package. - -/usr1/lisp/hemlock/bindings.lisp, 28-Mar-89 11:32:03, Edit by DBM. - Names for a couple of bindings were incorrect and have been - fixed. - -/usr1/lisp/nhem/diredcoms.lisp, 28-Mar-89 11:19:50, Edit by Chiles. - Modified "View File" to name buffers better. - -/usr1/lisp/nhem/bindings.lisp, 27-Mar-89 13:01:14, Edit by Chiles. - Forgot a copy and rename dired bindings. - -/usr1/lisp/nhem/mh.lisp, 27-Mar-89 11:46:28, Edit by Chiles. - Fixed :delete-hook arg that was not a list. - -/usr1/lisp/nhem/lispeval.lisp, 25-Mar-89 09:44:46, Edit by Chiles. - Wrote "Editor Server Name". - -/usr1/lisp/nhem/rompsite.lisp, 25-Mar-89 09:37:57, Edit by Chiles. - Modified INIT-EDITOR-SERVER to include process ID in editor server name for - same user, same machine, multiple instance protection. - -/usr1/lisp/nhem/lispbuf.lisp, 24-Mar-89 23:19:56, Edit by Chiles. -/usr1/lisp/nhem/lispbuf.lisp, 24-Mar-89 23:12:48, Edit by Chiles. - "Reenter Interactive Input" must copy the region when it is active since - moving the point changed the input region. There also was a bug that it - checked for the value of buffer-input-mark, but this has no global binding. - It now checks for a binding instead of a non-nil value. - -/usr1/lisp/nhem/spellcoms.lisp, 24-Mar-89 21:44:36, Edit by Chiles. - Made CORRECT-BUFFER-SPELLING and SPELL-PREVIOUS-WORD always ignore trailing - apostrophe s's on words. - -/usr1/lisp/nhem/bindings.lisp, 23-Mar-89 20:51:16, Edit by Chiles. - Added Bufed bindings. - -/usr1/lisp/nhem/bufed.lisp, 23-Mar-89 20:52:48, Edit by Chiles. - New file. - -/usr1/lisp/nhem/ts.lisp, 22-Mar-89 17:04:44, Edit by Chiles. -/usr1/lisp/nhem/srccom.lisp, 22-Mar-89 17:04:02, Edit by Chiles. -/usr1/lisp/nhem/spellcoms.lisp, 22-Mar-89 17:03:17, Edit by Chiles. -/usr1/lisp/nhem/register.lisp, 22-Mar-89 17:00:37, Edit by Chiles. -/usr1/lisp/nhem/morecoms.lisp, 22-Mar-89 16:59:49, Edit by Chiles. -/usr1/lisp/nhem/mh.lisp, 22-Mar-89 16:59:08, Edit by Chiles. -/usr1/lisp/nhem/lispeval.lisp, 22-Mar-89 16:58:16, Edit by Chiles. -/usr1/lisp/nhem/lisp-lib.lisp, 22-Mar-89 16:57:31, Edit by Chiles. -/usr1/lisp/nhem/killcoms.lisp, 22-Mar-89 15:27:23, Edit by Chiles. -/usr1/lisp/nhem/htext2.lisp, 22-Mar-89 15:24:23, Edit by Chiles. -/usr1/lisp/nhem/hi-integrity.lisp, 22-Mar-89 15:23:12, Edit by Chiles. -/usr1/lisp/nhem/filecoms.lisp, 22-Mar-89 15:22:19, Edit by Chiles. -/usr1/lisp/nhem/edit-defs.lisp, 22-Mar-89 15:21:01, Edit by Chiles. -/usr1/lisp/nhem/echocoms.lisp, 22-Mar-89 14:59:18, Edit by Chiles. -/usr1/lisp/nhem/echo.lisp, 22-Mar-89 14:57:55, Edit by Chiles. -/usr1/lisp/nhem/diredcoms.lisp, 22-Mar-89 14:13:31, Edit by Chiles. -/usr1/lisp/nhem/cursor.lisp, 22-Mar-89 14:11:46, Edit by Chiles. -/usr1/lisp/nhem/command.lisp, 22-Mar-89 14:09:36, Edit by Chiles. -/usr1/lisp/nhem/bit-screen.lisp, 22-Mar-89 14:08:27, Edit by Chiles. - Replaced idioms with BUFFER-START-MARK and BUFFER-END-MARK. - -/usr1/lisp/nhem/buffer.lisp, 22-Mar-89 14:05:29, Edit by Chiles. - Wrote BUFFER-START-MARK and BUFFER-END-MARK. - -/usr1/lisp/nhem/lisp-lib.lisp, 21-Mar-89 14:32:14, Edit by Chiles. - Modified all Lisp Library commands to signal an editor-error when not in a - library buffer. - -/usr1/lisp/nhem/morecoms.lisp, 21-Mar-89 14:22:02, Edit by Mbb. - Made "Count Occurrences" use the active region when it exists, otherwise - point to end of buffer. "Count Lines Region" became "Count Lines", and - "Count Words Region" became "Count Words". These two use the active region - now too. - -/usr1/lisp/nhem/searchcoms.lisp, 21-Mar-89 14:19:17, Edit by Mbb. - Made QUERY-REPLACE-FUNCTION use the active region if it exists, otherwise - point to end of buffer. Also, "List Matching Lines", "Delete Matching - Lines", and "Delete Non-Matching Lines" handle the active region similarly. - -/usr1/lisp/nhem/spellcoms.lisp, 20-Mar-89 15:17:19, Edit by Chiles. - Made CORRECT-BUFFER-SPELLING and SPELL-PREVIOUS-WORD ignore apostrophes - following words. - -/usr1/lisp/nhem/mh.lisp, 17-Mar-89 11:16:13, Edit by Chiles. - Replaced MODIFYING-MAIL-BUF with WITH-WRITABLE-BUFFER. - -/usr1/lisp/nhem/buffer.lisp, 17-Mar-89 11:07:41, Edit by Chiles. - Wrote WITH-WRITABLE-BUFFER. - -/usr1/lisp/nhem/window.lisp, 16-Mar-89 11:13:41, Edit by Chiles. - Made MAKE-MODELINE-FIELD have a restart that clobbers the existing defintion - of a modeline field name. - -/usr1/lisp/nhem/display.lisp, 14-Mar-89 23:19:27, Edit by Chiles. - Made REDISPLAY-WINDOWS-FROM-MARK invoke *things-to-do-once*. Some commands - were making buffers, using line buffered output streams - (WITH-OUTPUT-TO-MARK), and when redisplaying from the mark. This didn't - allow the chance for the buffer's modeline info object's start fields to get - initialized via UPDATE-MODELINE-FIELDS. - -/usr1/ch/lisp/complete/table.lisp, 14-Mar-89 19:46:09, Edit by Hoover. - Fixed a bogus declaration in COMPUTE-FIELD-POS. - -/usr1/lisp/nhem/echo.lisp, 14-Mar-89 14:07:56, Edit by Chiles. - Wrote BUFFER-VERIFICATION-FUNCTION which now moves the point around for - ambiguous shit. - -/usr1/lisp/nhem/echocoms.lisp, 14-Mar-89 13:22:31, Edit by Chiles. - Made "Complete Keyword" move the point in the echo area to the first - ambiguous field for :keyword completion (when the prefix is ambiguous of - course). - -/usr1/lisp/nhem/filecoms.lisp, 14-Mar-89 11:04:49, Edit by Chiles. - Modified PROCESS-FILE-OPTIONS to LOUD-MESSAGE and abort file options on - parsing errors. It still goes on to try to set a major mode. - -/usr1/lisp/nhem/table.lisp, 13-Mar-89 13:17:32, Edit by Chiles. - Eliminated optional argument to COMPLETE-STRING. Entered code for signalling - an error if the tables did not contain the same separator character, but - commented it out. - -/usr1/lisp/nhem/bindings.lisp, 09-Mar-89 16:19:19, Edit by Chiles. - Added more page titles. Voided some character translations and made up for - the few commands that needed to be duplicated. - -/usr1/lisp/nhem/window.lisp, 07-Mar-89 16:37:18, Edit by Chiles. - Added print function for modeline field info objects. - -/usr1/lisp/nhem/edit-defs.lisp, 07-Mar-89 10:59:30, Edit by Chiles. - Made GO-TO-DEFINITION use name-len instead of calculating it again. - -/usr1/lisp/nhem/mh.lisp, 06-Mar-89 21:37:11, Edit by Chiles. - Now make new mail buffer with delete-hook NEW-MAIL-BUF-DELETE-HOOK. Delete - old CLEANUP-NEW-MAIL-BUF-DELETION. - - Made CLEANUP-HEADERS-BUFFER, CLEANUP-MESSAGE-BUFFER, and CLEANUP-DRAFT-BUFFER - no longer check for their appropriate information structure. Made - MAYBE-MAKE-MH-BUFFER set buffer local deletion hooks for these functions. - - -/usr1/lisp/nhem/buffer.lisp, 06-Mar-89 21:25:54, Edit by Chiles. - MAKE-BUFFER now takes a :delete-hook argument, and DELETE-BUFFER now invokes - these functions. - -/usr1/lisp/nhem/struct.lisp, 06-Mar-89 21:19:05, Edit by Chiles. - Made buffer structure have a local delete hooks list. - -/usr1/lisp/nhem/highlight.lisp, 06-Mar-89 17:54:46, Edit by Chiles. - Made HIGHLIGHT-ACTIVE-REGION no longer do anything on the tty. - -/usr1/lisp/nhem/filecoms.lisp, 03-Mar-89 18:02:19, Edit by Chiles. - Fixed some recently lost functionality in "Create Buffer". - -/usr1/lisp/nhem/dired.lisp, 01-Mar-89 11:07:46, Edit by Chiles. - Modified ARRAY-ELEMENT-FROM-MARK to take an error message. - -/usr1/lisp/nhem/dired.lisp, 27-Feb-89 15:03:49, Edit by Chiles. - DELETE-FILE-AUX no longer outputs deleted file names on standard output. - -/usr1/lisp/nhem/kbdmac.lisp, 23-Feb-89 10:36:37, Edit by Chiles. - Changed "Define Keyboard Macro Key" message. - -/usr1/lisp/hemlock/rompsite.lisp, 07-Mar-89 17:33:05, Edit by DBM. - Modified the Hemlock GC notify functions to conform with the new - format for the messages. - -/usr1/lisp/nhem/dired.lisp, 27-Feb-89 15:03:49, Edit by Chiles. - DELETE-FILE-AUX no longer outputs deleted file names on standard output. - -/usr1/lisp/nhem/kbdmac.lisp, 23-Feb-89 10:36:37, Edit by Chiles. - Changed "Define Keyboard Macro Key" message. - -/usr1/lisp/nhem/complete/bindings.lisp, 22-Feb-89 14:31:11, Edit by Chiles. - Added new keyboard macro bindings. - -/usr1/lisp/nhem/complete/kbdmac.lisp, 22-Feb-89 14:22:01, Edit by Chiles. - Added new command "Define Keyboard Macro Key". - -/usr1/lisp/nhem/complete/scribe.lisp, 21-Feb-89 12:52:19, Edit by Chiles. -/usr1/lisp/nhem/complete/morecoms.lisp, 21-Feb-89 12:50:45, Edit by Chiles. -/usr1/lisp/nhem/complete/doccoms.lisp, 21-Feb-89 12:46:15, Edit by Chiles. -/usr1/lisp/nhem/complete/abbrev.lisp, 21-Feb-89 12:42:26, Edit by Chiles. - Modified MAKE-STRING-TABLE call. - -/usr1/lisp/nhem/complete/echo.lisp, 21-Feb-89 12:37:06, Edit by Chiles. - Modified for new string tables. - -/usr1/lisp/nhem/complete/echocoms.lisp, 21-Feb-89 11:50:59, Edit by Chiles. - Modified stuff for new string tables. - -/usr1/lisp/nhem/complete/struct.lisp, 21-Feb-89 11:43:26, Edit by Chiles. - Added new setf method for string tables. - -/usr1/lisp/nhem/complete/complete.lisp, 21-Feb-89 11:46:04, Edit by Chiles. - New file. - -/usr1/lisp/nhem/complete/macros.lisp, 21-Feb-89 11:45:10, Edit by Chiles. - Added new DO-STRINGS. - -/usr1/lisp/hemlock/dired.lisp, 22-Feb-89 16:36:49, Edit by DBM. - Fixed "Dired Help" string. - -/usr1/lisp/hemlock/mh.lisp, 21-Feb-89 14:25:42, Edit by Chiles. - Added delete-buffer-hook to set *new-mail-buffer* to nil. - -/usr1/lisp/nhem/rompsite.lisp, 20-Feb-89 16:54:11, Edit by Chiles. - Added load for hem:lisp-lib.fasl. - -/usr1/lisp/nhem/lisp-lib.lisp, 20-Feb-89 16:51:19, Edit by Chiles. - This is a new file. - -/usr1/lisp/nhem/bindings.lisp, 20-Feb-89 16:50:13, Edit by Chiles. - Added "Lisp-Lib" bindings. - -/usr1/lisp/nhem/dired.lisp, 15-Feb-89 15:20:25, Edit by Chiles. - This is a new file. - -/usr1/lisp/nhem/bindings.lisp, 15-Feb-89 15:20:03, Edit by Chiles. - Added Dired bindings. - -/usr1/lisp/nhem/rompsite.lisp, 14-Feb-89 18:04:46, Edit by Chiles. - Added load for dired.fasl. - -/usr1/lisp/nhem/srccom.lisp, 14-Feb-89 16:16:11, Edit by Chiles. - Fixed some silly coding. - -/usr1/lisp/nhem/rompsite.lisp, 14-Feb-89 16:06:28, Edit by Chiles. - Removed tty MESSAGE of GC info. - -/usr1/lisp/nhem/scribe.lisp, 14-Feb-89 11:08:53, Edit by Chiles. - Made "Insert Scribe Directive" use the active region for environments. - -/usr1/lisp/nhem/group.lisp, 13-Feb-89 16:19:57, Edit by Chiles. - Put back routine I accidently deleted. - -/usr1/lisp/nhem/struct.lisp, 10-Feb-89 16:45:23, Edit by Chiles. - Deleted export of COPY-MODELINE-FIELD. - -/usr1/ch/lisp/rompsite.lisp, 02-Feb-89 16:49:42, Edit by Christopher Hoover. - Changed font path support to use EXT:CAREFULLY-ADD-FONT-PATHS. Made - Hemlock look first on the local machine and then in AFS for fonts. - -/usr1/lisp/nhem/searchcoms.lisp, 31-Jan-89 11:00:10, Edit by Chiles. - Installed "String Search Ignore Case" and removed "Default Search Kind". - -/usr1/lisp/nhem/rompsite.lisp, 30-Jan-89 15:17:12, Edit by Chiles. - Changed underline font variable values and set up to really use X11 font - paths. - -/usr1/lisp/nhem/bindings.lisp, 27-Jan-89 13:31:13, Edit by Chiles. - Removed "Typescript" mode local binding of "Process Control invoke EXT:ABORT" - to #\hyper-a. - -/usr1/lisp/nhem/macros.lisp, 20-Jan-89 16:11:18, Edit by Chiles. - Fixed bug in LISP-ERROR-ERROR-HANDLER that allowed logical characters in - COMMAND-CASE to throw us into the debugger with a recursive error. - -/usr1/lisp/nhem/doccoms.lisp, 16-Jan-89 19:04:03, Edit by Chiles. - Fixed doc string for "Help" p. - -/usr1/lisp/nhem/macros.lisp, 11-Jan-89 23:03:10, Edit by Chiles. - Deleted export of IGNORE-EDITOR-ERRORS which no longer exists. - -/usr1/lisp/nhem/htext1.lisp, 11-Jan-89 22:54:14, Edit by Chiles. - Exported LINE> and LINES-RELATED. - -/usr1/lisp/nhem/window.lisp, 11-Jan-89 22:45:22, Edit by Chiles. - Removed some bogus exports dirtying the system with "nonexistent" symbols. - -/usr1/lisp/nhem/filecoms.lisp, 11-Jan-89 13:37:41, Edit by Chiles. - Fixed bug in READ-BUFFER-FILE invoking hook on wrong pathname (not probed - one). - -/usr1/lisp/nhem/filecoms.lisp, 10-Jan-89 18:03:38, Edit by Chiles. - Fixed bug in PATHNAME-TO-BUFFER-NAME. - -/usr1/lisp/nhem/lispeval.lisp, 05-Jan-89 17:21:54, Edit by Chiles. - Made "Describe Symbol" use MARK-SYMBOL - -/usr1/lisp/nhem/lispbuf.lisp, 05-Jan-89 17:20:12, Edit by Chiles. - Wrote MARK-SYMBOL and made "Editor Describe Symbol" use it. - -/usr1/lisp/nhem/scribe.lisp, 05-Jan-89 15:55:23, Edit by Chiles. - Made INSERT-SCRIBE-DIRECTIVE use the next word if the mark is immediately - before it, instead of the previous word. Cleaned up the code some and - documented it (oh no!). - -/usr1/lisp/nhem/spellcoms.lisp, 05-Jan-89 15:32:32, Edit by Chiles. - Made SPELL-PREVIOUS-WORD return the next word when the mark is immediately - before the next word, such that the cursor is displayed within that word. - Renamed "Correct Word Spelling" to "Check Word Spelling" and "Check Word - Spelling" to "Auto Check Word Spelling". - -/usr1/lisp/nhem/rompsite.lisp, 03-Jan-89 11:37:50, Edit by Chiles. - Made INVOKE-SCHEDULED-EVENTS bind *time-queue* to nil around invoking event - function. - -/usr1/lisp/nhem/hunk-draw.lisp, 02-Jan-89 15:53:58, Edit by Chiles. - Fixed problem with underline font leaving dots at the end of lines. I was - copying the pixmap onto the screen one pixel short of the appropriate length. - -/usr1/lisp/nhem/lispeval.lisp, 23-Dec-88 15:13:07, Edit by Chiles. - Rewrote "Compile Defun", "Evaluate Defun", and "Re-evaluate Defvar" to - use DEFUN-REGION. - -/usr1/lisp/nhem/lispbuf.lisp, 23-Dec-88 15:04:46, Edit by Chiles. - Wrote DEFUN-REGION and rewrote "Editor Compile Defun", "Editor Evaluate - Defun", and "Editor Re-evaluate Defvar" to use it. - -/usr1/lisp/nhem/lispmode.lisp, 22-Dec-88 23:43:33, Edit by Chiles. - Wrote MARK-TOP-LEVEL-FORM. Rewrote "Mark Defun" and "End of Defun" to use - it. Added doc strings to START-DEFUN-P and INSIDE-DEFUN-P. - -/usr1/lisp/nhem/keytran.lisp, 22-Dec-88 17:39:21, Edit by Chiles. - Fixed a bug in TRANSLATE-MOUSE-CHARACTER that would have tried to set the - :lock bit for a character which our system doesn't support. - -/usr1/lisp/nhem/mh.lisp, 21-Dec-88 14:26:09, Edit by Chiles. - Replaced occurrences of FILL-REGION-COMMAND-AUX with - FILL-REGION-BY-PARAGRAHPS. - -/usr1/lisp/nhem/fill.lisp, 21-Dec-88 13:59:36, Edit by Chiles. - Renamed FILL-REGION-COMMAND-AUX to FILL-REGION-BY-PARAGRAHPS. Made some - arguments optional. - -/usr1/lisp/nhem/morecoms.lisp, 20-Dec-88 17:31:29, Edit by Chiles. - Modified PAGE-DIRECTORY to clean it up and made it pull control-l's off the - line strings if it occurred as the first characters. - -/usr1/lisp/nhem/window.lisp, 19-Dec-88 13:52:23, Edit by Chiles. - Modified WINDOW-CHANGED to update the modeline's dis-line length. - -/usr1/lisp/nhem/unixcoms.lisp, 17-Dec-88 10:53:54, Edit by Chiles. -/usr1/lisp/nhem/mh.lisp, 17-Dec-88 10:53:13, Edit by Chiles. -/usr1/lisp/nhem/lispeval.lisp, 17-Dec-88 10:52:09, Edit by Chiles. -/usr1/lisp/nhem/lispbuf.lisp, 17-Dec-88 10:51:08, Edit by Chiles. - Changed instances of WRITE-DA-FILE to WRITE-BUFFER-FILE. - -/usr1/lisp/nhem/killcoms.lisp, 14-Dec-88 23:32:02, Edit by Chiles. - Fixed a bug in the KILL-REGION/KILL-CHARACTER interaction code -- needed to - set the *delete-char-region* to nil when the previous command type was a - region kill. - -/usr1/lisp/nhem/echo.lisp, 14-Dec-88 22:40:43, Edit by Chiles. - Modified PROMPT-FOR-BUFFER to disallow input of the empty string when no - default is offered. This now permits defaults to be specified with - :default-string even when :default is nil, but when :must-exist is non-nil, - :default-string must name an existing buffer. - -/usr1/lisp/nhem/filecoms.lisp, 14-Dec-88 22:13:17, Edit by Chiles. - Rewrote "Create Buffer". It now offers a default of "Buffer n". - - Added doc strings for BUFFER-DEFAULT-PATHNAME and PATHNAME-TO-BUFFER-NAME. - Changed what PATHNAME-TO-BUFFER-NAME does. When there is a type but no name, - it inserts *name/type-separator-character* before the type. - - Renamed WRITE-DA-FILE to WRITE-BUFFER-FILE, and READ-DA-FILE to - READ-BUFFER-FILE. Modified FIND-FILE-BUFFER and "Visit File". Hope they're - right. - - "Process File Options" no longer complains about a missing pathname. - PROCESS-FILE-OPTIONS is willing to handle a buffer without an associated - pathname. - - -/usr1/lisp/nhem/echo.lisp, 14-Dec-88 22:05:31, Edit by Chiles. - PROMPT-FOR-BUFFER does not allow the empty string to be supplied anymore. - -/usr1/lisp/nhem/srccom.lisp, 14-Dec-88 21:56:53, Edit by Chiles. - Made the prompt for a destination buffer offer a sticky-default, - "Source Compare Default Destination". - -/usr1/lisp/nhem/mh.lisp, 14-Dec-88 13:19:01, Edit by Chiles. - Updated modeline stuff to use MODELINE-FIELD. - -/usr1/lisp/nhem/main.lisp, 13-Dec-88 13:52:20, Edit by Chiles. - Modified MAKE-MODELINE-FIELD calls. - -/usr1/lisp/nhem/morecoms.lisp, 13-Dec-88 13:50:07, Edit by Chiles. - Updated DO-RECURSIVE-EDIT to use MODELINE-FIELD. - -/usr1/lisp/nhem/struct.lisp, 13-Dec-88 12:47:22, Edit by Chiles. - Renamed modeline-field-name to %name. Defined setf'er. - -/usr1/lisp/nhem/window.lisp, 13-Dec-88 13:40:45, Edit by Chiles. - Modified modeline stuff to make names first class. Renamed some modelien - field objects. Wrote MODELINE-FIELD, MODELINE-FIELD-NAME, and a setf'er. - -/usr1/lisp/nhem/bit-screen.lisp, 13-Dec-88 11:41:32, Edit by Chiles. - Uncommented hook additions for WINDOW-BUFFER and BUFFER-NAME icon naming. - -/usr1/lisp/nhem/rompsite.lisp, 13-Dec-88 11:42:28, Edit by Chiles. - Updated window icon naming for X11. Someone wanted it. - -/usr1/lisp/nhem/killcoms.lisp, 12-Dec-88 12:30:23, Edit by Chiles. - Made PUSH-BUFFER-MARK signal a Lisp error. - -/usr1/lisp/nhem/rompsite.lisp, 10-Dec-88 20:50:06, Edit by Chiles. - Added doc strings for TEXT-CHARACTER and PRINT-PRETTY-CHARACTER. - -/usr1/lisp/nhem/auto-save.lisp, 10-Dec-88 14:26:52, Edit by Chiles. - Added some documentation and removed some bogus "interface" claims as per - Rob's understanding of what "interface" means in a function's comments. - -/usr1/lisp/nhem/macros.lisp, 08-Dec-88 13:49:04, Edit by Chiles. - Modified doc string for EDITOR-ERROR. It also now signals an error if the - editor-error condition goes unhandled. - -/usr1/lisp/nhem/interp.lisp, 08-Dec-88 13:37:02, Edit by Chiles. - Established editor-error condition handler around command invocation. - Editor-error's were being handled by the "internal:" error handler - established in ED since these conditions are a subtype of error. - -/usr1/lisp/nhem/filecoms.lisp, 06-Dec-88 14:29:26, Edit by Chiles. - Wrote DELETE-BUFFER-IF-POSSIBLE. Added doc string for CHANGE-TO-BUFFER. - -/usr1/lisp/nhem/buffer.lisp, 06-Dec-88 13:51:58, Edit by Chiles. - Modified page title and doc string for DELETE-BUFFER. - -/usr1/lisp/nhem/mh.lisp, 06-Dec-88 13:45:19, Edit by Chiles. - Moved DELETE-MH-BUFFER and replaced calls with DELETE-BUFFER-IF-POSSIBLE. - -/usr1/lisp/nhem/xcoms.lisp, 30-Nov-88 17:36:43, Edit by Chiles. - Here it is -- "Stack Window". - -/usr1/lisp/nhem/filecoms.lisp, 30-Nov-88 17:36:19, Edit by Chiles. - Moved "Stack Window". - -/usr1/lisp/nhem/fill.lisp, 29-Nov-88 11:59:51, Edit by Chiles. - Changed occurrences of %MARK-PARAGRAPH to MARK-PARAGRAPH. - -/usr1/lisp/nhem/text.lisp, 29-Nov-88 11:58:01, Edit by Chiles. - Changed %MARK-PARAGRAPH to MARK-PARAGRAPH. - -/usr1/lisp/hemlock/mh.lisp, 28-Nov-88 16:21:44, Edit by DBM. - Modified CLEANUP-HEADERS-REFERENCE to set the message/draft-hdrs-mark to - nil. This is necessary if someone deletes the headers buffer before the - message buffer. - -/usr1/lisp/nhem/macros.lisp, 27-Nov-88 15:59:21, Edit by Chiles. - Rewrote EDITOR-ERROR. Created an editor-error condition with accesses - EDITOR-ERROR-FORMAT-STRING and EDITOR-ERROR-FORMAT-ARGUMENTS. - -/usr1/lisp/nhem/main.lisp, 26-Nov-88 14:56:25, Edit by Chiles. - Deleted bogus export of *current-package*. - -/usr1/lisp/nhem/text.lisp, 26-Nov-88 12:28:30, Edit by Chiles. - Replaced occurrence of %KILL-REGION with KILL-REGION. - -/usr1/lisp/nhem/lispmode.lisp, 26-Nov-88 12:27:12, Edit by Chiles. - Replaced occurrence of %KILL-REGION with KILL-REGION. - -/usr1/lisp/nhem/lispbuf.lisp, 26-Nov-88 12:26:07, Edit by Chiles. - Replaced occurrence of %KILL-REGION with KILL-REGION. - -/usr1/lisp/nhem/echocoms.lisp, 26-Nov-88 12:25:25, Edit by Chiles. - Replaced occurrence of %KILL-REGION with KILL-REGION. - -/usr1/lisp/nhem/morecoms.lisp, 25-Nov-88 20:55:18, Edit by Chiles. - Modified "Delete Previous Character Expanding Tabs" to call KILL-CHARACTERS. - -/usr1/lisp/nhem/command.lisp, 25-Nov-88 21:27:07, Edit by Chiles. - Modified "Delete Next Character" and "Delete Previous Character" to call - KILL-CHARACTERS. - -/usr1/lisp/nhem/killcoms.lisp, 25-Nov-88 21:58:39, Edit by Chiles. - Wrote KILL-CHARACTERS and modified KILL-REGION (used to be %KILL-REGION). - -/usr1/lisp/nhem/icom.lisp, 25-Nov-88 16:04:48, Edit by Chiles. - Removed italicize comments file option. Changed package spec to string. - -/usr1/lisp/nhem/mh.lisp, 22-Nov-88 16:06:53, Edit by Chiles. - Made SHOW-PROMPTED-MESSAGE normalize message ID strings. - -/usr1/lisp/nhem/bit-screen.lisp, 21-Nov-88 16:22:30, Edit by Chiles. - DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE now sets the next hunk trashed since we - are somehow getting exposure events out of order with configure - notifications. We should be able to remove this when facilities fixes the - new software it just released. - -/usr1/lisp/nhem/lispeval.lisp, 18-Nov-88 13:54:01, Edit by Chiles. - Made CREATE-SLAVE correctly get the name of the slave that just connected. - -/usr1/lisp/nhem/rompsite.lisp, 18-Nov-88 13:52:21, Edit by Chiles. - Made EDITOR_CONNECT-HANDLER set the name of the editor that just connected. - -/usr1/lisp/nhem/hunk-draw.lisp, 17-Nov-88 09:08:04, Edit by Chiles. - Made HUNK-REPLACE-LINE-ON-PIXMAP set gcontext :exposures nil. Fixed the - macro it uses to no longer require binding gcontext each time around the - loop. - -/usr1/lisp/nhem/mh.lisp, 15-Nov-88 21:25:50, Edit by Chiles. - Added page of code for message buffer modeline fields. Wrote - MARK-TO-NOTE-REPLIED-MSG. Created "Default Message Modeline Fields". - Modified DELETE-MESSAGE and UNDELETE-MESSAGE. Modified MAYBE-MAKE-MH-BUFFER. - Modified "Deliver Message" and wrote DELIVER-DRAFT-BUFFER-MESSAGE. - -/usr1/lisp/nhem/struct.lisp, 16-Nov-88 13:25:17, Edit by Chiles. - Export MODELINE-FIELD-NAME instead ML-FIELD-NAME. - -/usr1/lisp/nhem/rompsite.lisp, 16-Nov-88 13:32:48, Edit by Chiles. - Wrote EDITOR-DESCRIBE-FUNCTION. - -/usr1/lisp/nhem/lispbuf.lisp, 16-Nov-88 13:39:41, Edit by Chiles. - Wrote FUNCTION-TO-DESCRIBE and modified "Editor Describe Function Call". - -/usr1/lisp/nhem/lispeval.lisp, 16-Nov-88 13:50:14, Edit by Chiles. - Made DESCRIBE-FUNCTION-CALL-AUX use EDITOR-DESCRIBE-FUNCTION and - FUNCTION-TO-DESCRIBE. - -/usr1/lisp/nhem/mh.lisp, 15-Nov-88 20:46:02, Edit by Chiles. - Added message buffer modeline stuff. Modified MAYBE-MAKE-MH-BUFFER for the - creation of the message buffer. Modified DELETE-MESSAGE - - Maybe D shouldn't be fixed width? - -/usr1/lisp/nhem/window.lisp, 15-Nov-88 13:34:41, Edit by Chiles. - Modified %SET-MODELINE-FIELD-WIDTH to not allow zero width fields. Modified - MAKE-MODELINE-FIELD to check constraints too. - - Fixed a bug in the :buffer-name modeline-field. - - -/usr1/lisp/nhem/rompsite.lisp, 15-Nov-88 12:30:32, Edit by Chiles. - Replaced "nmmonitor" with "nm_active". - -/usr1/lisp/nhem/display.lisp, 15-Nov-88 12:40:25, Edit by Chiles. - Fixed REDISPLAY-WINDOWS-FOR-MARK to force output and so on. - -/usr1/lisp/hemlock/buffer.lisp, 14-Nov-88 15:14:34, Edit by DBM. - Made SETUP-INITIAL-BUFFER supply :modeline-fields nil. This gets set - when the editor fires up. - -/usr1/lisp/nhem/tty-display.lisp, 10-Nov-88 16:23:04, Edit by Chiles. - Modified occurrences of WINDOW-MODELINE-STRING to be WINDOW-MODELINE-BUFFER. - Made dumb redisplay method set the window's dis-line flags to unaltered. - -/usr1/lisp/nhem/bit-display.lisp, 10-Nov-88 16:20:40, Edit by Chiles. - Modified occurrences of WINDOW-MODELINE-STRING to be WINDOW-MODELINE-BUFFER. - -/usr1/lisp/nhem/main.lisp, 10-Nov-88 16:07:07, Edit by Chiles. - Added "Default Status Line Fields" along with DEFVAR's and PROCLAIM's for - recursive edit and completion mode fields. - - Modified "Default Modeline Fields". - -/usr1/lisp/nhem/bit-screen.lisp, 10-Nov-88 13:11:49, Edit by Chiles. - Modified BITMAP-MAKE-WINDOW to take modelinep. Modified - DEFAULT-CREATE-INITIAL-WINDOWS-ECHO to supply :modelinep t to MAKE-WINDOW. - Modified SET-HUNK-SIZE to determine if the window displays modelines by - checking WINDOW-MODELINE-BUFFER. - -/usr1/lisp/nhem/screen.lisp, 10-Nov-88 13:02:34, Edit by Chiles. - MAKE-WINDOW now takes a :modelinep argument. - - Added sets for echo and main BUFFER-MODELINE-FIELDS. - -/usr1/lisp/nhem/mh.lisp, 09-Nov-88 11:43:45, Edit by Chiles. - Modified a few MAKE-BUFFER calls. The modeline fields for mail buffer should - be redesigned when this stuff goes into the core. - -/usr1/lisp/nhem/lispeval.lisp, 09-Nov-88 11:38:19, Edit by Chiles. - Modified MAKE-BUFFER call. Made "Set Buffer Package" do over buffer's - windows calling UPDATE-MODELINE-FIELD on :package. - -/usr1/lisp/nhem/echo.lisp, 09-Nov-88 11:31:34, Edit by Chiles. - Modified MAKE-BUFFER call. - -/usr1/lisp/nhem/tty-screen.lisp, 09-Nov-88 11:02:14, Edit by Chiles. - Made main-lines be one less for status line. Made echo :text-position be one - less for status line. Modified calls to SETUP-MODELINE-IMAGE. - - Made TTY-MAKE-WINDOW refer to modelinep argument and modified its - SETUP-MODELINE-IMAGE call. - -/usr1/lisp/nhem/struct.lisp, 08-Nov-88 21:52:14, Edit by Chiles. - Added modeline-fields slot to buffer structure. - - Deleted window structure slots: main-pane, text-pane, modeline-pane, - font-map, modeline-line, and modeline-width. Added modeline-buffer and - modeline-buffer-len slots. - - Added DEFSETF for BUFFER-MODELINE-FIELDS. - - Added modeline-field and modeline-field-info structures. - - -/usr1/lisp/nhem/buffer.lisp, 05-Nov-88 17:30:52, Edit by Chiles. - Added page titles. - - Modified MAKE-BUFFER to initialize the %modeline-fields slot with a list of - ml-field-info objects. Now it takes keyword arguments. Modified call in - SETUP-INITIAL-BUFFER. - - Wrote BUFFER-MODELINE-FIELDS, %SET-BUFFER-MODELINE-FIELDS, and - SUB-SET-BUFFER-MODELINE-FIELDS, BUFFER-MODELINE-FIELD-P. - -/usr1/lisp/nhem/bit-display.lisp, 27-Oct-88 21:09:46, Edit by Chiles. - Removed calls to UPDATE-MODELINE-IMAGE. - -/usr1/lisp/nhem/winimage.lisp, 27-Oct-88 20:51:21, Edit by Chiles. - Deleted UPDATE-MODELINE-IMAGE. - -/usr1/lisp/nhem/display.lisp, 30-Oct-88 19:47:04, Edit by Chiles. - Stopped REDISPLAY-WINDOW and REDISPLAY-WINDOW-ALL from forcing output and - calling the after methods. This was causing INTERNAL-REDISPLAY to queue - input events for the editor that weren't seen before going into SYSTEM:SERVER - with a non-zero timeout. This means SYSTEM:SERVER had to timeout, or another - character had to be entered, before the unseen one was revealed. - -/usr1/lisp/nhem/display.lisp, 27-Oct-88 15:10:58, Edit by Chiles. - Wrote INTERNAL-REDISPLAY and made REDISPLAY-LOOP optionally splice in calling - the device's after-redisplay function. - -/usr1/lisp/nhem/rompsite.lisp, 27-Oct-88 15:12:02, Edit by Chiles. - Replaced calls to REDISPLAY with INTERNAL-REDISPLAY. - -/usr1/lisp/nhem/morecoms.lisp, 26-Oct-88 15:50:43, Edit by Chiles. - Wrote "Goto Absolute Line". - -/usr1/lisp/nhem/hunk-draw.lisp, 26-Oct-88 15:32:22, Edit by Chiles. - Made HUNK-REPLACE-LINE dispatch on *hack-hunk-replace-line*. - -/usr1/lisp/nhem/display.lisp, 26-Oct-88 15:15:47, Edit by Chiles. - Added an after-redisplay slot to the basic display structure. Made - REDISPLAY-LOOP, REDISPLAY-WINDOWS-FROM-MARK, REDISPLAY-WINDOW, and - REDISPLAY-WINDOW-ALL use this. - -/usr1/lisp/nhem/bit-screen.lisp, 26-Oct-88 15:03:05, Edit by Chiles. - MAKE-DEFAULT-BITMAP-DEVICE now sets the :after-redisplay slot. - REVERSE-VIDEO-HOOK-FUN now sets *hack-hunk-replace-line*. - -/usr1/lisp/hemlock/macros.lisp, 25-Oct-88 15:14:49, Edit by DBM. - Fixed the restart case in lisp-error-error-handler. - -/usr1/lisp/nhem/hunk-draw.lisp, 23-Oct-88 18:12:12, Edit by Chiles. - Fixed pixmap creation to be root depth instead of 1, so color stuff works. - When inverting areas, now use boole-xor instead of boole-c2 and a foreground - that is the xor of the foreground and background. This makes color inversion - work. If A is the foreground, and B is the background, then A xor B is AxB. - This value has the property that A xor AxB is B, and B xor AxB is A, thus - inverting in color the region. - -/usr1/lisp/nhem/bit-screen.lisp, 23-Oct-88 16:26:43, Edit by Chiles. - Modified BITMAP-MAKE-WINDOW to make the gcontext after we definitely have a - window. Made sure that where I destroy an xwindow, that I free the gcontext - for that hunk. Added a DEFVAR for *foreground-background-xor*, which is - initialized in INIT-BITMAP-SCREEN-MANAGER. This function also has corrected - calls to GET-HEMLOCK-GREY-PIXMAP and GET-HEMLOCK-CURSOR. Made - REVERSE-VIDEO-HOOK-FUN deal with rthunk correctly for new strategy, and it - calls GET-HEMLOCK-CURSOR now. - -/usr1/lisp/nhem/rompsite.lisp, 23-Oct-88 14:17:19, Edit by Chiles. - Modified FLASH-WINDOW-BORDER and FLASH-WINDOW to use an xor function and a - pixel value that is the xor of foreground and background. This allows - inversion in a color window, that is for any pixel values including 1 and 0. - Changed the cursor fetching code to no longer save the pixmaps hot spots. - These are now generated each time you fetch a new Hemlock cursor, and this - code now uses distinct graphics contexts for each pixmap (cursor and mask) to - accomodate the color monitor. This also seemed more correct in general. The - grey pixmap generation has been changed to not use XLIB:PUT-RAW-IMAGE since - this required Hemlock to know every server/monitor's preferences for raw - data. Fixed pixmap creation to be the root depth instead of 1 when not - making cursors. - -/usr1/lisp/nhem/hunk-draw.lisp, 22-Oct-88 20:06:02, Edit by Chiles. - Made HUNK-REPLACE-LINE-PIXMAP call XLIB:CREATE-PIXMAP with a depth of - XLIB:SCREEN-ROOT-DEPTH instead of 1. - -/usr1/lisp/nhem/buffer.lisp, 22-Oct-88 16:09:32, Edit by Chiles. - Modified %SET-BUFFER-NAME to do the right thing if the name supplied was - already in use but for the buffer being affected. This allows the buffer to - be renamed to the same name, but with different casing for display effect. - -/usr1/lisp/nhem/filecoms.lisp, 22-Oct-88 16:37:45, Edit by Chiles. - Modified "Rename Buffer" to allow users to rename a buffer to the same - name,but with different casing for visual effect. - -/usr1/lisp/nhem/lispeval.lisp, 21-Oct-88 18:40:11, Edit by Chiles. - Made CREATE-SLAVE not mess with the value of "Current Eval Server". It now - uses a special *create-slave-wait* that is set by the connect handler. - -/usr1/lisp/nhem/rompsite.lisp, 21-Oct-88 18:08:42, Edit by Chiles. - Made EDITOR_CONNECT-HANDLER only affect the :global value of "Current Eval - Server". It also not sets ed::*create-slave-wait* to nil. - -/usr1/lisp/nhem/window.lisp, 21-Oct-88 02:26:40, Edit by Chiles. - Modified %SET-WINDOW-BUFFER to move the window's display start and ends to - the new display-start slot buffers have. - -/usr1/lisp/nhem/buffer.lisp, 21-Oct-88 02:25:07, Edit by Chiles. - Added initialization for :display-start slot of new buffer. - -/usr1/lisp/nhem/struct.lisp, 21-Oct-88 02:23:11, Edit by Chiles. - Added display-start slot to the buffer structure. - -/usr1/lisp/nhem/lispeval.lisp, 20-Oct-88 22:13:53, Edit by Chiles. - MAYBE-QUEUE-OPERATION-REQUEST now informs the user whether the operation is - queued to be sent or being sent. - -/usr1/lisp/nhem/killcoms.lisp, 17-Oct-88 13:34:26, Edit by Chiles. - Made "Set/Pop Mark" only MESSAGE when interactive. - -/usr1/lisp/nhem/filecoms.lisp, 17-Oct-88 12:16:08, Edit by Chiles. - Installed new "Save All Files" that tells how many files it saved. - -/usr1/lisp/nhem/mh.lisp, 14-Oct-88 13:56:45, Edit by Chiles. - Made EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS always set the name back in case the - user used "Pick Headers". Broke off part of it to form - MAYBE-GET-NEW-MAIL-MSG-HDRS which is now also called in PICK-MESSAGE-HEADERS. - Made "Incorporate and Read New Mail" set the unseen mail buffer's name when - it already existed just in case someone used "Pick Headers". - PICK-MESSAGE-HEADERS now checks for the new mail buffer, and when the pick - expression is empty, it uses MAYBE-GET-NEW-MAIL-MSG-HDRS. - -/usr1/lisp/nhem/mh.lisp, 13-Oct-88 11:31:13, Edit by Chiles. - PROMPT-FOR-FOLDER was not giving must-exist to PROMPT-FOR-KEYWORD. It was - always passing nil. - -/usr1/lisp/nhem/bit-screen.lisp, 12-Oct-88 15:09:10, Edit by Chiles. - Reinstalled the better window deletion next merger code. Commented out the - hack in case we run into another asinine window manager. - -/usr1/lisp/nhem/lispbuf.lisp, 10-Oct-88 14:03:41, Edit by Chiles. - Modified commands that redirected *standard-output* for compiler warnings to - now redirect *error-output* to adhere to new compiler - -/usr1/lisp/nhem/lispbuf.lisp, 09-Oct-88 16:54:18, Edit by Chiles. - Made "Package" file option not choke when it couldn't stringify the thing. - -/usr1/lisp/nhem/bindings.lisp, 05-Oct-88 20:24:21, Edit by Chiles. - Eliminated bogus BIND-KEY in "Eval" mode for "Confirm Eval Input". - -/usr1/lisp/nhem/morecoms.lisp, 04-Oct-88 20:13:34, Edit by Chiles. - Made "Uppercase Region" and "Lowercase Region" insist on the region being - active. Made TWIDDLE-REGION, which implements above, take a region instead - of two marks. - -/usr1/lisp/nhem/htext4.lisp, 04-Oct-88 19:57:55, Edit by Chiles. - Modified FILTER-REGION doc string. Added page titles. - -/usr1/lisp/hemlock/bit-display.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/keytrandefs.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/tty-screen.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/bit-screen.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/font.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/window.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/bit-stream.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/hunk-draw.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/main.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/xcoms.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/charmacs.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/rompsite.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/keytran.lisp, 03-October-88, Edit by Chiles. -/usr1/lisp/hemlock/screen.lisp, 03-October-88, Edit by Chiles. - Modified to support X11 using CLX. - -/usr1/lisp/nhem/scribe.lisp, 30-Sep-88 14:45:41, Edit by Chiles. - Broke up long FORMAT string into several lines of code. Fixed bug in - DIRECTIVE-HELP. - -/usr1/lisp/nhem/filecoms.lisp, 27-Sep-88 11:48:10, Edit by Chiles. - Added a "Make Buffer Hook" to add all new buffers to the history. Added some - doc and a page title. - -/usr1/lisp/nhem/bindings.lisp, 22-Sep-88 22:46:30, Edit by Chiles. - Added binding for "Insert Scribe Directive". Deleted lots of other "Scribe" - bindings. - -/usr1/lisp/nhem/scribe.lisp, 21-Sep-88 22:48:46, Edit by Chiles. - Added new code to dispatch on a character and either insert a Scribe command - or environment, instead of having 30 similar commands. Deleted the following - commands entirely: - "Scribe Appendix" - "Scribe AppendixSection" - "Scribe Chapter" - "Scribe Heading" - "Scribe MajorHeading" - "Scribe Paragraph" - "Scribe PrefaceSection" - "Scribe Section" - "Scribe SubHeading" - "Scribe SubSection" - "Scribe UnNumbered" - "Scribe Verbatim" - "Scribe Verse" - Introduced "List Scribe Paragraph Delimiters". - Cleaned up code. - Got the stuff working. - -/usr1/lisp/nhem/lispmode.lisp, 15-Sep-88 14:31:53, Edit by Chiles. - Modified LISP-INDENT-REGION to do it undoably. It takes an optional argument - for the undo text. "Indent Form" supplies its name when calling this. - Documented INDENT-FOR-LISP. Modified some page boundaries. - -/usr1/lisp/nhem/bindings.lisp, 07-Sep-88 16:44:35, Edit by Chiles. - Changed "Eval Input" bindings to "Confirm Eval Input". - -/usr1/lisp/nhem/lispbuf.lisp, 07-Sep-88 16:43:34, Edit by Chiles. - Renamed "Eval Input" to "Confirm Eval Input". - -/usr1/lisp/nhem/mh.lisp, 07-Sep-88 13:08:04, Edit by Chiles. - Modified DELETE-AND-EXPUNGE-TEMP-DRAFTS one more time. Now it makes use of - MH's :errorp arguement to squelch errors. - -/usr1/lisp/hemlock/lispeval.lisp, 30-Aug-88 11:32:53, Edit by DBM. - Changed references to slave-utility-name to slave-utility and - slave-arguments to slave-utility-switches. - -/usr1/lisp/nhem/ts.lisp, 19-Aug-88 21:47:12, Edit by Chiles. - Fixed "Unwedge Interactive Input String" according to mail I sent. - -/usr1/lisp/nhem/bindings.lisp, 15-Aug-88 12:30:05, Edit by Chiles. - Added binding for "Scribe Buffer File". - -/usr1/lisp/nhem/lispeval.lisp, 15-Aug-88 11:11:10, Edit by Chiles. - Renamed "Slave Utility Name" to "Slave Utility" and - "Slave Arguments" to "Slave Utility Switches". - -/usr1/lisp/nhem/unixcoms.lisp, 15-Aug-88 11:09:48, Edit by Chiles. - Renamed "Print Utility Options" to "Print Utility Switches". Added Scribe - stuff. - -/usr1/lisp/nhem/mh.lisp, 09-Aug-88 23:16:09, Edit by Chiles. - Made "Expunge Messages" and "Quit Headers" doc strings mention "Temporary - Draft Folder". Modified DELETE-AND-EXPUNGE-TEMPORARY-DRAFTS to do a - directory to realize if there were really any messages to blow away. - -/usr1/lisp/nhem/doccoms.lisp, 09-Aug-88 22:57:13, Edit by Chiles. - Modified "Apropos" to use CURRENT-VARIABLE-TABLES, and cleaned up this moby - growing command. - -/usr1/lisp/nhem/echo.lisp, 09-Aug-88 22:26:46, Edit by Chiles. - Wrote CURRENT-VARIABLE-TABLES, and exported it. Modified PROMPT-FOR-VARIABLE - to use it. - -/usr1/lisp/nhem/mh.lisp, 07-Aug-88 04:03:13, Edit by Chiles. - "Remail Message". - -/usr1/lisp/nhem/filecoms.lisp, 04-Aug-88 22:20:23, Edit by Chiles. - Made "Insert File" and "Insert Buffer" push a buffer mark before inserting. - -/usr1/lisp/nhem/lispbuf.lisp, 04-Aug-88 21:31:10, Edit by Chiles. - Fixed default binding and doc string of "Unwedge Interactive Input Confirm". - -/usr1/lisp/nhem/mh.lisp, 30-Jul-88 22:09:59, Edit by Chiles. - Fixed a bug with "Reply to Message Prefix Action". Made "Reply to M in O - Window", when invoked in the headers buffer, put the message in the "current" - window. - -/usr1/lisp/nhem/highlight.lisp, 26-Jul-88 17:26:32, Edit by Chiles. - Did away with HIGHLIGHT-ACTIVE-REGION-P. Replaced calls with - REGION-ACTIVE-P. Made MAYBE-HIGHLIGHT-OPEN-PARENS check the value of - "Highlight Active Region" and REGION-ACTIVE-P instead of just the latter. - -/usr1/lisp/nhem/killcoms.lisp, 26-Jul-88 17:21:36, Edit by Chiles. - Made REGION-ACTIVE-P check for the last command type being a member of - *ephemerally-active-command-types*. Modified "Kill Region" and "Save Region" - to call CURRENT-REGION normally. - -/usr1/lisp/nhem/lispbuf.lisp, 19-Jul-88 22:35:22, Edit by Chiles. - Fixed bug in "Eval Input". - -/usr1/lisp/hemlock/linimage.lisp, 27-Jul-88 11:09:17, Edit by DBM. -/usr1/lisp/hemlock/line.lisp, 27-Jul-88 10:56:33, Edit by DBM. - Removed some old Perq cruft. - -/usr1/lisp/nhem/lispbuf.lisp, 19-Jul-88 22:35:22, Edit by Chiles. - Fixed bug in "Eval Input". - -/usr1/lisp/nhem/filecoms.lisp, 11-Jul-88 12:55:48, Edit by Chiles. - Fixed bug in "Visit File" telling the user that the file is already in some - buffer. - -/usr1/lisp/nhem/doccoms.lisp, 06-Jul-88 23:14:13, Edit by Chiles. - Added "Describe Pointer" command and frobbed "Help". - -/usr1/lisp/nhem/bindings.lisp, 05-Jul-88 16:34:31, Edit by Chiles. - Added bindings for new commands in Commands.Lisp. - - Added initial value for *describe-pointer-keylist*. - -/usr1/lisp/nhem/command.lisp, 05-Jul-88 16:36:40, Edit by Chiles. - Added "Mark to Beginning of Buffer" "Mark to End of Buffer". - -/usr1/lisp/nhem/ts.lisp, 04-Jul-88 15:46:46, Edit by Chiles. - Broke "Process Control" up into separate commands. - -/usr1/lisp/nhem/filecoms.lisp, 01-Jul-88 23:40:00, Edit by Chiles. - made "Visit File" MESSAGE when another buffer also contains the pathname. - -/usr1/lisp/nhem/mh.lisp, 29-Jun-88 23:33:40, Edit by Chiles. - Wrote "Delete Message and Down Line". - - Made "Deliver Message" say "Delivering draft ...". - - Deleted GET-MESSAGE-HEADERS-SEQ. Made SET-MESSAGE-HEADERS-IDS optionally - return an MH sequence. These were identical but for this difference. - - Made "Refile Message" and "Delete Message" maintain consistency. - - Made SHOW-MESSAGE-OFFSET-MARK return nil when it couldn't place the mark - instead of signalling an error. Wrote SHOW-MESSAGE-OFFSET-MSG-BUG, and - renamed SHOW-MESSAGE-OFFSET-HEADERS to SHOW-MESSAGE-OFFSET-HDRS-BUF. In a - message buffer, we move back to the headers buffer and delete the message - buffer. - - Added "Reply to Message Prefix Action" which controls prefix argument actions - in "Reply to Message". - - Removed "Automatic Current Message" feature. - Removed DEFHVAR just after "Headers Information". - Removed when...show from: - "Message Headers" - "Pick Headers" - INSERT-NEW-MAIL-MESSAGE-HEADERS - Modified REVAMP-HEADERS-BUFFER and CLEANUP-HEADERS-BUFFER to always take care - of the main message buffer. - - -/usr1/lisp/nhem/bindings.lisp, 27-Jun-88 13:45:22, Edit by Chiles. - Added bindings for macroexpansion and reenter input stuff. - - Added new bindings for "Process Control" break up. - - -/usr1/lisp/nhem/lispbuf.lisp, 27-Jun-88 13:34:56, Edit by Chiles. - Added "Editor Macroexpand Expression". - - Added "Reenter Interactive Input". - - -/usr1/lisp/nhem/lispeval.lisp, 27-Jun-88 13:33:11, Edit by Chiles. - Added "Macroexpand Expression". - -/usr1/lisp/nhem/bindings.lisp, 26-Jun-88 20:02:02, Edit by Chiles. - Uncommented binding for "Delete Message and Down Line". - -/usr1/lisp/nhem/bindings.lisp, 24-Jun-88 16:11:37, Edit by Chiles. - Fixed C-c bindings messed up by making C-c a hyper prefix. Made all c-, m-, - and s- bindings be spelled out for consistency. - -/usr1/lisp/nhem/mh.lisp, 16-Jun-88 15:02:40, Edit by Chiles. - Made "Delete Draft and Buffer" cleanup after split window drafts. - -/usr1/lisp/nhem/spellcoms.lisp, 16-Jun-88 12:54:08, Edit by Chiles. - Made corrections based on previous corrections undoable and changed message - to say "corrected" instead of "replaced". - -/usr1/lisp/nhem/mh.lisp, 15-Jun-88 20:04:23, Edit by Chiles. - Added MESSAGE's to INCORPORATE-NEW-MAIL. - -/usr1/lisp/nhem/lispeval.lisp, 13-Jun-88 19:28:48, Edit by Chiles. - Made #\c for "Edit Compiler Errors" center the window around the current - error. - -/usr1/lisp/nhem/mh.lisp, 10-Jun-88 16:16:58, Edit by Chiles. - Fixed a bug in "Headers Refile Message". It wasn't supplying - *refile-default-destination* to PROMPT-FOR-FOLDER when in a message buffer. - -/usr1/lisp/nhem/mh.lisp, 10-Jun-88 13:21:55, Edit by Chiles. - Made CLEANUP-HEADERS-REFERENCE, when the info is TYPEP 'draft-info, set the - replied-to folder and msg to nil. - -/usr1/lisp/nhem/lispbuf.lisp, 09-Jun-88 20:17:30, Edit by Chiles. - Fixed bug in warning message for "List Compile Group". - -/usr1/ch/lisp/files.lisp, 06-Jun-88 23:44:01, Edit by Christopher Hoover. - Fixed a bug which caused WRITE-FILE to sometimes lose when given an - "access" value. - -/usr1/ch/lisp/unixcoms.lisp, 03-Jun-88 15:54:46, Edit by Christopher Hoover. - Wrote the command "Unix Filter Region". - -/usr1/ch/lisp/auto-save.lisp, 16-May-88 02:31:07, Edit by Christopher Hoover. - Fixed the code so that "Auto Save Checkpoint Frequency" is always - truncated to an integer to keep (very) bad things from happening. - -/usr1/lisp/nhem/spellcoms.lisp, 01-Jun-88 10:46:45, Edit by Chiles. - Made "Check Word Spelling" show close words regardless of "Correct Unique - Spelling Immediately". - -/usr1/lisp/nhem/bindings.lisp, 31-May-88 15:25:23, Edit by Chiles. - Bound all alpha chars to "Illegal" in "Headers" and "Message" modes. - -/usr1/lisp/nhem/mh.lisp, 25-May-88 11:42:13, Edit by Chiles. - Created "Temporary Draft Folder" variable, wrote - DELETE-AND-EXPUNGE-TEMP-DRAFTS, and modified "Quit Headers"and "Expunge - Messages". - -/usr1/lisp/nhem/edit-defs.lisp, 25-May-88 11:09:51, Edit by Chiles. - Made "Edit Definition" and "Goto Definition" (which has a new name) use - editor Lisp if there is no currently valid slave. - -/usr1/lisp/nhem/lispeval.lisp, 25-May-88 02:39:37, Edit by Chiles. - Made "Describe Function Call" and "Describe Symbol" use the editor Lisp when - the current eval server doesn't exist is invalid. - -/usr1/lisp/nhem/mh.lisp, 24-May-88 14:57:36, Edit by Chiles. - Changed PROMPT-FOR-MESSAGE to take keyword args adding prompt. Changed all - the call sites. Made "Message Headers", "Delete Message", "Undelete - Message", and "Refile Message" supply particular prompt messages. - - Changed "Quit Headers Confirm" to "Expunge Messages Confirm". - -/usr1/lisp/nhem/mh.lisp, 19-May-88 12:14:27, Edit by Chiles. - Wrote BREAKUP-MESSAGE-SPEC and added the variable, "Unseen Headers Message - Spec". This affected "Incorporate and Show New Mail" and "Expunge Message". - -/usr1/lisp/nhem/mh.lisp, 15-May-88 15:40:24, Edit by Chiles. - Made MH-PROFILE-COMPONENT take an optional error-on-open argument, so when - this is used for sequence files, and the sequence file is not there or - readable, then the command can continue ... assuming the sequence file - operation is insignificant if the file cannot be opened. Made - MH-SEQUENCE-LIST use this argument. - - Made MARK-ONE-MESSAGE not write the file on :delete unless the message was - really in the sequence before deletion. - -/usr1/lisp/nhem/lispmode.lisp, 12-May-88 15:11:15, Edit by Chiles. - Added mailer and xlib DEFINDENT forms. - -/usr1/lisp/nhem/mh.lisp, 12-May-88 10:45:02, Edit by Chiles. - Fixed documentation for "Reply to Message in Other Window". - -/usr1/lisp/nhem/mh.lisp, 11-May-88 14:03:29, Edit by Chiles. - Wrote "Edit Message Buffer". Made a bunch of (subseq folder 1) calls be - calls to STRIP-FOLDER-NAME for consistency. - -/usr1/lisp/nhem/mh.lisp, 11-May-88 10:33:23, Edit by Chiles. - Made "Insert Message Region" know about split-window drafts. - -/usr1/lisp/hemlock/edit-defs.lisp, 10-May-88 17:11:28, Edit by Chiles. - Made "Edit Command Definition" on an argument prompt for a key instead of - prompting for a command name. - -/usr1/lisp/nhem/mh.lisp, 10-May-88 12:37:40, Edit by Chiles. - Made DELETE-HEADERS-LINE-REFERENCES delete message buffers if they are - not associated with a draft buffer. If they are, then it cleans up the - reference. - - Wrote "Reply to Message in Other Window" which splits the current window - when replying to a message. Made "Insert Message Buffer" try to delete a - window if the draft is a split-window draft. Made "Deliver Message" - delete a window if there are a couple lieing around and the draft is a - split-window draft. - -/usr1/lisp/nhem/command.lisp, 10-May-88 11:19:21, Edit by Chiles. - Added doc strings to "Exit Hemlock" and "Pause Hemlock". - -/usr1/lisp/nhem/files.lisp, 09-May-88 16:57:39, Edit by Chiles. - Made WRITE-FILE take keywords keep-backup (previously optional) and access. - When access is supplied non-nil, it is used as Unix modes with - MACH:UNIX-CHMOD. - -/usr1/lisp/nhem/doccoms.lisp, 10-May-88 08:27:39, Edit by Chiles. - Made "Describe Command" show bindings. Fixed bindings printing. - -/usr1/lisp/nhem/auto-save.lisp, 09-May-88 17:28:05, Edit by Chiles. - Made WRITE-CHECKPOINT-FILE call WRITE-FILE the new correct way supplying - :access #o600 for read/write by owner only. - -/usr1/lisp/nhem/spellcoms.lisp, 09-May-88 10:09:13, Edit by Chiles. - Made "Set Buffer Spelling Dictionary" hash on the namestring of the true name - instead of what was given. Made it also add the write hook instead of the - "Dictionary" file option. Stopped modifying "Write File Hook" buffer - specifically, using ADD-HOOK now. Made "Dictionary" file option LOUD-MESSAGE - if it couldn't find the dictionary file, blowing the whole thing off. - Changed "Message Buffer Insertion Prefix" to four spaces. - -/usr1/lisp/nhem/mh.lisp, 09-May-88 09:34:43, Edit by Chiles. - Fixed a bug in SETUP-HEADERS-MESSAGE-DRAFT that associated the draft with the - headers buffer which caused CLEANUP-DRAFT-BUFFER to try to delete a nil - headers mark into the headers buffer. - -/usr1/lisp/nhem/mh.lisp, 06-May-88 10:06:23, Edit by Chiles. - Renamed SETUP-MSG-BUF-REPLY-DRAFT to SETUP-MESSAGE-BUFFER-DRAFT, modifying it - to take a message buffer, message info, and a type. The type is one of - :reply, :compose, or :forward. It does the right thing. - -/usr1/lisp/nhem/tty-display.lisp, 05-May-88 17:26:08, Edit by Chiles. - Rewrote CM-OUTPUT-COORDINATE to not use TRUNCATE on floats or LOG. Changed - it from a macro to a function too. Now it builds the characters in a buffer, - using DEVICE-WRITE-STRING to send the chars out. - -/usr1/lisp/nhem/mh.lisp, 03-May-88 14:41:30, Edit by Chiles. - New Hemlock file. Ta dah! - -/usr1/lisp/nhem/bindings.lisp, 03-May-88 14:55:46, Edit by Chiles. - Added new mailer bindings. - -/usr1/lisp/nhem/display.lisp, 18-Apr-88 14:30:41, Edit by Chiles. - Added DEFVAR for *screen-image-trashed* which was lost due to old bitmap code - tossing. - -/usr1/lisp/nhem/window.lisp, 19-Apr-88 12:01:26, Edit by Chiles. - Inserted code from Owindow.Lisp (previously thrown away due to old bitmap - code tossing) that was still necessary for tty redisplay. - -/usr1/lisp/nhem/rompsite.lisp, 18-Apr-88 11:02:05, Edit by Chiles. - Made HEMLOCK-WINDOW test *hemlock-window-mngt* for being non-nil. - - Removed OBITMAP-SHOW-MARK. - - Removed loading old bitmap files from BUILD-HEMLOCK. - -/usr1/lisp/nhem/rompsite.lisp, 06-Apr-88 12:44:22, Edit by Chiles. - Made the editer server name default to "[<machine-name>:<user-name>]Editor". - -/usr1/lisp/nhem/display.lisp, 04-Apr-88 09:47:08, Edit by Chiles. - Removed some references to old bitmap redisplay in comments. - -/usr1/lisp/nhem/filecoms.lisp, 04-Apr-88 09:09:45, Edit by Chiles. - Changed the default of "Keep Backup Files" and the doc string. - -/usr1/lisp/hemlock/obit-display.lisp, 01-Apr-88 16:27:00, Edit by Chiles -/usr1/lisp/hemlock/obit-screen.lisp, 01-Apr-88 16:27:00, Edit by Chiles -/usr1/lisp/hemlock/ofont.lisp, 01-Apr-88 16:27:00, Edit by Chiles -/usr1/lisp/hemlock/owindow.lisp, 01-Apr-88 16:27:00, Edit by Chiles -/usr1/lisp/hemlock/pane-stream.lisp, 01-Apr-88 16:27:00, Edit by Chiles -/usr1/lisp/hemlock/pane.lisp, 01-Apr-88 16:27:00, Edit by Chiles -/usr1/lisp/hemlock/keyboard_codes.lisp, 01-Apr-88 16:27:00, Edit by Chiles - These files have been removed from the sources. - -/usr1/lisp/nhem/screen.lisp, 01-Apr-88 16:25:47, Edit by Chiles. - Made %INIT-SCREEN-MANAGER not regard CONSOLEP. - -/usr1/lisp/nhem/rompsite.lisp, 01-Apr-88 16:04:09, Edit by Chiles. - Rewrote (that is, mostly blew away a lot of code) GET-EDITOR-TTY-INPUT. Blew - away TRANSLATE-CHAR definition. - - Blew away all console character translation variables. - - Cleaned out console specific code in SETUP-INPUT and RESET-INPUT. - - Blew away use of *editor-console-input*. - - Blew away CONSOLEP. - - -/usr1/lisp/nhem/morecoms.lisp, 30-Mar-88 14:19:12, Edit by Chiles. - Removed unnecessary (null b) check in "List Buffers". - -/usr1/lisp/nhem/undo.lisp, 25-Mar-88 14:33:23, Edit by Chiles. - Massively documented this stuff. - -/usr0/ram/group.lisp, 21-Mar-88 13:58:49, Edit by Ram. - Changed Do-Active-Group to save and restore the Buffer-Point around the code - that hacks on the buffer. This means that group commands no longer trash the - point (which usually left you at the beginning of the buffer). - -/usr1/ch/lisp/echocoms.lisp, 21-Mar-88 13:33:57, Edit by Christopher Hoover. - Frobbed "Ignore File Types" -- deleted unknowns and added a few common - binary formats. - -/usr1/ch/lisp/auto-save.lisp, 16-Mar-88 16:54:00, Edit by Christopher Hoover. - Made the call to write-region in Auto Save supply NIL as the optional - argument for keeping backup files so that the luser does not end up - with .CKP.BAK files. - -/usr1/ch/lisp/files.lisp, 16-Mar-88 15:59:18, Edit by Christopher Hoover. - Made write-region take an optional argument which tells it whether or - not to do ":if-exist :rename" or ":if-exist :rename-and-delete". - If the argument is not supplied, it looks at the hvar "Keep Backup - Files". - -/usr1/ch/lisp/filecoms.lisp, 16-Mar-88 15:20:00, Edit by Christopher Hoover. - Added the hvar "Keep Backup Files". This variable controls whether - write region deletes .BAK files. - -/usr1/ch/lisp/filecoms.lisp, 14-Mar-88 22:14:47, Edit by Christopher Hoover. - Removed "c" and "h" from the file type hook which invokes Pascal mode - since Pascal mode is worse than Fundamental mode for editing C code. - Someday, there will be a real electric C mode. - -/usr1/lisp/nhem/rompsite.lisp, 15-Mar-88 21:00:11, Edit by Chiles. - Wrote RE-INIT-EDITOR-SERVER to be the port death handler instead of - INIT-EDITOR-SERVER. - -/usr1/lisp/nhem/morecoms.lisp, 15-Mar-88 16:25:44, Edit by Chiles. - Installed Naeem's mods to "Delete Previous Character Expanding Tabs" that - saves on the kill ring after some threshold. - -/usr1/lisp/nhem/command.lisp, 15-Mar-88 16:24:09, Edit by Chiles. - Installed Naeem's mods to "Delete Previous Character" and "Delete Next - Character" that saves on the kill ring after some threshold. - -/usr1/ch/lisp/echocoms.lisp, 14-Mar-88 21:50:47, Edit by Christopher Hoover - Deleted the hvar "Help Show Options" since it is not used anywhere. - Added a real doc string for the hvar "Beep on Ambiguity". - - Fixed Complete Keyword for files to use the new whizzy complete-file. - Added the hvar "Ignore File Types" to control which file types to - ignore. - -/usr1/lisp/nhem/morecoms.lisp, 10-Mar-88 20:59:36, Edit by Chiles. - Installed "Defhvar" command. - -/usr1/lisp/nhem/filecoms.lisp, 10-Mar-88 15:48:57, Edit by Chiles. - Modified PROCESS-FILE-OPTIONS to invoke the file type hook when no major mode - had been seen, even though some mode option had been specified. Modified the - "Mode" file option handler to return whether it had seen a major mode. - -/usr1/lisp/nhem/bit-screen.lisp, 08-Mar-88 14:57:10, Edit by Chiles. - Made REVERSE-VIDEO-HOOK-FUN make sure there is an X window for the random - typeout stream before trying to set its background. - -/usr1/lisp/nhem/fill.lisp, 06-Mar-88 21:28:51, Edit by Chiles. - Made %FILLING-SET-NEXT-LINE not call INDENT-NEW-COMMENT-LINE-COMMAND when - there is a fill prefix. - -/usr1/lisp/nhem/bit-display.lisp, 06-Mar-88 14:15:17, Edit by Chiles. - Fixed redisplay bug concerning excessive counting of lines to clear. - Otherwise case now stops counting cleared lines and packages off one clear - operations if we are currently counting. - -/usr1/lisp/nhem/font.lisp, 06-Mar-88 12:46:24, Edit by Chiles. - Made *default-font-family* have a default value so MAKE-WINDOW and things - trying to look at it under tty redisplay don't choke. - -/usr1/lisp/nhem/main.lisp, 02-Mar-88 22:03:26, Edit by Chiles. - Changed EXPORT of after-initializations to AFTER-EDITOR-INITIALIZATIONS which - is really what the macro is called. - -/usr1/lisp/nhem/font.lisp, 02-Mar-88 19:53:10, Edit by Chiles. - Rearranged some functions. Added doc strings for exported stuff. Deleted - hardwired structures. Moved two parameters to Rompsite.Lisp. Added logical - pages. - -/usr1/lisp/nhem/lispbuf.lisp, 02-Mar-88 14:12:30, Edit by Chiles. - Made SETUP-EVAL-MODE make a local binding of "Current Package" to nil. - -/usr1/lisp/nhem/lispeval.lisp, 02-Mar-88 13:42:49, Edit by Chiles. - Modified "Set Buffer Package" to set *package* when in the eval buffer. - -/usr1/lisp/nhem/bit-screen.lisp, 01-Mar-88 16:00:24, Edit by Chiles. - Made HUNK-MOUSE-ENTERED invoke the "Enter Window Hook" and made - HUNK-MOUSE-LEFT invoke the "Exit Window Hook". Fixed REVERSE-VIDEO-HOOK-FUN - to change the background pixmap for a window, so you don't get a flash of - white before Hemlock paints black when the window is exposed. - -/usr1/lisp/nhem/filecoms.lisp, 24-Feb-88 12:26:07, Edit by Chiles. - Changed "Last Resort Pathname Defaults" and "Last Resort Pathname Defaults - Function". - -/usr1/lisp/nhem/rompsite.lisp, 01-Mar-88 15:29:32, Edit by Chiles. - Made SITE-INIT define "Enter Window Hook" and "Exit Window Hook". Wrote - ENTER-WINDOW-AUTORAISE as example hook for losers into autoraising. - - Put in DEFHVAR in SITE-INIT for "Default Font". Modified INIT-RAW-IO, - SETUP-FONT-FAMILY, and OPEN-FONT in conjunction with supporting this new - variable. - -/usr1/chiles/work/temp-hem/rompsite.lisp, 22-Feb-88 21:07:14, Edit by Chiles. - Changed GET-HEMLOCK-CURSOR to not use ".mask" as a pathname, but to use - MAKE-PATHNAME :type "mask" ... instead. - -/usr1/chiles/work/temp-hem/lispeval.lisp, 22-Feb-88 21:01:49, Edit by Chiles. - Changed CLEANUP-COMPILE-NOTIFICATION to not use ".fasl" as a pathname, but to - use MAKE-PATHNAME :type "fasl" ... instead. - -/usr1/lisp/nhem/filecoms.lisp, 22-Feb-88 17:15:35, Edit by Chiles. - Introduced "Last Resort Pathname Defaults" and "Last Resort Pathname Defaults - Function" and modified BUFFER-DEFAULT-PATHNAME. - -/usr1/lisp/nhem/spellcoms.lisp, 22-Feb-88 16:50:33, Edit by Chiles. - Made "Check Word Spelling" output digits with possible correct spellings. - Made "Correct Last Misspelled Word" take 0-9 in the command loop as the - numbered word to use as a correct spelling. - -/usr1/lisp/nhem/morecoms.lisp, 22-Feb-88 13:13:54, Edit by Chiles. - Frobbed control flow in "Goto Page" and made it drop a mark when searching - page titles a first time. - -/usr1/lisp/nhem/auto-save.lisp, 18-Feb-88 17:25:10, Edit by Chiles. - Made "Save" mode turn off automatically in "Typescript" and "Eval" modes. - -/usr1/lisp/nhem/main.lisp, 18-Feb-88 17:11:12, Edit by Chiles. - Put "Save" mode in "Default Modes". - -/usr1/lisp/nhem/indent.lisp, 16-Feb-88 14:41:34, Edit by Chiles. - Fixed bug "Indent" being called with a zero argument. - -/usr1/lisp/nhem/searchcoms.lisp, 16-Feb-88 14:14:32, Edit by Chiles. - Made THE four searching commands only drop a mark if the region is not - active. Also, make i-search ^G invoke the abort-hook. Made incremental - searching commands set the last command type to nil since each letter typed - does not go through the command loop, and ephemerally active regions were - staying highlighted throughout the search. - -/usr1/lisp/nhem/lispmode.lisp, 14-Feb-88 20:34:03, Edit by Chiles. - Added DEFINDENT's for some CLOS stuff. Added one for "frob" for Rob and me. - Added a few for system calls. - -/usr1/lisp/nhem/lispeval.lisp, 11-Feb-88 13:58:31, Edit by Chiles. - Made FILE-COMPILE look at a new variable "Remote File Compile". - -/usr1/lisp/nhem/lispeval.lisp, 10-Feb-88 20:08:04, Edit by Chiles. - Made OLDER-OR-NON-EXISTENT-FASL-P's second argument optional. - -/usr1/lisp/nhem/lispbuf.lisp, 10-Feb-88 20:11:14, Edit by Chiles. - Made "List Compile Group" use OLDER-OR-NON-EXISTENT-FASL-P. - -/usr1/lisp/nhem/highlight.lisp, 10-Feb-88 19:52:50, Edit by Chiles. - Modified HIGHLIGHT-ACTIVE-REGION to not do anything when the window is the - echo area window. - -/usr1/lisp/nhem/killcoms.lisp, 10-Feb-88 15:55:19, Edit by Chiles. - Augmented the active region flag with an active region buffer variable to - circumvent echo area interactions. - -/usr1/lisp/nhem/main.lisp, 10-Feb-88 15:46:29, Edit by Chiles. - Made SAVE-ALL-BUFFERS optionally list unmodified buffers. - -/usr1/lisp/nhem/highlight.lisp, 08-Feb-88 13:49:37, Edit by Chiles. - Implemented highlighting active regions. Renamed a bunch of open paren - highlighting stuff, and frobbed it to interact with region highlighting. - -/usr1/lisp/nhem/killcoms.lisp, 08-Feb-88 13:30:20, Edit by Chiles. - Made CURRENT-REGION take another option to not deactivate the region. - -/usr1/lisp/nhem/rompsite.lisp, 06-Feb-88 16:23:45, Edit by Chiles. - Fixed bug in PRETTY-PRINT-CHARACTER that was created by INSERT-CHARACTER - checking the type of its arguments. - -/usr1/lisp/nhem/lispmode.lisp, 06-Feb-88 16:17:20, Edit by Chiles. - Fixed Scan-Direction-Valid to return NIL when it hits the end of the buffer. - -/usr1/lisp/nhem/killcoms.lisp, 06-Feb-88 10:11:35, Edit by Chiles. - Made "Exchange Point and Mark" no longer activate the region. - -/usr1/lisp/nhem/fill.lisp, 06-Feb-88 09:53:14, Edit by Chiles. - Made "Fill Paragraph" and "Fill Region" use p as the column if supplied. - -/usr1/lisp/nhem/rompsite.lisp, 04-Feb-88 15:33:11, Edit by Chiles. - Fixed the font stuff in initialization to not call TRUENAME on the font - names. This was wrong. Fixed the font stuff to be aware of a font not - opening, signalling an error if it is the default font and warning if it was - the highlighting font. - -/usr1/lisp/nhem/htext3.lisp, 04-Feb-88 16:02:41, Edit by Chiles. - Made INSERT-CHARACTER check the type of its argument. - -/usr1/lisp/nhem/searchcoms.lisp, 04-Feb-88 15:46:24, Edit by Chiles. - Fixed bug in i-search that allowed non-text characters to be searched for. - Also in the C-q case, nil was trying to be inserted into a buffer which - crashed Lisp. - -/usr1/lisp/nhem/command.lisp, 04-Feb-88 14:21:10, Edit by Chiles. - Provided error message for TEXT-CHARACTER nil result in "Self Insert" and - "Quoted Insert" - -/usr1/lisp/nhem/overwrite.lisp, 04-Feb-88 14:17:32, Edit by Chiles. - Protected use of TEXT-CHARACTER, testing for nil result. - -/usr1/lisp/nhem/lispeval.lisp, 03-Feb-88 11:57:33, Edit by Chiles. -/usr1/lisp/nhem/lispbuf.lisp, 03-Feb-88 11:57:33, Edit by Chiles. - Modified "Compile Buffer File", "Editor Compile Buffer File", "Compile - Group", and "Editor Compile Group". Deleted MAYBE-COMPILE-FILE and - MAYBE-COMPILE-EDITOR-FILE. Wrote OLDER-OR-NON-EXISTENT-FASL-P. - -/usr1/lisp/nhem/icom.lisp, 01-Feb-88 16:21:37, Edit by Chiles. - Merged Scott's hack to the comment hack to keep highlighted parens clean. - -/usr1/lisp/nhem/obit-screen.lisp, 01-Feb-88 16:08:35, Edit by Chiles. - Modified OBITMAP-MAKE-WINDOW and OBITMAP-DELETE-WINDOW to invalidate the - currently selected hunk. - -/usr1/lisp/nhem/tty-screen.lisp, 01-Feb-88 15:56:53, Edit by Chiles. - Modified TTY-MAKE-WINDOW and TTY-DELETE-WINDOW to invalidate the currently - selected hunk. - -/usr1/lisp/nhem/spellcoms.lisp, 01-Feb-88 08:28:09, Edit by Chiles. - Fixed MAYBE-READ-DEFAULT-USER-SPELLING-DICTIONARY. - -/usr1/lisp/nhem/bindings.lisp, 28-Jan-88 20:46:09, Edit by Chiles. - Deleted binding for "Compile Buffer File" in "Editor" mode. - -/usr1/lisp/nhem/interp.lisp, 28-Jan-88 11:18:47, Edit by Chiles. - Fixed problem with clearing prefix characters from the echo area when a bad - sequence is typed. - -/usr0/ram/lispmode.lisp, 27-Jan-88 17:21:48, Edit by Ram. - Wrote Find-Ignore-Region and used it to implement Valid-Spot and the new - Scan-Direction-Valid macro, which efficiently scans for a valid character - having the specified properties of its attribute. Used Scan-Direction-Valid - to substantially rewrite %Form-Offset. It now correctly handles character - literals (and as a side-effect, symbols with slashed characters). Also - changed form offset to skip over prefix characters when moving backward over - a list. Users will probably notice this, and hopefully like it. - -/usr0/ram/highlight.lisp, 27-Jan-88 17:15:35, Edit by Ram. - Changed Form-Offset to List-Offset in Maybe-Highlight-Open-Parens. Now that - backward form offset on lists include prefix characters, Form-Offset is no - longer correct. Directly doing List-Offset is slightly more efficient - anyway. - -/usr1/lisp/nhem/highlight.lisp, 27-Jan-88 15:29:50, Edit by Chiles. - Turned "Highlight Open Parens" off by default. - -/usr1/lisp/nhem/lispmode.lisp, 27-Jan-88 15:32:12, Edit by Chiles. - Turned "Paren Pause Period" and "Highlight Open Parens" on in "Lisp" mode. - Set "Paren Pause Period" to 0.5 by default. - -/usr1/lisp/nhem/tty-screen.lisp, 27-Jan-88 15:32:57, Edit by Chiles. - Made INIT-TTY-SCREEN-MANAGER make "Paren Pause Period" and "Highlight Open - Parens" be off in "Lisp" mode for tty's since we don't have highlighting - fonts for tty's. - -/usr1/lisp/hemlock/highlight.lisp, 25-Jan-88 16:19:49, Edit by DBM. - Chanded default for "Highlight Open Parens" to T. - -/usr1/lisp/nhem/newer/rompsite.lisp, 25-Jan-88 11:30:43, Edit by Chiles. - Made SLEEP-FOR-TIME deal with noting a read wait (dropping and lifting the - cursor). - -/usr1/lisp/nhem/main.lisp, 25-Jan-88 11:11:10, Edit by Chiles. - Entered DEFHVAR for "Key Echo Delay". - -/usr1/lisp/nhem/newer/interp.lisp, 25-Jan-88 11:06:01, Edit by Chiles. - Frobbed %COMMAND-LOOP to try to echo keys after some typing delay. - -/usr1/lisp/nhem/newer/lispeval.lisp, 24-Jan-88 19:43:50, Edit by Chiles. - Made DELETE-SERVER look for all bindings of "Current Eval Server", setting - them to nil if they referenced the argument info object. Also made it delete - the "Server Information" variable in the slave buffer if there was one. - -/usr1/lisp/nhem/newer/rompsite.lisp, 24-Jan-88 19:10:52, Edit by Chiles. - Modified EDITOR_CONNECT-HANDLER to define "Server Information" in the slave - buffer. - -/usr1/lisp/nhem/newer/command.lisp, 24-Jan-88 15:33:09, Edit by Chiles. - Installed Shareef's "Refresh Screen" that knows about arguments. - -/usr1/lisp/nhem/newer/lispmode.lisp, 24-Jan-88 15:27:06, Edit by Chiles. - Fixed bug in "Lisp Insert )" to make it echo the closing paren if it is not - DISPLAYED-P regardless of "Paren Pause Period". - -/usr1/lisp/nhem/highlight.lisp, 23-Jan-88 15:43:59, Edit by Chiles. - New file. - -/usr1/lisp/nhem/scribe.lisp, 23-Jan-88 15:42:11, Edit by Chiles. - Modified SCRIBE-INSERT-PAREN to know about "Paren Pause Period" possibly - being nil. - -/usr1/lisp/nhem/lispmode.lisp, 23-Jan-88 15:40:57, Edit by Chiles. - Modified "Lisp Insert )" to know about "Paren Pause Period" possibly being - nil. - -/usr1/lisp/nhem/morecoms.lisp, 23-Jan-88 15:36:22, Edit by Chiles. - Fixed "Mark Page" when point is at buffer-end. - -/usr1/lisp/nhem/srccom.lisp, 23-Jan-88 15:26:40, Edit by Chiles. - Put "Buffer Changes" from my init file into the core. - -/usr1/lisp/nhem/filecoms.lisp, 23-Jan-88 15:21:36, Edit by Chiles. - Modified "Revert File" to be more aware of whether it was backing up to the - checkpoint file or the saved file. - -/usr1/lisp/nhem/display.lisp, 23-Jan-88 14:01:50, Edit by Chiles. - Changed REDISPLAY-LOOP and REDISPLAY-WINDOWS-FROM-MARK to do the current - window first if it is going to get done, so the redisplay-hook effects could - be seen in other windows into the same buffer. - -/usr1/lisp/nhem/edit-defs.lisp, 23-Jan-88 14:47:28, Edit by Chiles. - Modified DEFINITION-EDITING-INFO to correspond to the new - FUN-DEFINED-FROM-PATHNAME ability to deal with encapsulations. - -/usr1/lisp/nhem/rompsite.lisp, 23-Jan-88 14:36:33, Edit by Chiles. - Modified FUN-DEFINED-FROM-PATHNAME, now deals with encapsulations. - -/usr1/lisp/nhem/indent.lisp, 23-Jan-88 13:42:43, Edit by Chiles. - Added Shareef's "Center Line" command. - -/usr1/lisp/nhem/files.lisp, 23-Jan-88 12:42:10, Edit by Chiles. - Made WRITE-FILE supply :if-exists :rename-and-delete. - -/usr1/lisp/nhem/lispeval.lisp, 23-Jan-88 12:28:13, Edit by Chiles. - Made "Compile File" signal an error when buffer has no associated pathname. - -/usr1/ch/lisp/filecoms.lisp, 22-Jan-88 11:48:49, Edit by Christopher Hoover - Fixed write-region to call (current-region) before prompting for filename. - This makes it work better with active regions. - -/usr1/chiles/work/modeline/window.lisp, 19-Jan-88 09:58:24, Edit by Chiles. - Modified DEFAULT-MODELINE-FUNCTION-FUNCTION and wrote - UPDATE-BUFFER-MODELINES, which is exported. - -/usr1/chiles/work/modeline/main.lisp, 19-Jan-88 10:10:27, Edit by Chiles. - Changed the value of "Default Modeline String". - -/usr1/chiles/work/modeline/lispmode.lisp, 19-Jan-88 10:05:31, Edit by Chiles. - Wrote SETUP-LISP-MODE to make a "Current Package" if there wasn't one already. - -/usr1/chiles/work/modeline/lispeval.lisp, 19-Jan-88 09:49:29, Edit by Chiles. - Made "Set Buffer Package" use PROMPT-FOR-EXPRESSION, using STRING on the - result. It also now calls UPDATE-BUFFER-MODELINES. When in a slave's - interactive buffer's, do NOT set "Current Package", but change *package* in - the slave. Modified sites of (value current-package) to supply "" instead of - the editor's *package*. - -/usr1/lisp/nhem/lispbuf.lisp, 18-Jan-88 12:50:34, Edit by Chiles. - Modified "package" file option to do a STRING of a READ-FROM-STRING. - -/usr1/lisp/nhem/ts.lisp, 17-Jan-88 20:53:13, Edit by Chiles. - Made MAKE-TYPESCRIPT use "Interactive History Length" when setting up - "Interactive History". - -/usr1/lisp/nhem/lispbuf.lisp, 17-Jan-88 20:51:25, Edit by Chiles. - Moved some stuff around. Created "Interactive History Length" used to setup - "Interactive History" when "Eval" mode is turned on. - -/usr1/lisp/nhem/spellcoms.lisp, 16-Jan-88 16:58:31, Edit by Chiles. - Introduced "Default User Spelling Dictionary". When set, this is loaded upon - entering "Spell" mode and when "Set Buffer Spelling Dictionary" (or - "dictionary" file option) runs. Also, "Save Incremental Spelling Insertions" - doesn't prompt for a file if this is set. - - Made SAVE-DICTIONARY-ON-WRITE make sure 'spell-information is bound in the - buffer. - -/usr1/ch/lisp/auto-save.lisp, 12-Jan-88 16:28:56, Edit by Christopher Hoover - Wrapped a condition-case around the write-file in Auto Save. This will cause - Auto Save to graceful handle write failures. - -/usr1/lisp/nhem/spellcoms.lisp, 06-Jan-88 22:14:14, Edit by Chiles. - Made incremental insertions dictionary specific with a global default for - upward compatability. - Commands with new names: - "Append to Spelling Dictionary" --> "Save Incremental Spelling Insertions" - "Augment Spelling Dictionary" --> "Read Spelling Dictionary" - New commands: - "Set Buffer Spelling Dictionary" - "Remove Word from Spelling Dictionary" - "List Incremental Spelling Insertions" - AND there is a "dictionary" file option that read a dictionary if necessary, - makes it the buffer's dictionary, and causes the incremental insertions for - this dictionary to be written when the buffer is. - - Added "Spelling Un-Correct Prompt for Insert" that makes "Undo Last Spelling - Correction" prompt before inserting word into dictionary. - -/usr1/lisp/nhem/doccoms.lisp, 22-Dec-87 15:42:26, Edit by Chiles. - Changed #\S help to #\V, "Describe and show Variable". Rewrote some code to - do this and added the command "Describe and show Variable". - -/usr1/lisp/nhem/spell-augment.lisp, 17-Dec-87 21:05:37, Edit by Chiles. - Added SPELL-ROOT-FLAGS, which returns a list of the letter flags a root entry - has, and SPELL-REMOVE-ENTRY, which removes an entry by clearing a flag if - appropriate or setting the dictionary element to -1. - -/usr1/lisp/nhem/spell-correct.lisp, 17-Dec-87 20:34:09, Edit by Chiles. - Made TRY-WORD-ENDINGS return the flag mask when a flag was used instead of - just t. Modified lookup hashing to know about deleted elements. - -/usr1/lisp/nhem/echo.lisp, 16-Dec-87 21:25:58, Edit by Chiles. - MAYBE-WAIT should really do a SLEEP instead of EDITOR-SLEEP to make sure - nothing happens while the user is trying to see the message. - -/usr1/lisp/nhem/active/text.lisp, 14-Dec-87 01:25:42, Edit by Chiles. - Made "Mark Paragraph" and "Mark Sentence" use PUSH-BUFFER-MARK, so it will - activate the region. - -/usr1/lisp/nhem/active/lispmode.lisp, 14-Dec-87 01:25:03, Edit by Chiles. - Made "Mark Defun" and "Mark Form" use PUSH-BUFFER-MARK, so it will activate - the region. - -/usr1/lisp/nhem/active/morecoms.lisp, 13-Dec-87 20:45:48, Edit by Chiles. - Modified "Insert Page Directory" to insert the listing at the curren point if - invoked with an argument. - -/usr1/lisp/nhem/active/lispeval.lisp, 12-Dec-87 13:15:04, Edit by Chiles. - Defined "Slave Utility Name" and "Slave Arguments" and made CREATE-SLAVE use - these to spawn Lisps. - -/usr1/lisp/nhem/active/main.lisp, 11-Dec-87 07:24:44, Edit by Chiles. - Defined and invoked "Reset Hook". - -/usr1/lisp/nhem/active/xcommand.lisp, 11-Dec-87 05:37:26, Edit by Chiles. - Made "Region to Cut Buffer" use CURRENT-REGION, insisting it be active. - -/usr1/lisp/nhem/active/lispbuf.lisp, 11-Dec-87 05:16:46, Edit by Chiles. - Made commands use CURRENT-REGION, insisting it be active. Changed the - semantics of "Editor Compile Defun" "Editor Evaluate Defun". - -/usr1/lisp/nhem/active/indent.lisp, 11-Dec-87 03:49:08, Edit by Chiles. - Made "Indent Region" and "Indent Rigidly" use CURRENT-REGION, insisting it be - active. - -/usr1/lisp/nhem/active/fill.lisp, 11-Dec-87 03:16:15, Edit by Chiles. - Made "Fill Region" use CURRENT-REGION, insisting it be active. - -/usr1/lisp/nhem/active/filecoms.lisp, 11-Dec-87 03:12:25, Edit by Chiles. - Made "Write Region" use CURRENT-REGION, insisting it be active. - -/usr1/lisp/nhem/active/abbrev.lisp, 11-Dec-87 03:05:12, Edit by Chiles. - Modified commands to use CURRENT-REGION, not insisting it be active. - -/usr1/lisp/nhem/active/morecoms.lisp, 11-Dec-87 02:40:31, Edit by Chiles. - Changed calls to PUSH-BUFFER-MARK that shouldn't activate the region. Made - "Count Lines Region" and "Count Words Region" use CURRENT-REGION, not - insisting it be active (for now). "Insert Page Directory" sets the command - type to :ephemerally-active, so "Kill Region" can kill the inserted text. - -/usr1/lisp/nhem/active/lispeval.lisp, 11-Dec-87 01:52:20, Edit by Chiles. - Made "Edit Compiler Errors" not activate the region when it calls - PUSH-BUFFER-MARK. Made commands use CURRENT-REGION, insisting it be active. - Changed the semantics of "Compile Defun" and "Evaluate Defun". Fixed bug in - FILE-COMPILE-TEMP-FILE. - -/usr1/lisp/nhem/active/edit-defs.lisp, 11-Dec-87 01:32:31, Edit by Chiles. - Made GO-TO-DEFINITION not activate the region when it calls - PUSH-BUFFER-MARK. - -/usr1/lisp/nhem/active/command.lisp, 11-Dec-87 01:25:22, Edit by Chiles. - Made "Beginning of Buffer" and "End of Buffer" not activate the region when - they call PUSH-BUFFER-MARK. - -/usr1/lisp/nhem/active/register.lisp, 11-Dec-87 01:01:22, Edit by Chiles. - Fixed bug in cleanup for deleted buffers -- should free register when its a - mark since you cannot list it. Made "Get Register" set LAST-COMMAND-TYPE to - :ephemerally-active, so "Kill Region" can kill the inserted text. - -/usr1/lisp/nhem/active/bindings.lisp, 10-Dec-87 23:41:40, Edit by Chiles. - Added bindings for "Activate Region", "Pop and Goto Mark", and "Pop Mark". - Bound "Verbose Directory" to ^X^D and destroyed translation for ^D, so I - duplicated bindings for "Delete Next Character" and "Scribe Display". - -/usr1/lisp/nhem/macros.lisp, 10-Dec-87 16:49:39, Edit by Chiles. - Made ADD-HOOK use PUSHNEW. - -/usr1/lisp/nhem/register.lisp, 10-Dec-87 00:08:00, Edit by Chiles. - New Register hacking code. - -/usr1/lisp/nhem/bindings.lisp, 09-Dec-87 13:55:22, Edit by Chiles. - Made bindings for "Transpose Regions" and "Directory". - Added default bindings for register stuff. - -/usr1/lisp/nhem/morecoms.lisp, 09-Dec-87 13:36:55, Edit by Chiles. - Added "Transpose Regions". - -/usr1/lisp/nhem/doccoms.lisp, 09-Dec-87 13:20:28, Edit by Chiles. - Wrote "Show Variable". - -/usr1/lisp/nhem/echo.lisp, 09-Dec-87 13:04:50, Edit by Chiles. - Modified PROMPT-FOR-VARIABLE and wrote VARIABLE-VERIFICATION-FUNCTION to - notice when a variable completion lost due to multiple entries of the same - variable. - -/usr1/lisp/nhem/spellcoms.lisp, 09-Dec-87 01:05:57, Edit by Chiles. - Made "Append to Spelling Dictionary" take an optional file argument. - -/usr1/lisp/nhem/edit-defs.lisp, 08-Dec-87 18:18:44, Edit by Chiles. - Merged with lost sources to get back the preference translation functionality - where one directory can be mapped to an ordered list of translations. - -/usr1/lisp/nhem/lispeval.lisp, 08-Dec-87 22:54:12, Edit by Chiles. - Modifed eval-notification structure, EVAL-OPERATION_COMPLETE, REGION-EVAL, - and FILE-COMPILE-TEMP-FILE. Wrote PATHNAME-FOR-REMOTE-ACCESS and STRING-EVAL - and the command "Load File". - -/usr1/lisp/nhem/lispbuf.lisp, 08-Dec-87 19:48:43, Edit by Chiles. - Renamed "Load File" to be "Editor Load File". - -/usr1/lisp/nhem/main.lisp, 05-Dec-87 18:14:19, Edit by Chiles. - Defined "Redisplay Hook". - -/usr1/lisp/nhem/display.lisp, 05-Dec-87 15:37:53, Edit by Chiles. - Put a redisplay hook into REDISPLAY-WINDOW-RECENTERING. - -/usr1/lisp/nhem/rompsite.lisp, 04-Dec-87 21:10:14, Edit by Chiles. - Made SITE-WRAPPER-MACRO bind *standard-input* to a stream that disallows - reads. This is to keep people from losing in "Eval" mode. - -/usr1/lisp/nhem/filecoms.lisp, 04-Dec-87 15:00:50, Edit by Chiles. - Made "Visit File" set buffer-writable, so the buffer's region could be - deleted when the buffer was read only. - -/usr1/lisp/nhem/edit-defs.lisp, 04-Dec-87 14:54:21, Edit by Chiles. - Created "Editor Definition Info" variable to control where "Edit - Definition" and "Go to Definition" get their defined from information, - the editor Lisp or the slave Lisp. - -/usr1/lisp/nhem/lispbuf.lisp, 04-Dec-87 13:52:46, Edit by Chiles. - Made "Editor Definition Info" t in "Eval" mode. - -/usr1/lisp/nhem/lispeval.lisp, 04-Dec-87 13:53:20, Edit by Chiles. - Made "Editor Definition Info" t in "Editor" mode. - -/usr1/lisp/hemlock/lispeval.lisp, 02-Dec-87 13:23:27, Edit by DBM. - Mofified for new name server. - -/usr1/lisp/hemlock/rompsite.lisp, 02-Dec-87 13:22:10, Edit by DBM. - Modified for new name server. - -/usr1/lisp/nhem/bit-screen.lisp, 29-Nov-87 22:55:03, Edit by Chiles. - Made BITMAP-DELETE-WINDOW call REMOVE-XWINDOW-OBJECT on the X window - instead of the Hemlock window. - -/usr1/lisp/nhem/auto-save.lisp, 23-Nov-87 15:59:36, Edit by Chiles. - Picked up Chris' latest version. Tweaked a defvar into a defhvar. - Changed its reference and made "Save" mode be turned off when nil or an - empty pathname is returned. - -/usr1/lisp/nhem/lispeval.lisp, 23-Nov-87 14:33:19, Edit by Chiles. - Fixed logic error in GET-CURRENT-SERVER. - -/usr1/lisp/nhem/lispeval.lisp, 20-Nov-87 14:17:52, Edit by Chiles. - Wrote CALL-EVAL_FORM that makes sure the server isn't busy, binds and - error handler, and binds a server death handler. EVAL_FORM-IN-CLIENT and - "Re-Evaluate Defvar" use this. - -/usr1/lisp/nhem/rompsite.lisp, 20-Nov-87 13:22:23, Edit by Chiles. - Made GET-HEMLOCK-CURSOR do a TRUENAME on the cursor bitmap file variable. - -/usr1/lisp/nhem/searchcoms.lisp, 20-Nov-87 11:56:35, Edit by Chiles. - "Delete Matching Lines" modified and new "Delete Non-Matching Lines" by - Chris. - -/usr1/lisp/nhem/killcoms.lisp, 20-Nov-87 11:58:26, Edit by Chiles. - "Delete Blank Lines" added by Chris. - -/usr1/lisp/nhem/bindings.lisp, 20-Nov-87 12:06:58, Edit by Chiles. - Added binding for "Delete Blank Lines". - -/usr1/lisp/nhem/morecoms.lisp, 20-Nov-87 12:10:21, Edit by Chiles. - Added Chris' "Count Words Region". - -/usr1/lisp/nhem/bit-screen.lisp, 19-Nov-87 00:02:04, Edit by Chiles. - Fixed problem with flushing random typeout with the mouse over the - typeout window. Apparently when X buries a window, you do not get an - exit event, but Hemlock was getting an entered event and causing the - cursor to get out of sync. - -/usr1/lisp/nhem/lispeval.lisp, 18-Nov-87 22:39:54, Edit by Chiles. - Rewrote CHECK-SERVER-INFO, SUB-CHECK-SERVER-INFO, and GET-CURRENT-SERVER. - Added MAYBE-CREATE-SLAVE in the process. Now when the current eval - server dies, the next Lisp interaction command does not signal an error - but tries to get a valid slave for the user. - -/usr1/lisp/nhem/rompsite.lisp, 18-Nov-87 01:07:02, Edit by Chiles. - Wrote EDITOR-INPUT-METHOD-MACRO to replace the bodies of EDITOR-TTY-IN - and EDITOR-WINDOW-IN. Added to the macro a test for re-entering a - Hemlock input method, signalling an error if this happens. Added a - binding of an error condition handler that exits Hemlock and goes into - the debugger. - -/usr1/lisp/hemlock/bit-screen.lisp, 17-Nov-87 17:03:15, Edit by Chiles. - Made enter and exit window event handlers call CURSOR-INVERT-CENTER when - the cursor is dropped. - -/usr1/lisp/nhem/lispeval.lisp, 17-Nov-87 15:40:42, Edit by Chiles. - Made CREATE-SLAVE not call INIT-EDITOR-SERVER since we presumably catch - nameserver crashes now. - -/usr1/lisp/nhem/lispbuf.lisp, 15-Nov-87 20:30:20, Edit by Chiles. - Made "Compile File" do an update compilation. - -/usr1/lisp/nhem/lispeval.lisp, 15-Nov-87 20:11:12, Edit by Chiles. - Made "Compile File" do an update compilation. - -/usr1/lisp/nhem/main.lisp, 15-Nov-87 18:20:19, Edit by Chiles. - Fixed doc string of ED to escape some "'s. - -/usr1/lisp/nhem/morecoms.lisp, 15-Nov-87 17:27:12, Edit by Chiles. - Made "Exit Recursive Edit" and "Abort Recursive Edit" call - IN-RECURSIVE-EDIT, signalling an error when nil. - -/usr1/lisp/nhem/buffer.lisp, 15-Nov-87 16:48:01, Edit by Chiles. - Made EXIT-RECURSIVE-EDIT and ABORT-RECURSIVE-EDIT signal an error when - not in a recursive edit. Wrote IN-RECURSIVE-EDIT. - -/usr1/lisp/nhem/lispbuf.lisp, 15-Nov-87 13:45:32, Edit by Chiles. - Made "Load File" supply (or load default buffer pathname default) for - :default to PROMPT-FOR-FILE. - -/usr1/lisp/nhem/, 15-Nov-87 13:24:00, Edit by Chiles. - Renamed Integrity.Lisp to Hi-Integrity.Lisp. Created Ed-Integrity.Lisp - that currently includes tty redisplay testing code. Modified Ctw.Lisp to - conform with these two changes. - -/usr1/lisp/nhem/tty-display.lisp, 15-Nov-87 12:35:09, Edit by Chiles. - Generally added major gobs of documentation. - Modified: - COMPUTE-TTY-CHANGES - Introduced cum-inserts. - Changed computation of line deletions location. - Changed where deletions are done for the modeline due to excessive - insertion above it. - DO-SEMI-DUMB-LINE-WRITES - Commented out a somewhat bogus optimization that was causing - TTY-SMART-WINDOW-REDISPLAY to lose when "Scroll Redraw Ration" - kicked in. - DELETE-SI-LINES - INSERT-SI-LINES - Changed variable names. - -/usr1/lisp/nhem/filecoms.lisp, 14-Nov-87 13:38:42, Edit by Chiles. - Made "Write Region" use BUFFER-PATHNAME-DEFAULTS. - -/usr1/lisp/nhem/lispeval.lisp, 11-Nov-87 21:54:53, Edit by Chiles. - Modified "Edit Compiler Errors" to not switch to errors buffer unless it - has too. This fixes spurious redisplay when there are no errors to edit. - -/usr1/lisp/nhem/main.lisp, 10-Nov-87 19:19:13, Edit by Chiles. - Removed DEFHVAR's for "Timer Hook" and "Timer Hook Interval". - -/usr1/lisp/nhem/rompsite.lisp, 10-Nov-87 19:15:25, Edit by Chiles. - Added page title "Time queue". This is used in editor input stream in - methods in conjunction with user interfaces SCHEDULE-EVENT and - REMOVE-SCHEDULED-EVENT to all the user to have functions invoked - periodically. - -/usr1/lisp/nhem/main.lisp, 09-Nov-87 21:23:37, Edit by Chiles. - Added AFTER-EDITOR-INITIALIZATIONS macro. Made ED funcall stuff on - *after-editor-initializations-funs* put there by the macro. - -/usr1/lisp/nhem/filecoms.lisp, 06-Nov-87 00:59:21, Edit by Chiles. - Modified WRITE-DA-FILE and READ-DA-FILE to invoke the "Write File Hook" - and "Read File Hook" hooks. eh! - -/usr2/lisp/nhem/lispeval.lisp, 26-Oct-87 11:36:35, Edit by Chiles. - Put back in feature of restoring previous buffer in "Edit Compiler - Errors" that was lost somehow. - -/usr2/lisp/nhem/filecoms.lisp, 25-Oct-87 17:13:04, Edit by Chiles. - ROB: Split two subfunctions off of "Find File". FIND-FILE-BUFFER does - all the work, returning the buffer and a flag indicating whether it - created a buffer. Fixed some :prompt values. - -/usr2/lisp/nhem/edit-defs.lisp, 25-Oct-87 16:42:00, Edit by Chiles. - Fixed bug in GET-DEFINITION-PATTERN for type :command. - -/usr0/ram/group.lisp, 04-Oct-87 15:10:49, Edit by Ram. - Changed Group-Read-File to use Find-File-Buffer instead of Find-File-Command, - eliminating the need for gruesome hacks to tell whether a buffer was created. - This also has the beneficial side-effect of making it easy for group commands - to leave to buffer history intact. Changed Do-Active-Group to restore the - buffer that was current at the time the command was done. - -/usr1/lisp/hemlock/hunk-draw.lisp, 23-Oct-87 15:45:14, Edit by Chiles. - Wrote CURSOR-INVERT-CENTER to hollow out the center of the cursor. THis - is used when Hemlock is not the listener to corresspond with Xterm - behaviour. Modified DROP-CURSOR and LIFT-CURSOR to use this new fun too - when Hemlock is not the listener, so we don't get little black squares or - empty boxes when we should. - -/usr2/lisp/nhem/filecoms.lisp, 23-Oct-87 15:36:25, Edit by Chiles. - Inserted Chris Hoover's "Revert File" and "Mode" file option definitions. - -/usr2/lisp/nhem/hunk-draw.lisp, 23-Oct-87 15:24:36, Edit by Chiles. - Fixed documentation for DRAW-HUNK-BOTTOM-BORDER and HUNK-REPLACE-MODELINE, - stating dependencies on BITMAP-HUNK-MODELINE-POS not returning nil. - -/usr2/lisp/nhem/bit-screen.lisp, 23-Oct-87 15:16:40, Edit by Chiles. - Fixed a usage of BITMAP-HUNK-MODELINE-POS that was assuming it was never - nil. - -/usr1/lisp/hemlock/lispeval.lisp, 23-Oct-87 12:10:09, Edit by DBM. - File-compile, Region-eval, and region-compile were passing a - structure as a port to the servers. - -/usr2/lisp/nhem/bindings.lisp, 23-Oct-87 11:58:45, Edit by Chiles. - Killed bindings for c-m-c and c-m-\c in "Echo Area". - -/usr2/lisp/nhem/bit-screen.lisp, 22-Oct-87 15:43:08, Edit by Chiles. - Fixed BITMAP-MAKE-WINDOW to set the thumb-bar-p slot to (and - modeline-string (value thumb-bar-meter)) instead of just the Hvar's - value. Windows without modelines were get a nil not number error. - -/usr2/lisp/nhem/lispbuf.lisp, 16-Oct-87 14:04:38, Edit by Chiles. - Made DESCRIBE-SYMBOL-AUX slightly better with respect to (quote <symbol>) - (function <symbol>). - -/usr2/lisp/nhem/lispeval.lisp, 15-Oct-87 22:22:13, Edit by Chiles. - Made DESCRIBE-SYMBOL-AUX slightly better with respect to (quote <symbol>) - (function <symbol>). - -/usr2/lisp/nhem/edit-defs.lisp, 15-Oct-87 21:02:29, Edit by Chiles. - Added a hack to catch command definitions when looking for the name of a - function, and the last sever letters of the function name are "COMMAND". - -/usr2/lisp/nhem/bit-screen.lisp, 15-Oct-87 16:33:54, Edit by Chiles. - Made HUNK-EXPOSED-OR-CHANGED take a width and height argument since the X - exposedwindow handler is supposed to now and eliminated the call to - FULL-WINDOW-STATE. - -/usr1/lisp/hemlock/rompsite.lisp, 12-Oct-87 16:56:14, Edit by DBM. - Added auto-save.fasl to list of files loaded. - -/usr1/lisp/hemlock/auto-save.lisp, 12-Oct-87 16:49:34, Edit by DBM. - Added to the hemlock sources. - -/usr2/lisp/nhem/lispeval.lisp, 06-Oct-87 00:18:25, Edit by Chiles. - Modified "Edit Compiler Errors" to save a pointer to the previous buffer - when moving to the background buffer, and to use this before EDITOR-ERROR - calls to restore the user's position. - -/usr2/lisp/nhem/edit-defs.lisp, 01-Oct-87 14:06:00, Edit by Chiles. - Rewrote translation stuff and GO-TO-DEFINITION to handle a list of - translations for a given match. This allows me to first look on - vancouver, then wb1, then lisp-rt1, then fred, etc. for sources depending - on which machines are down. - -/usr2/lisp/nhem/filecoms.lisp, 01-Oct-87 12:20:46, Edit by Chiles. - Modified "Save All Files" to show the file it is going to write when - prompting, and when the buffer name is not derived from the pathname, it - shows both. - -/usr2/lisp/nhem/bit-screen.lisp, 30-Sep-87 22:39:37, Edit by Chiles. - Rewrote BITMAP-DELETE-WINDOW to not lose when a window is made and then - deleted right away. Created DELETING-WINDOW-DROP-EVENT that drops - pending events for a window that is about to be deleted. Also, made - BITMAP-DELETE-WINDOW lift the cursor when the window being deleted - displayed the cursor. - -/usr2/lisp/nhem/ts.lisp, 30-Sep-87 21:57:18, Edit by Chiles. - Made PROCESS_OPERATION_CONTROL-HANDLER test for *in-top-level-catcher* - before throwing to top level. - -/usr2/lisp/nhem/tty-display.lisp, 29-Sep-87 15:40:22, Edit by Chiles. - Modified TTY-SMART-CLEAR-TO-EOW and TTY-DUMB-WINDOW-REDISPLAY to clear - screen image lines properly ... had some off-by-one problems. - -/usr2/lisp/nhem/lispbuf.lisp, 28-Sep-87 12:59:25, Edit by Chiles. - Made "Editor Compile Defun" and "Editor Compile Region" call - COMPILE-FROM-STREAM with :defined-from-pathname supplied as the buffer's - pathname. - -/usr2/lisp/nhem/rompsite.lisp, 28-Sep-87 11:21:07, Edit by Chiles. - Made FUN-DEFINED-FROM-PATHNAME test for "/..", clipping it and the - machine name if it is present in the defining file name. - -/usr2/lisp/nhem/lispeval.lisp, 25-Sep-87 11:42:25, Edit by Chiles. - Modified "Set Eval Buffer" to set the global eval server always. - Modified "Set Compile Server" to set the global compile server always. - Rewrote or added support routines SELECT-CURRENT-SERVER, - SELECT-GLOBAL-SERVER, SELECT-CURRENT-COMPILE-SERVER, - SELECT-GLOBAL-COMPILE-SERVER, GET-CURRENT-SERVER, CHECK-SERVER-INFO. - Modified "Select Background" to try for the current compile server's - background with a prefix argument. Modified "Edit Compiler Errors" to - look for a compile server before using the current eval server. Added - commands "Current Eval Server" and "Current Compile Server". Introduced - "Prompt for Current Server", so CHECK-SERVER-INFO does not prompt for - creating a new slave but prompts for an already known server instead. - -/usr2/lisp/nhem/morecoms.lisp, 24-Sep-87 23:12:42, Edit by Chiles. - Modified "List Buffers" to show both buffer name and pathname when the - are different and both exist. - -/usr2/lisp/nhem/hunk-draw.lisp, 25-Sep-87 09:48:17, Edit by Chiles. - Made HUNK-DRAW-BOTTOM-BORDER enhance the 80'th notch it draws. - -/usr2/lisp/nhem/defsyn.lisp, 24-Sep-87 23:32:57, Edit by Chiles. - Made #\formfeed no longer is a whitespace character. - -/usr2/lisp/nhem/bindings.lisp, 24-Sep-87 23:28:26, Edit by Chiles. - Did some "Argument Digit" binding. - -/usr2/lisp/nhem/lispmode.lisp, 24-Sep-87 23:24:29, Edit by Chiles. - "Minimum Lines Parsed" and "Maximum Lines Parsed" now default to 50 and - 500. - -/usr2/lisp/nhem/searchcoms.lisp, 24-Sep-87 23:22:41, Edit by Chiles. - Made "Count Occurrences" use echo area for result instead of random - typeout. - -/usr2/lisp/nhem/filecoms.lisp, 24-Sep-87 22:16:48, Edit by Chiles. - Made default for "Save All Files Confirm" be t. - -/usr2/lisp/nhem/bindings.lisp, 24-Sep-87 22:11:20, Edit by Chiles. - Made binding for "Select Background", C-M-C. - -/usr2/lisp/nhem/lispbuf.lisp, 24-Sep-87 22:02:32, Edit by Chiles. - Changed "Lisp Describe" to "Editor Describe". - -/usr2/lisp/nhem/doccoms.lisp, 24-Sep-87 21:56:40, Edit by Chiles. - Replaced instance of LISP-DESCRIBE-COMMAND with EDITOR-DESCRIBE-COMMAND. - -/usr2/lisp/nhem/lispbuf.lisp, 24-Sep-87 21:48:36, Edit by Chiles. - Removed "Eval Mode" command. - -/usr2/lisp/nhem/lispeval.lisp, 24-Sep-87 00:21:19, Edit by Chiles. - Fixed "Set Buffer Package" to not try to access nil when there isn't a - current eval server. Also, made it test for the server being valid - before trying to use it. - -/usr2/lisp/nhem/lispeval.lisp, 23-Sep-87 22:49:32, Edit by Chiles. - Modified GET-CURRENT-SERVER and CREATE-SERVER to use - MAYBE-GET-SLAVE-NAME. - -/usr2/lisp/nhem/rompsite.lisp, 23-Sep-87 22:27:38, Edit by Chiles. - Modified EDITOR_CONNECT-handler to handler name argument differently. - Added definition of "Thumb Bar Meter" to SITE-INIT. - -/usr2/lisp/nhem/bit-screen.lisp, 23-Sep-87 15:03:12, Edit by Chiles. - Made HUNK-EXPOSED-REGION and HUNK-RESET call HUNK-DRAW-BOTTOM-BORDER. - -/usr2/lisp/nhem/hunk-draw.lisp, 23-Sep-87 14:56:44, Edit by Chiles. - Renamed HUNK-DRAW-TOP-BORDER to HUNK-DRAW-BOTTOM-BORDER and made it do it - to the bottom. Made hunk-bottom-border be 10 instead of 3. - -/usr2/lisp/nhem/bindings.lisp, 21-Sep-87 17:13:39, Edit by Chiles. - Made "Compile File" be the default binding for "Editor" mode. - -/usr2/lisp/nhem/rompsite.lisp, 21-Sep-87 12:55:58, Edit by Chiles. - Modified EDITOR-WINDOW-IN to not use VARIABLE-VALUE four times in a loop. - Likewise for EDITOR-TTY-IN. - -/usr2/lisp/nhem/edit-defs.lisp, 20-Sep-87 23:57:08, Edit by Chiles. - Rewrote GET-DEFINTION-FILE and wrote MAYBE-TRANSLATE-DEFINITION-FILE to - have definition directory translation done in the editor instead of the - client. - -/usr2/lisp/nhem/bindings.lisp, 15-Sep-87 16:44:28, Edit by Chiles. - Made prefix key translation for #\control-^ to be :control. - -/usr2/lisp/nhem/lispeval.lisp, 14-Sep-87 22:09:42, Edit by chiles. - Modified "Set Buffer Package" to use new TL:SET_PACKAGE interface. - -/usr2/lisp/nhem/htext4.lisp, 14-Sep-87 17:27:44, Edit by chiles. - Modified DELETE-CHARACTERS to do nothing and return t when n = 0. - Modified DELETE-REGION to do nothing when the region is empty. - Modified DELETE-AND-SAVE-REGION to just return an empty region when its - argument is empty. - -/usr2/lisp/nhem/htext3.lisp, 14-Sep-87 17:12:52, Edit by chiles. - Modified INSERT-STRING to not modify buffer when the string is empty. - INSERT-CHARACTER always modifies the buffer. - INSERT-REGION wins on empty regions because of INSERT-STRING. - -/usr2/lisp/nhem/display.lisp, 14-Sep-87 17:14:52, Edit by chiles. - Added some documentation to REDISPLAY-WINDOW-RECENTERING. Modified - MAYBE-UPDATE-WINDOW-IMAGE to return to or nil based on whether it updated - the window image. - -/usr2/lisp/nhem/cursor.lisp, 14-Sep-87 16:59:56, Edit by chiles. - Modified MAYBE-RECENTER-WINDOW to return t or nil based on whether it - recentered. - -/usr2/lisp/nhem/filecoms.lisp, 13-Sep-87 18:37:15, Edit by Chiles. - Made "Log Entry Template" capitalize file author. - -/usr2/lisp/nhem/lispeval.lisp, 13-Sep-87 17:59:15, Edit by Chiles. - Modified server-info structure, removing the ll-buffer slot in favor of a - slave-ts slot. Modified CREATE-SLAVE to pass the -slave switch the name - of the editor server in case two people are on the same machine (in which - case they must use -edit differently), and instead of using EDITOR-SLEEP, - it now uses SERVER (it was returning immediately on input with - EDITOR-SLEEP). Modified REGION-EVAL, REGION-COMPILE, and FILE-COMPILE to - pass the slave-ts slot of the server-info structure of the notification, - so terminal-io will happen in the interactive buffer for the server - instead of the background buffer. - -/usr2/lisp/nhem/main.lisp, 13-Sep-87 14:32:47, Edit by Chiles. - Added DEFHVAR's for "Input Hook", "Timer Hook", and "Timer Hook - Interval". Added code in ED to handle Hemlock specific init files. - -/usr2/lisp/nhem/ts.lisp, 13-Sep-87 15:34:09, Edit by Chiles. - Modified READ-OR-HANG to message about input waits that occur while a - buffer is not visible. Introduced variable "Input Wait Alarm". - -/usr2/lisp/nhem/rompsite.lisp, 13-Sep-87 14:41:27, Edit by Chiles. - Made editor input stream methods deal with "Input Hook", "Timer Hook", - and "Timer Hook Interval". Modified EDITOR_CONNECT-HANDLER to correspond - with new server-info structure. - -/usr1/lisp/hemlock/rompsite.lisp, 10-Sep-87 14:38:14, Edit by DBM. - Now that Lisp no longer diddles the interrupt characters, the bare - console has to be modified so that it doesn't send one of the standard - control characters as part of the encoding for control characters. - -/usr0/ram/htext1.lisp, 10-Sep-87 13:29:50, Edit by Ram - Added a without-interrupts in Close-Line and some warnings about exclusion - elsewhere. - -/usr2/lisp/nhem/lispbuf.lisp, 09-Sep-87 22:09:00, Edit by Chiles. - Wrote "Select Eval Buffer" command. - -/usr2/lisp/nhem/lispeval.lisp, 09-Sep-87 21:47:46, Edit by Chiles. - Rewrote the local queuing of :unsent notifications. This involved - deleting all the old stuff and changing KILL-NOTIFICATION and - MAYBE-QUEUE-OPERATION-REQUEST. - -/usr2/lisp/nhem/filecoms.lisp, 09-Sep-87 18:17:34, Edit by Chiles. - Changed "Log Entry Template". - -/usr2/lisp/nhem/rompsite.lisp, 09-Sep-87 18:06:39, Edit by Chiles. - Made MORE-READ-CHAR call REDISPLAY while looping on SERVER. - -/usr2/lisp/nhem/tty-display-rt.lisp, 09-Sep-87 16:00:26, Edit by Chiles. - Modified INIT-TTY-DEVICE and EXIT-TTY-DEVICE to not assume that - system:*file-input-handlers* had an association for Unix stdin (0). - -/usr2/lisp/nhem/lispbuf.lisp, 08-Sep-87 14:04:00, Edit by Chiles. - Replaced appropriate occurrences of "top-level" and "top level" with - "eval". - -/usr2/lisp/nhem/lispeval.lisp, 07-Sep-87 20:56:39, Edit by Chiles. - Replaced occurrences of "lisp listener" with "slave lisp" or "lisp - interaction". Renamed things to to with "anonymous client lisp" to - "slave". - -/usr2/lisp/nhem/tty-display-rt.lisp, 06-Sep-87 18:47:02, Edit by Chiles. - Added some documentation to the exit method. - -/usr2/lisp/nhem/filecoms.lisp, 03-Sep-87 16:12:28, Edit by Chiles. - Made "Directory" list Unix dot files if the prefix is supplied and made - the random typeout window have the right number of lines for each - listing. Made a "Verbose Directory" command like "Directory" but based - on the new :verbose argument to PRINT-DIRECTORY. - -/usr2/lisp/nhem/rompsite.lisp, 06-Sep-87 18:07:40, Edit by Chiles. - Fixed INIT-RAW-IO again to not push into system:*file-input-handlers*. - Modified EDITOR_CONNECT-HANDLER to make "Slave Lisp <n>" buffer names - instead of "Lisp Listener <n>" buffer names. - -/usr2/lisp/nhem/tty-display.lisp, 06-Sep-87 16:54:18, Edit by Chiles. - Fixed TTY-SMART-CLEAR-TO-EOW boundary condition -- when clearing last - line of window to eow, needed >= test instead of = test. - -/usr2/lisp/nhem/bindings.lisp, 05-Sep-87 15:52:11, Edit by Chiles. - Deleted binding of "Exit Hemlock" to C-c since it is later used for - "Process Control". Changed binding of "Select Lisp Listener" to be a - binding for "Select Slave Lisp". Replaced occurrences of "top-level" - with "eval". - -/usr2/lisp/nhem/morecoms.lisp, 05-Sep-87 14:08:32, Edit by Chiles. - Made "List Buffers" print pathnames with the FILE-NAMESTRING first - followed by two spaces and the DIRECTORY-NAMESTRING. - -/usr2/lisp/nhem/hunk-draw.lisp, 01-Sep-87 15:02:57, Edit by Chiles. - Made CURSOR-INVERT do an X:XFLUSH. - -/usr2/lisp/nhem/bindings.lisp, 01-Sep-87 15:00:47, Edit by Chiles. - Fixed merge lossage from re-integration with sources. - -/usr2/lisp/nhem/bindings.lisp, 28-Aug-87 17:05:12, Edit by Chiles. - Fixed some bindings for "Editor" mode and put them on the right page. - -/usr2/lisp/nhem/lispeval.lisp, 28-Aug-87 19:05:14, Edit by Chiles. - Fixed bug in CREATE-ANONYMOUS-CLIENT-LISP and "Select Lisp Listener". - Made "Set Eval Server" really define a buffer local variable when a - prefix was supplied. - -/usr1/ram/charmacs.lisp, 25-Aug-87 19:59:00, Edit by Ram - Flushed Alt and Oops character names. Added Escape as a name to shadow - the initial Altmode name. Added Enter and Action as alternate names for - Return and Linefeed. - -/usr1/ram/keytran.lisp, 25-Aug-87 19:44:24, Edit by Ram - Changed delete to translate to delete rather than oops. Made all random - named keys translate to a super character when shifted. Made keypad keys - always translate to super characters. - -/usr1/ram/bindings.lisp, 25-Aug-87 19:15:10, Edit by Ram - Frobbed bindings to allow rational documentation. Case-Insensitivize now - translates to lowercase. Use of Insert as an Escape standin had been - flushed. Insert is now used for X cut buffer operations. Bindings to Oops - have been flushed. Interactive input kill/abort is now M-i/C-M-i. Flushed - redundant extra bindings of mouse commands to super-clicks (except for S-left - being the same as middle). Made S-Left and S-Right be illegal in the echo - area. Made illegal upclicks do nothing so that you don't get annoying double - errors. Made C-_ be a :Help character. Flushed M-_ binding for Help and - Help on Parse. Made redundant bindings to backspace and return for C-h and - C-m so that TTYs can win. (Scribe mode is still wedged pending intallation - of the new Scribe insertion command.) Use Delete character name instead of - Rubout. - -/usr2/lisp/nnhem/searchcoms.lisp, 24-Aug-87 09:17:00, Edit by Chiles - Added Chris Hoover's "List Matching Lines", "Delete Matching Lines", and - "Count Occurrences". Redid page breaks. - -/usr2/lisp/nnhem/lispeval.lisp, 23-Aug-87 18:53:42, Edit by Chiles - Rewrote "Select Lisp Listener" and wrote CREATE-ANONYMOUS-CLIENT-LISP to - be used in the command and GET-CURRENT-SERVER. - -/usr2/lisp/nnhem/tty-screen.lisp, 23-Aug-87 10:15:58, Edit by Chiles - TTY-RANDOM-TYPEOUT-CLEANUP now calls REDISPLAY-WINDOW-ALL instead of - funcall'ing DEVICE-DUMB-REDISPLAY directly. - -/usr2/lisp/nnhem/font.lisp, 22-Aug-87 14:10:06, Edit by Chiles - SETF methods for changing a window's font set the hunk's trashed slot to - :font-change instead of t. - -/usr2/lisp/nnhem/window.lisp, 21-Aug-87 19:59:19, Edit by Chiles - Replaced numeric constants with symbolic ones. WINDOW-CHANGED no longer - redisplays, but it does update the window image (recentering if current - window). - -/usr2/lisp/nhem/pane.lisp, 19-Aug-87 22:34:12, Edit by Chiles - Wrote OFROB-CURSOR to be the note-read-wait method for old bitmap - displays. Rewrote PANE-SHOW-CURSOR. Titled pages. Documented cursor - stuff. - -/usr2/lisp/nhem/obit-screen.lisp, 19-Aug-87 22:28:24, Edit by Chiles - Added an initialization for the note-read-wait slot of the default old - bitmap device to #'ofrob-cursor. OBITMAP-RANDOM-TYPEOUT-CLEANUP now - calls REDISPLAY-WINDOW-ALL instead of ODUMB-WINDOW-REDISPLAY. - -/usr2/lisp/nhem/hunk-draw.lisp, 19-Aug-87 18:53:14, Edit by Chiles - Rewrote HUNK-SHOW-CURSOR. Added FROB-CURSOR. Tweaked DROP-CURSOR and - LIFT-CURSOR. - -/usr2/lisp/nhem/bit-screen.lisp, 19-Aug-87 18:49:23, Edit by Chiles - Initialized note-read-wait slot of default bitmap device to #'frob-cursor - which is new in Hunk-Draw.Lisp. Modified SET-WINDOW-HOOK-RAISE-FUN. Put - DEFHVAR in SITE-INIT. Removed all references to BITMAP-HUNK-LOCK. - Additionally modified HUNK-RESET, HUNK-EXPOSED-OR-CHANGED, and - HUNK-CHANGED. HUNK-EXPOSED-OR-CHANGED now calls REDISPLAY-WINDOW-ALL - instead of DUMB-WINDOW-REDISPLAY. - -/usr2/lisp/nhem/display.lisp, 19-Aug-87 18:46:16, Edit by Chiles - Added device structure slot note-read-wait which is a function that - somehow notes on the display that input is expected. This will simply be - dropping the cursor for now on the RT. Rewrote REDISPLAY-LOOP to take a - window variable to bind and two forms for general window redisplay and - current window redisplay. Added REDISPLAY-WINDOW, REDISPLAY-WINDOW-ALL, - MAYBE-UPDATE-WINDOW-IMAGE, and REDISPLAY-WINDOW-RECENTERING. Modified - REDISPLAY-WINDOWS-FROM-MARK to use REDISPLAY-WINDOW-RECENTERING (which is - also used by REDISPLAY). - -/usr2/lisp/nhem/bit-display.lisp, 19-Aug-87 14:44:03, Edit by Chiles - Reorganized pages some: put smart redisplay structure definitions on the - smart window redisplay page, and retitle/titled other pages. Did away - with most macros, making them functions and moving their definitions - below their uses. Modified some call sites and argument passing of what - were macros and now are functions. Removed code from - SMART-WINDOW-REDISPLAY and DUMB-WINDOW-REDISPLAY that is now encorporated - into the REDISPLAY and REDISPLAY-ALL loops. Removed references and sets - to BITMAP-HUNK-LOCK. - -/usr2/lisp/nhem/obit-display.lisp, 19-Aug-87 14:44:14, Edit by Chiles - Moved definition of *current-font* from Bit-Display.Lisp to the only file - using it, this one. Removed recenterp argument from - OSMART-WINDOW-REDISPLAY and ODUMB-WINDOW-REDISPLAY. Also removed window - image building code from these functions since it is now taken care of - higher up in the redisplay calls. - -/usr2/lisp/nhem/tty-display-rt.lisp, 19-Aug-87 12:26:13, Edit by Chiles - Modified INIT-TTY-DEVICE and EXIT-TTY-DEVICE to destructively modify - system:*file-input-handlers*. Now the standard input file descriptor - used for terminal streams is associated with an editor input handler - instead of the editor having its own file descriptor. - -/usr2/lisp/nhem/rompsite.lisp, 18-Aug-87 15:29:01, Edit by Chiles - Modified INIT-RAW-IO to not open the tty device. Now, it simply assumes - Unix standard input. Modified TTY-BEEP to not write to the editor's file - descriptor which is Unix standard input but to write to 1 (Unix standard - output). Put DEFHVAR for "Set Window Autoraise" in SITE-INIT. Modified - SHOW-MARK to call REDISPLAY-WINDOW instead of calling the smart redisplay - method out of the device. Made editor connect handler store lisp - listener buffer in server-info slot. - -/usr2/lisp/nhem/tty-display.lisp, 18-Aug-87 15:13:41, Edit by Chiles - Moved INIT-TTY-DEVICE and EXIT-TTY-DEVICE to Tty-Display-Rt.Lisp. - Deleted code from TTY-SMART-WINDOW-REDISPLAY and - TTY-SEMI-DUMB-WINDOW-REDISPLAY that was folded into the REDISPLAY and - REDISPLAY-ALL loops. Likewise for TTY-DUMB-WINDOW-REDISPLAY. Also - deleted recenterp arguments from all these functions. - -/usr2/lisp/nhem/rompsite.lisp, 18-Aug-87 14:13:43, Edit by Chiles - Made EDITOR-TTY-IN and EDITOR-WINDOW-IN drop and lift the cursor at most - once, not each time SERVER is called. - -/usr2/lisp/nhem/vars.lisp, 18-Aug-87 13:29:37, Edit by Chiles - Fixed error form for GET-MODE-OBJECT to say the argument is not a defined - mode instead of saying NIL isn't. - -/usr2/lisp/nhem/buffer.lisp, 18-Aug-87 13:28:01, Edit by Chiles - Fixed MODE-MAJOR-P to return MODE-OBJECT-MAJOR-P instead of - MODE-OBJECT-NAME. - -/usr2/lisp/nhem/morecoms.lisp, 11-Aug-87 12:03:46, Edit by Chiles - JR fixed "List Buffers" to print the pathname of the buffer unless there - was not one or the buffer names was not derived from it. Otherwise, - print the buffer name. - -/usr2/lisp/nhem/bindings.lisp, 30-Jul-87 15:26:08, Edit by Chiles - Added binding for C-M-\L to "Illegal" in "Echo Area" mode. - -/usr2/lisp/nhem/line.lisp, 29-Jul-87 15:28:41, Edit by Chiles - Rob documented the line defstruct, eliminating the chars slot in favor of - always having the %chars slot. Added a macro for LINE-%CHARS instead of - symbol-function and symbol-plist hackery. - -/usr2/lisp/nhem/struct.lisp, 29-Jul-87 15:31:55, Edit by Chiles - Fixed documentation on COMMANDP. - -/usr2/lisp/nhem/echo.lisp, 28-Jul-87 16:26:44, Edit by Chiles - Merged some code from the Perq to fix up current buffer and window when - trying to confirm a non-existent parse. - -/usr2/lisp/nhem/bit-screen.lisp, 26-Jul-87 20:13:05, Edit by Chiles - Made SET-WINDOW-HOOK-RAISE-FUN look at the value of "Set Window Autoraise". - -/usr2/lisp/nhem/rompsite.lisp, 26-Jul-87 19:59:31, Edit by Chiles - Made EDITOR-SLEEP loop around SERVER using its timeout functionality - instead of busy looping. - -/usr2/lisp/nhem/lispeval.lisp, 26-Jul-87 20:04:08, Edit by Chiles - Made loop waiting for anonymous client lisp use EDITOR-SLEEP which loops - around SERVER. Before, the client Lisp could never connect since SERVER - was never being called. - - Wrote "Select Lisp Listener" command. - -/usr2/lisp/nhem/tty-display.lisp, 26-Jul-87 18:56:41, Edit by Chiles - Fixed display bug involving lines that are both new and changed (seen - often in the echo area for some reason). - -/usr2/lisp/nhem/filecoms.lisp, 25-Jul-87 19:37:16, Edit by Chiles - Fixed "Select Previous Buffer" to not call "Circulate Buffer" since it - doesn't exist. - -/usr2/lisp/nhem/macros.lisp, 25-Jul-87 18:30:59, Edit by Chiles - Made LISP-ERROR-ERROR-HANDLER have an E command that reports the - condition it was called on in a pop-up window. - -/usr2/lisp/nhem/lispeval.lisp, 25-Jul-87 19:28:23, Edit by Chiles - Made FILE-COMPILE use a temporary output file for compiler output when - its ouput-file argument is not t. This temporary file is publicly - writeable in case the eval server is running on another machine. - -/usr2/lisp/nhem/edit-defs.lisp, 25-Jul-87 19:25:32, Edit by Chiles - Made "Go to Definition" and "Edit Definition" use the client Lisp to - determine where something is defined. Had to restructure the code - significantly, but it can be put back to non-eval-server functionality - easily and cleanly. - -/usr2/lisp/nhem/bindings.lisp, 23-Jul-87 11:07:22, Edit by Chiles - Added bindings for "Process Control", "Editor Evaluate Expression", and - "Select Lisp Listener". - -Rompsite.Lisp, while doing eval-server, Edit by Chiles - Tty streams now loop over SERVER for input, so the eval-server stuff can - be used on terminals. There are a couple new functions for connection to - editor servers. - -Lispeval.Lisp, while doing eval-server, Edit by Chiles - This is a new file replacing a lot of commands in Lispbuf.Lisp with - similar commands that use the eval server interface. New in this file - from the Perq implementation is function description. - -Ts.Lisp, while doing eval-server, Edit by Chiles - This is a new file that implements the server side of the typescript - protocol. - -Morecoms.Lisp, while doing eval-server, Edit by Chiles - Made "Do Nothing", typically bound to up mouse clicks, propagate the last - command type (as if nothing happened). This was needed to make - super-rightup keep the command type of super-rightdown ("Insert Kill Buffer"). - -Keytran.Lisp, while doing eval-server, Edit by Chiles - Made shift-mouseclicks send super-mouseclick. - -Bindings.Lisp, while doing eval-server, Edit by Chiles - Addeds lots of new bindings and changed a few with respect to the - eval-server stuff going in. - -Bit-Screen.Lisp, while doing eval-server, Edit by Chiles - Fixed initial windows hook to keep echo area border visible on the screen - by hacking in another -2 pixels. This might be because X has by default - moves windows down from the top, so the top borders will show. - -/usr1/ram/lispmode.lisp, 01-Jul-87 12:04:59, Edit by Ram - Fixed Quest-For-Balancing-Paren to use the net-open and net-close information - correctly. It's silly to go to the trouble of computing this information, - and then (incorrectly) compute a paren balance by subtracting the two. - -/usr2/lisp/nhem/streams.lisp, 19-Jun-87 18:02:55, Edit by Chiles - Merged in some fixes from old Perq version. - -/usr2/lisp/nhem/lispbuf.lisp, 19-Jun-87 17:54:25, Edit by Chiles - Changed the following command names to be prefixed by "Editor ": - "Editor Evaluate Defun" - "Editor Re-evaluate Defvar" - "Editor Evaluate Expression" - "Editor Compile Defun" - "Editor Compile Region" - "Editor Evaluate Region" - "Editor Evaluate Buffer" - "Editor Compile File" - "Editor Compile Group" - "Editor Describe Function Call" - "Editor Describe Symbol". - Removed old reference to KILL-TOP-LEVEL-INPUT-COMMAND in "Top-Level Eval". - -/usr2/lisp/nhem/killcoms.lisp, 19-Jun-87 17:39:34, Edit by Chiles - Wrote BUFFER-MARK which is to CURRENT-MARK as BUFFER-POINT is to - CURRENT-POINT. - -/usr2/lisp/nhem/filecoms.lisp, 16-Jun-87 23:25:52, Edit by Chiles - Removed the definition of the "Package" file option, placing a new - version in Lispbuf.Lisp. - -/usr2/lisp/nhem/srccom.lisp, 18-Jun-87 10:23:01, Edit by Chiles - Made "Compare Buffers" and "Merge Buffers" only handle the current region - in each buffer when the prefix argument is supplied. - -/usr2/lisp/nhem/bindings.lisp, 16-Jun-87 14:09:20, Edit by Chiles - Added bindings for super-<mouseclick> characters. Added binding for - "Exit Hemlock". Added binding for "Circulate Buffer". - -/usr2/lisp/nhem/morecoms.lisp, 15-Jun-87 22:18:26, Edit by Chiles - Made "Do Nothing" set the last command type to its current value. - Added "Insert Kill Buffer". - -/usr2/lisp/nhem/echocoms.lisp, 15-Jun-87 13:47:15, Edit by Chiles - Made "Help on Parse" check for *parse-help* being nil. - -/usr2/lisp/nhem/bit-screen.lisp, 08-Jun-87 12:20:39, Edit by Chiles - Modified DEFAULT-CREATE-INITIAL-WINDOWS-HOOK to added in a couple more - border widths, so the echo area's bottom border is visible. - -************************* - -/usr1/lisp/hemlock/rompsite.lisp, 03-Jun-87 10:09:24, Edit by DBM. - All references to the accint package have been changed to Mach. - -/usr1/lisp/hemlock/obit-screen.lisp, 03-Jun-87 10:05:34, Edit by DBM. - All references to the accint package have been changed to Mach. - -/usr2/lisp/nhem/tty-display.lisp, 01-Jun-87 21:25:15, Edit by Chiles - Modified TTY-SMART-WINDOW-REDISPLAY to punt insert/delete line - optimizations in favor of redrawing every altered line when "Scroll - Redraw Ratio" is exceeded. - -/usr2/lisp/nhem/command.lisp, 01-Jun-87 21:12:21, Edit by Chiles - "Scroll Redraw Ratio" is a new Hemlock variable that controls the - abortion of insert/delete line optimization in terminal redisplay in - favor of redrawing all altered lines. This is used in Tty-Display.Lisp. - -/usr2/lisp/nhem/tty-display.lisp, 27-May-87 14:38:50, Edit by Chiles - Wrote TTY-SMART-CLEAR-TO-EOW to use the internal screen image instead of - TTY-SEMI-DUMB-WINDOW-REDISPLAY and TTY-SMART-WINDOW-REDISPLAY using the - clear-to-eow method that clears every line disregarding internal - information. - -/usr2/lisp/nhem/rompsite.lisp, 26-May-87 16:14:27, Edit by Chiles - Modified EDITOR-TTY-IN to detect lowercase control g's. - -/usr2/lisp/nhem/bit-screen.lisp, 25-May-87 17:40:30, Edit by Chiles - Modified arguments to X window event handlers as per the changes in - X.Lisp. - -/usr1/ram/spellcoms.lisp, 22-May-87 04:02:19, Edit by Ram - Fixed Fix-Word to bump the mark in the all uppercase case even when the word - is already in the hashtable. - -/usr1/ram/echo.lisp, 14-May-87 13:07:07, Edit by Ram - Changed Message to use displayed-p on the buffer end to tell whether the echo - area needs to be cleared rather than just counting the lines. This works - much better in the presence of wrapped lines. - -/usr1/ram/cursor.lisp, 14-May-87 13:02:09, Edit by Ram - Changed renamed Display-P to %Displayed-P, and wrote Displayed-P which does - an update-window-iamge before calling %Displayed-P. - -/usr2/lisp/xhem/xcommand.lisp, 12-May-87 16:00:16, Edit by Chiles - This is a new file of X specific commands. Currently it only contains - "Insert Cut Buffer" and "Region to Cut Buffer". - -/usr2/lisp/xhem/keyboard_codes.lisp, 12-May-87 15:55:42, Edit by Chiles - Modified some translations to work better with the new key bindings. - -/usr2/lisp/xhem/lispbuf.lisp, 12-May-87 14:43:15, Edit by Chiles - Added "List Compile File" and "Re-evaluate Defvar". - -/usr2/lisp/xhem/command.lisp, 12-May-87 14:07:11, Edit by Chiles - Modified "Self Insert" and "Quoted Insert" to handler new TEXT-CHARACTER - in Rompsite.Lisp. - -/usr2/lisp/xhem/morecoms.lisp, 12-May-87 14:01:29, Edit by Chiles - Made "List Buffers" on a prefix argument list only modified buffers. - -/usr2/lisp/xhem/main.lisp, 12-May-87 12:55:51, Edit by Chiles - Stopped ED from calling REDISPLAY-ALL when the editor has been entered - already and moved this into the device init methods that require this. - -/usr2/lisp/xhem/lispmode.lisp, 12-May-87 12:53:32, Edit by Chiles - Blasted a couple bogus type declarations on some DEFSTRUCT slots. - Inserted a few lines to LISP-INDENTATION from my init file. - -/usr2/lisp/xhem/indent.lisp, 12-May-87 12:48:29, Edit by Chiles - Replaced a couple SCAN-CHAR and REV-SCAN-CHAR uses with FIND-ATTRIBUTE - and REVERSE-FIND-ATTRIBUTE, so compilation in a Lisp without Hemlock - wouldn't lose. - -/usr2/lisp/xhem/filecoms.lisp, 12-May-87 12:42:08, Edit by Chiles - Renamed "New Window" to "Split Window", and made "New Window" prompt the - user for a window. - -/usr2/lisp/xhem/charmacs.lisp, 12-May-87 12:24:05, Edit by Chiles - Modified character name a-list. Rob Flushed addition of the command-bits - feature and added the all-bit-names constant. - -/usr2/lisp/xhem/window.lisp, 12-May-87 11:47:35, Edit by Chiles - This contains the stuff we still need from Owindow.Lisp and some new - stuff brought over from the Perq. - -/usr2/lisp/xhem/tty-screen.lisp, 12-May-87 11:43:55, Edit by Chiles - Modified to fit the new device independent structure, adding beep and - finish-output methods. Creating and Deleting window methods now set - *screen-image-trashed since not all devices need this. Random typeout - methods got an extra argument that we ignore. - -/usr2/lisp/xhem/struct.lisp, 12-May-87 11:37:25, Edit by Chiles - Modified window, dis-line, and font structures. When the old bitmap - stuff goes away, so will a few slots of windows. Also, some old setf - stuff for old font information will go away. - -/usr2/lisp/xhem/screen.lisp, 12-May-87 11:34:06, Edit by Chiles - Modified to be once-again device independent with respect to the addition - of Hemlock running under X windows. MAKE-WINDOW and DELETE-WINDOW no - longer set *screen-image-trashed* since this isn't necessary for all - devices. - -/usr2/lisp/xhem/rompsite.lisp, 12-May-87 00:56:01, Edit by Chiles - SITE-INIT is all new and defines some Hemlock variables for controlling - some of the X activity. INIT-RAW-IO is much bigger now for initializing - stuff when we are running under X. *editor-windowed-input* is set to t - when we are running under X, and WINDOWED-MONITOR-P returns the value of - this variable for use is other files. - - BEEP was moved to Code:Machio.Lisp, and there's a couple different - beeping methods in here now that get called as a result of - *beep-function* being bound by SITE-WRAPPER-MACRO. HEMLOCK-WINDOW calls - *hemlock-window-mngt* when *current-window* is bound, which happens going - in and out of Hemlock. - - The X scan code translation mechanism lives here, but the initialization - is in Keytran.Lisp. Terminal translation now downcases control - characters to interact more smoothly with the new Hemlock key translation - and binding scheme. - - There are now different types of editor input streams that all a head and - tail pointer into an input queue of events. One is used for terminals - and flat bitmap screens, and the other uses SERVER for windowed input - under X. TEXT-CHARACTER is new and now more correct. - - There is a page of X support: getting a Hemlock cursor, setting up a grey - pixmap for border frobbing, cut buffer manipulation, and naming windows. - -/usr2/lisp/xhem/owindow.lisp, 12-May-87 00:52:54, Edit by Chiles - This file used to be Window.Lisp. It now contains only the old bitmap - related code for setting up a windows image. - -/usr2/lisp/xhem/ofont.lisp, 12-May-87 00:51:35, Edit by Chiles - This file used to be Font.Lisp. It now contains only the few things - necessary for old bitmap font interfacing. - -/usr2/lisp/xhem/obit-screen.lisp, 12-May-87 00:43:50, Edit by Chiles - This file used to be Screen-Bit.Lisp. Shared stuff has been moved to - the new file by the old name. Window creation and deletion methods now - set *screen-image-trashed* since this is not meaningful across all - devices. - -/usr2/lisp/xhem/obit-display.lisp, 12-May-87 00:40:35, Edit by Chiles - This file used to be Bit-Display.Lisp. Shared stuff has been moved to - the new file by the old name. - -/usr2/lisp/xhem/macros.lisp, 12-May-87 00:35:30, Edit by Chiles - WITH-RANDOM-TYPEOUT has been modified to handle new termination - functionality involved with running Hemlock under X. - LISP-ERROR-ERROR-HANDLER no longer calls REDISPLAY after returning from a - BREAK. This is the responsibility of the device's init method if it is - necessary. - -/usr2/lisp/xhem/keytran.lisp, 12-May-87 00:30:18, Edit by Chiles - This is a new file. It contains the initialization of the keyboard - translations for Hemlock running under X. These were too numerous to - leave in Rompsite since there is no hack for generating the translations. - -/usr2/lisp/xhem/hunk-draw.lisp, 12-May-87 00:28:02, Edit by Chiles - This is a new file, a kin to Pane.Lisp. It contains screen painting - routines for Hemlock running under X windows. This includes cursor and - border manipulation. - -/usr2/lisp/xhem/font.lisp, 12-May-87 00:12:10, Edit by Chiles - This is a new file, replacing the currently named Ofont.Lisp. It - contains the pseudo-independent Hemlock font information implementation. - This includes stuff particular for running Hemlock under X windows and - stuff that is used by the other bitmap redisplay/screen manager code. - -/usr2/lisp/xhem/display.lisp, 12-May-87 00:09:23, Edit by Chiles - The device structure has been modified to handle new methods, such as - beeping and finishing output. The device-clear method is now optional. - The entry points into redisplay have been modified to encorporate the - needs of Hemlock running under X windows. - -/usr2/lisp/xhem/bit-screen.lisp, 11-May-87 23:16:26, Edit by Chiles - This is a new file, replacing the currently named Obit-Screen.Lisp. It - contains the event handlers for selected events on Hemlock windows, the - screen management methods for Hemlock running under X windows, the random - typeout methods, and screen manager initialization. - -/usr2/lisp/xhem/bit-hunk-stream.lisp, 11-May-87 22:43:36, Edit by Chiles - This is a new file. It contains the bitmap-hunk-output-stream structure - definition and the associated methods. This is used for random typeout. - -/usr2/lisp/xhem/bit-display.lisp, 11-May-87 22:38:47, Edit by Chiles - This is a new file, replacing the currently named Obit-Display.Lisp. It - contains the bitmap-hunk structure and the X related redisplay methods.d - -/usr1/ram/cursor.lisp, 08-May-87 05:02:09, Edit by Ram - Totally rewrote dis-line-offset-guess, making it dramatically simpler and - more correct by making it do only what is needed for the scrolling functions, - rather than attempting to make it preserve position within the line. - -/../chiles/usr/lisp/hemlock/bindings.lisp, 29-Apr-87 23:33:27, Edit by Ram - Massively revised bindings now that we have key-translations and a real meta - key. C-Z and Escape are now handled as bit-prefix characters, so all - explicit bindings containing these have been flushed. Key translations are - used to make things case-insensitive, so duplicate bindings for different - case have been flushed. - - All the C-<punctuation>/Escape <punctuation> bindings pairs have been - replaced with M-<punctuation>. This is the main user-interface change. Also - the commands previously bound to C-Z M-<char> have been rebound to C-M-<CHAR> - (i.e. control meta shift). This is necessary since C-Z M-<char> is just - C-M-<char> due to the bit prefix mechanism. We selectively flush the - uppercasing translation for the control meta chars used in this way. - - In a more rt-specific change, uses of Help have been replaced with Home. - -/usr/ram/interp.lisp, 30-Apr-87 00:36:04, Edit by Ram - New Key-Translation mechanism replaces key links. A key translation - specifies a substitution that is done one key arguments to the bindings - functions. When the translated-from key appears as a subsequence of the key - to be translated, that subsequence is replaced with the translation. There - is also a mechanism for defining bit-prefix characters. - - The key-table code has been changed a fair amount. Key-tables are now - structures. The conditionalization off of the commands-bits feature has been - flushed. Keys are no longer internally assumed to be simple-vectors so that - we can use vectors with fill-pointers as internal buffers. - - Also put in a few doc strings and made crunch-key allow any seqence and check - that the components are characters. The type check was in the PERQ version - but got lost. - -/usr/ram/spellcoms.slisp, 12-Apr-87 10:57:44, Edit by Ram - Fixed Spell-Replace-Word not to consider words beginning with #\' to be - capitalized. - -/../wb1/usr/chiles/nhem/lispmode.slisp, 04-Apr-87 22:44:36, Edit by Chiles - Modified "Transpose Forms" such that - (form1) ;comment - (form2) - became - (form2) ;comment - (form1) - instead of - ;comment - (form2) (form1) - -/../wb1/usr/chiles/nhem/tty-display.slisp, 26-Mar-87 18:51:40, Edit by Chiles - Fixed bug in TTY-SEMI-DUMB-WINDOW-REDISPLAY and - TTY-SMART-WINDOW-REDISPLAY that came up when writing the modeline. Put - in an UNWIND-PROTECT around TTY-SMART-LINE-REDISPLAY since it can throw - out of redisplay leaving the terminal in standout mode. - -/../wb1/usr/chiles/nhem/htext1.slisp, 26-Mar-87 18:10:15, Edit by Chiles - Modified MODIFYING-BUFFER to invoke new "Buffer Modified Hook" when the - buffer went from unmodified to modified. - -/../wb1/usr/chiles/nhem/main.slisp, 26-Mar-87 17:49:12, Edit by Chiles - Added definition for "Buffer Modified Hook" and changed definition for - "Default Modeline String". - -/../wb1/usr/chiles/nhem/window.slisp, 26-Mar-87 17:37:32, Edit by Chiles - Made %INIT-REDISPLAY add QUEUE-BUFFER-CHANGES to new "Buffer Modified Hook". - Made DEFAULT-MODELINE-FUNCTION-FUNCTION return one more value, whether - the buffer is modified. - -/../wb1/usr/chiles/nhem/buffer.slisp, 26-Mar-87 18:14:08, Edit by Chiles - Made %SET-BUFFER-MODIFIED to invoke new "Buffer Modified Hook" on sense. - -/usr1/ram/group.slisp, 20-Mar-87 14:10:56, Edit by Ram - Changed the "Group Search" commands to feel more like the "Query Replace" - commands. :Yes now exits instead of skipping, skipping is moved to :No and - skipping the rest of the file is move to :Do-All. - -/usr/ram/searchcoms.slisp, 19-Mar-87 00:04:09, Edit by Ram - Changed query-replace-function to set up the search pattern itself. Also - made it error if the count is specified and negative, rather than trying to - do replacement backwards and getting it wrong. Also restore the search - pattern after a recursive edit. - -/usr/ram/group.slisp, 19-Mar-87 00:31:13, Edit by Ram - Fixed up a bunch of things. Indirect filespecs are parsed normally; it is no - longer assumed that the rest of the line is the name of the file. The - default file name is no longer capitalized. Temporary search buffers are no - longer renamed to "Group Search", making exiting from searches more - well-defined. "Group Search" restores the search pattern after a recursive - edit. - -/usr/lisp/nhem/lispmode.slisp, 12-Mar-87 16:05:30, Edit by Chiles - Rewrote TOP-LEVEL-OFFSET to be correct and to not move the mark unless it - could really do the offset. Modified INSIDE-DEFUN-P to not return t when - point is between a top level form and the beginning of the buffer. Added - START-DEFUN-P to be used in heavily modified versions of "End of Defun" - and "Mark Defun" commands. - -/../wb1/usr/chiles/nhem/lispmode.slisp, 03-Mar-87 17:33:05, Edit by Chiles - Fixed LISP-INDENTATION to do a "generic" indent instead of simply - returning 0. This fixes doc strings. - -/../wb1/usr/chiles/nhem/indent.slisp, 27-Feb-87 14:18:59, Edit by Chiles - Fixed "Indent" command to only affect argument number of lines (instead - of one too many) when the prefix argument is supplied. Rewrote - INDENT-REGION-FOR-COMMANDS to be much simpler, fixing a couple - irritatingly buggy special cases. - -/../wb1/usr/chiles/nhem/fill.slisp, 27-Feb-87 12:18:50, Edit by Chiles - Fixed "Fill Paragrah" command's undoability. When a prefix was added to - the first line, it was ignored by the undo region do to a :left-inserting - mark. - -/usr1/ram/text.slisp, 23-Feb-87 11:00:53, Edit by Ram - The "Paragraph Delimiter Function" variable is now used to determine whether - a line is a paragraph break. This is used by Scribe mode. - -/usr1/ram/spellcoms.slisp, 23-Feb-87 10:52:18, Edit by Ram - "Spell Correct Unique Spelling Immediately" (on by default) causes an unknown - word with only one correction to be corrected immediately in auto-spell mode, - rather than requiring "Correct Last Misspelled Word" to be done. - - The "Undo Last Spelling Correction" command undoes the last incremental - spelling correction and places the word in the dictionary. - - "Spell Ignore Uppercase" (off by default) causes all-uppercase unknown words - to be ignored. - -/usr1/ram/defsyn.slisp, 23-Feb-87 10:50:01, Edit by Ram - Changed definition of "Lisp Syntax" attribute for new Lisp mode primitives. - -/usr1/ram/lispbuf.slisp, 23-Feb-87 10:48:54, Edit by Ram - Changed to use new Lisp mode primitives. - -/usr1/ram/htext1.slisp, 23-Feb-87 10:19:19, Edit by Ram - Deleted old line-plist support. The user directly accesses the Plist slot - now that he is responsible for keeping treack of when it changes. - -/usr1/ram/line.slisp, 23-Feb-87 10:17:30, Edit by Ram - Merged in code to implement the documented line-plist/line-signature - semantics. This code somehow never got merged in from the PERQ version. - -/usr1/ram/scribe.slisp, 20-Feb-87 16:25:07, Edit by Ram - A real Scribe mode. Has general bracket balancing, and knows about paragraph - boundaries. Also various commands for inserting Scribe directives bound to - C-H mumble. - -/usr1/ram/bindings.slisp, 20-Feb-87 14:22:45, Edit by Ram - New bindings for "Undo Last Spelling Correction" and Scribe mode commands. - -/usr1/ram/lispmode.slisp, 18-Feb-87 11:42:22, Edit by Ram - New Lisp mode primitives, courtesy of Ivan (Crash and burn like an unblanced - paren Vazquez. These primitives know about Lisp commenting and quotation - conventions, and ignoring meaningless parens and quotes. This is done by - pre-parsing the lines in the buffer, annotating them with information about - the quoted areas on the line. Forward-Form and Backward-Form are gone, - replaced by Form-Offset. Similarly, Forward-List and Backward-List are - replaced by List-Offset. - - All users of these Lisp parsing primitives must call Pre-Command-Parse-Check - or equivalent to ensure that the buffer is properly annotated. This function - calls the values of "Parse Start Function" and "Parse End Function" to - determine the area of the buffer to parse. The default parse start and end - functions use "Minimum Lines Parsed", "Maximum Lines Parsed" and - "Defun Parse Goal" to determine how much stuff to parse. - - I also reimplemented Lisp indentation. Other than general cleanup, use of - newly avilable syntax information, and bug fixes, the major changes are: - -- Unless there is a reason otherwise, indentation for a form will be copied - from the previous form. - -- If no special args appear on the same line with the form name, then the - special args are indented four spaces. This is useful with - Unwind-Protect and Multiple-Value-Bind. - -- DEFxxx is now uniformly treated as a two-arg special form, rather than - being bizzarely special-cased. "Indent Defanything" controls this - behavior. - -- Lines in the middle of a quoted string are not indented, rather than - being indented as though they were lines of code. This eliminates - spurious whitespace in multi-line strings. - -/usr/lisp/hemlock/termcap.slisp, 17-Feb-87 12:04:32, Edit by Chiles - Made GET-TERMCAP handle TERMCAP environment variable. - -/usr/lisp/hemlock/rompsite.slisp, 17-Feb-87 11:48:16, Edit by Chiles - Modified SITE-WRAPPER-MACRO to call init/exit methods out of the device. - EDITOR-LISTEN now loops a parameter number of times which can be set when - using a slow line to make sure the editor listens for input before - wasting redisplay effort. - -/usr/lisp/hemlock/tty-display.slisp, 16-Feb-87 17:05:01, Edit by Chiles - Added "semi dumb" terminal redisplay. This is used for terminals without - add line and delete line. Made INIT-TTY-DEVICE (renamed) and - EXIT-TTY-DEVICE (renamed) call standard init/exit function from - Rompsite.Slisp. - -/usr/lisp/hemlock/macros.slisp, 14-Feb-87 01:33:08, Edit by Chiles - Made LISP-ERROR-ERROR-HANDLER call init/exit methods out of the device - when going in and out of Hemlock. - -/usr/lisp/hemlock/bit-screen.slisp, 14-Feb-87 01:08:15, Edit by Chiles - Added INIT-BITMAP-DEVICE and EXIT-BITMAP-DEVICE. Now whenever the editor - is exited or entered there is a method to be called in the device - structure. - -/usr/lisp/hemlock/main.slisp, 14-Feb-87 00:27:47, Edit by Chiles - Made ED reflect new SITE-WRAPPER-MACRO in Rompsite.Slisp. - -/usr/lisp/hemlock/tty-screen.slisp, 14-Feb-87 00:13:44, Edit by Chiles - Modified MAKE-DEVICE to reflect new "semi dumb" redisplay ability. - -/usr/lisp/hemlock/rompsite.slisp, 12-Feb-87 13:02:40, Edit by DBM. - A bug in get-editor-input was causing Hemlock to drop characters. - There used to be a (setq *events* before the (rplacd (last *events*... - -/usr/lisp/hemlock/rompsite.slisp, 10-Feb-87 15:58:23, Edit by DBM. - Modified all the unix package specifiers to be mach. - -/usr/lisp/hemlock/tty-display-rt.slisp, 10-Feb-87 15:54:04, Edit by DBM. - Modified all the unix package specifiers to be mach. - -/usr/lisp/hemlock/spell-rt.slisp, 10-Feb-87 15:52:41, Edit by DBM. - Modified all the unix package specifiers to be mach. - -/usr/lisp/hemlock/macros.slisp, 10-Feb-87 15:51:58, Edit by DBM. - Modified all the unix package specifiers to be mach. - -/usr/lisp/hemlock/files.slisp, 10-Feb-87 15:49:03, Edit by DBM. - Modified all the unix package specifiers to be mach. - -/usr/lisp/hemlock/rompsite.slisp, 14-Jan-87 14:20:03, Edit by DBM. - Wrapped a catch of redisplay-catcher around the redisplay form - in show-mark -- otherwise sometimes a bad throw would happen. - -/usr/lisp/hemlock/rompsite.slisp, 14-Jan-87 14:05:30, Edit by DBM. - Export pause-hemlock, so that the command works. - -/usr/lisp/hemlock/tty-hunk-stream.slisp, 14-Jan-87 11:58:52, Edit by Chiles - Fixed scrolling for random typeout -- forgot to local variable to line 0 - TTY-HUNK-STREAM-NEWLINE. - -/usr/lisp/hemlock/bit-screen.slisp, 13-Jan-87 16:45:31, Edit by DBM. - Modified bitmap-make-window so that it creates a bitmap-hunk - instead of device-hunk to describe the device. Also added the - arguments :device, :text-pane, and :modeline-pane to the call. - -/usr/lisp/hemlock/macros.slisp, 12-Jan-87 12:56:43, Edit by DBM. - Changed device-random-output-stream to device-random-typeout-stream. - -/usr/lisp/hemlock/tty-screen.slisp, 11-Jan-87 17:03:35, Edit by Chiles - This is a new file. It contains terminal screen management - initialization, device methods for window operations, and device methods - for random typeout. - -/usr/lisp/hemlock/tty-hunk-stream.slisp, 11-Jan-87 16:58:52, Edit by Chiles - This is a new file. It contains stream-hunk and tty-hunk-stream - structure definitions and stream operations. This is used for random - typeout. - -/usr/lisp/hemlock/tty-display.slisp, 10-Jan-87 15:35:09, Edit by Chiles - This is a new file. It contains terminal device structures, hunk - structures, and other structures needed for terminal redisplay methods. - -/usr/lisp/hemlock/tty-display-rt.slisp, 31-Dec-86 01:12:12, Edit by Chiles - This is a new file. It contains RT specific, terminal redisplay code. - -/usr/lisp/hemlock/termcap.slisp, 11-Jan-87 16:36:33, Edit by Chiles - This is a new file. It contains code for building a representation of - terminal capabilities from Unix termcap files. - -/usr/lisp/hemlock/screen.slisp, 11-Jan-87 16:30:31, Edit by Chiles - This is a new file. The previous contents are now in Bit-Screen.Slisp -- - see log entry below. This file contains new %INIT-SCREEN-MANAGER, - PREPARE-FOR-RANDOM-TYPEOUT, and RANDOM-TYPEOUT-CLEANUP functions, and it - contains new window operations that dispatch off the device structure -- - MAKE-WINDOW, NEXT-WINDOW, PREVIOUS-WINDOW, and DELETE-WINDOW. - -/usr/lisp/hemlock/rompsite.slisp, 11-Jan-87 16:06:26, Edit by Chiles - Organized file into logical partitions with page markers. Added - *editor-console-input* to be used in GET-EDITOR-INPUT, which should go - away when we are on a window system -- maybe a device method for - translating input characters or even getting them. Modified INIT-RAW-IO - to set *editor-console-input*. Modified SITE-WRAPPER-MACRO, so it does - not signal an error if it cannot find a bitmap device. Added terminal - character translation tables and TTY-TRANSLATE-CHAR. Added - SLEEP-FOR-TIME to be used in input stuff and SHOW-MARK. Rewrote - SHOW-MARK code to dispatch off of device. Added functions CONSOLEP and - GET-TERMINAL-NAME for use in Screen.Slisp. Modified BUILD-HEMLOCK to be - consistent with new files. - -/usr/lisp/hemlock/main.slisp, 11-Jan-87 16:00:36, Edit by Chiles - Modified ED to call any device init or exit function going in or out of - ED. - -/usr/lisp/hemlock/display.slisp, 11-Jan-87 14:35:16, Edit by Chiles - This is a new file. The previous contents are now in Bit-Display.Slisp -- - see log entry below. This file contains device structure definitions for - redisplay methods and device-hunk structure definitions for claiming - areas of the screens. It contains the entry points into redisplay. - -/usr/lisp/hemlock/bit-screen.slisp, 11-Jan-87 15:03:07, Edit by Chiles - Created from old Screen.Slisp. Removed functions MAKE-WINDOW, - NEXT-WINDOW, PREVIOUS-WINDOW, DELETE-WINDOW, PREPARE-FOR-RANDOM-TYPEOUT, - and RANDOM-TYPEOUT-CLEANUP putting them in the new Screen.Slisp. Added - bitmap device funs, bitmap-hunk structure definition, new initialization - function for bitmap screen management, new bitmap window operation - methods (make, delete, next, previous), and new random typeout setup and - cleanup for bitmaps. Deleted screen-hunk structure definition. - -/usr/lisp/hemlock/bit-display.slisp, 11-Jan-87 14:50:38, Edit by Chiles - Created file from old Display.Slisp. Removed functions REDISPLAY, - REDISPLAY-ALL, and REDISPLAY-WINDOWS-FROM-MARK putting them in the new - Display.Slisp. - -/usr/lisp/hemlock/window.slisp, 28-Dec-86 21:46:17, Edit by Chiles - Modified %REDISPLAY-INIT to initialize the device before calling - REDISPLAY-ALL. - -/usr/lisp/hemlock/macros.slisp, 18-Dec-86 17:14:25, Edit by Chiles - Rewrote WITH-RANDOM-TYPEOUT to grab the random typeout stream from the - device structure gotten from the current window. - -/usr/slisp/hemlock/macros.slisp, 22-Oct-86 22:11:22, Edit by Chiles - Error-error handler calls BREAK on the condition instead of the string - "Hemlock Debug". - -/usr/slisp/hemlock/rompsite.slisp, 22-Oct-86 22:01:22, Edit by Chiles - Setup for spell files. - -/usr/slisp/hemlock/spell-build.slisp, 22-Oct-86 17:48:02, Edit by Chiles -/usr/slisp/hemlock/spellcoms.slisp, 22-Oct-86 17:47:04, Edit by Chiles -/usr/slisp/hemlock/spell-augment.slisp, 22-Oct-86 17:46:21, Edit by Chiles -/usr/slisp/hemlock/spell-correct.slisp, 22-Oct-86 17:45:29, Edit by Chiles - The spelling correction stuff has been rewritten substantially. This is - the RT implementation. These files should be implementation independent, - modulo their use of Spell-Rt.Slisp. - -/usr/slisp/hemlock/spell-rt.slisp, 22-Oct-86 17:38:27, Edit by Chiles - Created this file to contain implementation dependent spelling code. - -/usr/slisp/hemlock/bindings.slisp, 22-Oct-86 17:35:48, Edit by Chiles - Used the new DO-ALPHA-CHARS macro from Charmacs.Slisp to do key linking. - Also, uncommented the spelling bindings. - -/usr/slisp/hemlock/edit-defs.slisp, 11-Oct-16 16:56:45, Edit by Chiles - Created this file to contain the stuff just removed from Lispmode.Slisp. - -/usr/slisp/hemlock/lispmode.slisp, 10-Oct-16 12:53:41, Edit by Chiles - Rewrote GET-DEFINITION-FILE to match longer, more specific directory - specification before matching shorter, less specific specifications. - Before it only matched whole directory namestrings. - - Removed all of the definition editing code form Lispmode.slisp. - -/sys/slisp/hemlock/echo.slisp#1, 08-Sep-86 01:15:37, Edit by Chiles -/sys/slisp/hemlock/macros.slisp#1, 08-Sep-86 01:15:37, Edit by Chiles - Made error handling stuff use the new error system. - -/sys/slisp/hemlock/morecoms.slisp#1, 27-Aug-86 10:51:27, Edit by Chiles - Modified "View Page Directory" and "Insert Page Directory" to be smarter - when creating a pop-up window and to be more general with respect to a - :page-delimiter character that is not also a :whitespace character. - -/sys/slisp/hemlock/filecoms.slisp#1, 26-Aug-86 16:18:09, Edit by Chiles - Modified WRITE-DA-FILE to display the buffer's name when prompting about - tacking a newline at the end of the file. - -/sys/slisp/hemlock/filecoms.slisp#1, 05-Aug-86 18:17:17, Edit by Chiles - Added *buffer-history-ptr* and modified "Select Previous Buffer" to walk - down *buffer-history* (when called repeatedly with an argument), selecting - successively previous buffers while leaving *buffer-history* unchanged. - -/sys/slisp/hemlock/Bindings.slisp#1, 26-Jul-86 10:57:47, Edit by Chiles - Added bindings: - (bind-key "Kill Previous Word" #\meta-backspace) - (bind-key "Echo Area Kill Previous Word" #\meta-backspace) - (bind-key "Complete Keyword" #\altmode :mode "Echo Area") - The last one is added in case you hit Esc, see nothing happened, and hit - it again. It doesn't hurt to bind this even if you have to hit Esc Esc - to get it to work. - -/sys/slisp/hemlock/lispmode.slisp#1, 25-Jul-86 11:49:43, Edit by Chiles - Fixed bug involving a comment starting after a function name and the - first argument being lined up with the comment instead of under the - function name; for example: - (cond (special-arg-p ; comment this cond branch - (first-thing-in-branch arg) - ...) - becomes - (cond (special-arg-p ; comment this cond branch - (first-thing-in-branch arg) - ...) - Note, this is somewhat kludged since a #|...|# comment will still - generate bogus indentation, but the whole LISP-INDENTATION algorithm - needs to be revamped anyway. - -/sys/slisp/hemlock/lispmode.slisp#1, 24-Jul-86 13:22:30, Edit by Chiles - "End of Defun" never worked since it was believed that MARK-AFTER was - enough to cause NEXT-TOP-LEVEL to move its argument mark, but actually - the use of LINE-OFFSET is required. - -/sys/slisp/hemlock/lispmode.slisp#1, 23-Jul-86 10:20:29, Edit by Chiles - Made LISP-INDENTATION check that the paren was on the start of a line - before doing the "DEF" hack with *indent-defanything*. - -/sys/slisp/hemlock/echo.slisp#1, 15-Jul-86 12:10:21, Edit by Chiles - Missed :trim argument to PROMPT-FOR-STRING while merging. - -08-Jul-86 - Merged most of Hemlock's changes on the Perq since the fall of 85. - Didn't try to pick up anything having to do with the eval server/ - two Lisps. The files things were taken from were: - abbrev.slisp - bindings.slisp - command.slisp - comments.slisp - echo.slisp - filecoms.slisp - fill.slisp - group.slisp - indent.slisp - kbdmac.slisp - killcoms.slisp - lispbuf.slisp - lispeval.slisp - lispmode.slisp - main.slisp - morecoms.slisp - overwrite.slisp - perqsite.slisp - scribe.slisp - searchcoms.slisp - text.slisp - undo.slisp - vars.slisp - window.slisp diff --git a/hemlock/hi-integrity.lisp b/hemlock/hi-integrity.lisp deleted file mode 100644 index 538a8b57786c6b204d72c2a2afc612d059c5919c..0000000000000000000000000000000000000000 --- a/hemlock/hi-integrity.lisp +++ /dev/null @@ -1,51 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Skef Wholey -;;; -;;; Hack to check a buffer's integrity. -;;; -(in-package 'hemlock-internals) - -(defun checkit (&optional (buffer (current-buffer))) - "Returns NIL if the buffer's region is OK, or a losing line if it ain't. - If a malformed mark is found in the mark list it is returned as the - second value." - (do ((line (mark-line (buffer-start-mark buffer)) (line-next line)) - (previous nil line) - (lines nil (cons line lines))) - ((null line) nil) - (unless (eq (line-%buffer line) buffer) - (format t "~%Oh, Man! It's in the wrong buffer!~%") - (return line)) - (when (member line lines) - (format t "~%Oh, Man! It's circular!~%") - (return line)) - (unless (eq previous (line-previous line)) - (format t "~%Oh, Man! A back-pointer's screwed up!~%") - (return line)) - (when (and previous (>= (line-number previous) (line-number line))) - (format t "~%Oh, Man! A line number is screwed up!~%") - (return line)) - (let ((res - (do ((m (line-marks line) (cdr m))) - ((null m) nil) - (unless (<= 0 (mark-charpos (car m)) (line-length line)) - (format t "~%Oh, Man! A mark is pointing into hyperspace!~%") - (return (car m))) - (unless (memq (mark-%kind (car m)) - '(:left-inserting :right-inserting)) - (format t "~%Oh, Man! A mark's type is bogus!.~%") - (return (car m))) - (unless (eq (mark-line (car m)) line) - (format t "~%Oh, Man! A mark's line pointer is messed up!~%") - (return (car m)))))) - (when res - (return (values line res)))))) diff --git a/hemlock/highlight.lisp b/hemlock/highlight.lisp deleted file mode 100644 index 05703ede8d30e4f6cd2d9dd353622aed34ba80ec..0000000000000000000000000000000000000000 --- a/hemlock/highlight.lisp +++ /dev/null @@ -1,217 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Highlighting paren and some other good stuff. -;;; -;;; Written by Bill Chiles and Jim Healy. -;;; - -(in-package "HEMLOCK") - - - -;;;; Open parens. - -(defhvar "Highlight Open Parens" - "When non-nil, causes open parens to be displayed in a different font when - the cursor is directly to the right of the corresponding close paren." - :value nil) - -(defhvar "Open Paren Highlighting Font" - "The string name of the font to be used for highlighting open parens. - The font is loaded when initializing Hemlock." - :value nil) - - -(defvar *open-paren-font-marks* nil - "The pair of font-marks surrounding the currently highlighted open- - paren or nil if there isn't one.") - -(defvar *open-paren-highlight-font* 2 - "The index into the font-map for the open paren highlighting font.") - - -;;; MAYBE-HIGHLIGHT-OPEN-PARENS is a redisplay hook that matches parens by -;;; highlighting the corresponding open-paren after a close-paren is -;;; typed. -;;; -(defun maybe-highlight-open-parens (window) - (declare (ignore window)) - (when (value highlight-open-parens) - (with-mark ((mark (current-point))) - (cond ((and (value highlight-active-region) (region-active-p)) - (kill-open-paren-font-marks)) - ((eq (character-attribute :lisp-syntax (previous-character mark)) - :close-paren) - (pre-command-parse-check mark) - (cond ((not (and (valid-spot mark nil) (list-offset mark -1))) - (kill-open-paren-font-marks)) - ((not *open-paren-font-marks*) - (set-open-paren-font-marks mark)) - ((mark= (region-start *open-paren-font-marks*) mark)) - (t (reset-open-paren-font-marks mark)))) - (t (kill-open-paren-font-marks)))))) -;;; -(add-hook redisplay-hook 'maybe-highlight-open-parens) - -(defun set-open-paren-font-marks (mark) - (let ((line (mark-line mark))) - (setf *open-paren-font-marks* - (region - (font-mark line (mark-charpos mark) *open-paren-highlight-font*) - (font-mark line (mark-charpos (mark-after mark)) 0))))) - -(defun reset-open-paren-font-marks (mark) - (move-font-mark (region-start *open-paren-font-marks*) mark) - (move-font-mark (region-end *open-paren-font-marks*) - (mark-after mark))) - -(defun kill-open-paren-font-marks () - (when *open-paren-font-marks* - (delete-font-mark (region-start *open-paren-font-marks*)) - (delete-font-mark (region-end *open-paren-font-marks*)) - (setf *open-paren-font-marks* nil))) - - - -;;;; Active regions. - -(defhvar "Active Region Highlighting Font" - "The string name of the font to be used for highlighting active regions. - The font is loaded when initializing Hemlock." - :value nil) - -(defvar *active-region-font-marks* nil) -(defvar *active-region-highlight-font* 3 - "The index into the font-map for the active region highlighting font.") - - -;;; HIGHLIGHT-ACTIVE-REGION is a redisplay hook for active regions. -;;; Since it is too hard to know how the region may have changed when it is -;;; active and already highlighted, if it does not check out to being exactly -;;; the same, we just delete all the font marks and make new ones. When -;;; the current window is the echo area window, just pretend everything is -;;; okay; this keeps the region highlighted while we're in there. -;;; -(defun highlight-active-region (window) - (unless (eq window *echo-area-window*) - (when (value highlight-active-region) - (let ((tty-p (typep (hi::device-hunk-device - (hi::window-hunk (current-window))) - 'hi::tty-device))) - (cond ((region-active-p) - (cond (tty-p) - ((not *active-region-font-marks*) - (set-active-region-font-marks)) - ((check-active-region-font-marks)) - (t (kill-active-region-font-marks) - (set-active-region-font-marks)))) - (tty-p) - (*active-region-font-marks* - (kill-active-region-font-marks))))))) -;;; -(add-hook redisplay-hook 'highlight-active-region) - -(defun set-active-region-font-marks () - (flet ((stash-a-mark (m &optional (font *active-region-highlight-font*)) - (push (font-mark (mark-line m) (mark-charpos m) font) - *active-region-font-marks*))) - (let* ((region (current-region nil nil)) - (start (region-start region)) - (end (region-end region))) - (with-mark ((mark start)) - (unless (mark= mark end) - (loop - (stash-a-mark mark) - (unless (line-offset mark 1 0) (return)) - (when (mark>= mark end) (return))) - (unless (start-line-p end) (stash-a-mark end 0)))))) - (setf *active-region-font-marks* (nreverse *active-region-font-marks*))) - -(defun kill-active-region-font-marks () - (dolist (m *active-region-font-marks*) - (delete-font-mark m)) - (setf *active-region-font-marks* nil)) - -;;; CHECK-ACTIVE-REGION-FONT-MARKS returns t if the current region is the same -;;; as that what is highlighted on the screen. This assumes -;;; *active-region-font-marks* is non-nil. At the very beginning, our start -;;; mark must not be at the end; it must be at the first font mark; and the -;;; font marks must be in the current buffer. We don't make font marks if the -;;; start is at the end, so if this is the case, then they just moved together. -;;; We return nil in this case to kill all the font marks and make new ones, but -;;; no new ones will be made. -;;; -;;; Sometimes we hack the font marks list and return t because we can easily -;;; adjust the highlighting to be correct. This keeps all the font marks from -;;; being killed and re-established. In the loop, if there are no more font -;;; marks, we either ended a region already highlighted on the next line down, -;;; or we have to revamp the font marks. Before returning here, we see if the -;;; region ends one more line down at the beginning of the line. If this is -;;; true, then the user is simply doing "Next Line" at the beginning of the -;;; line. -;;; -;;; Each time through the loop we look at the top font mark, move our roving -;;; mark down one line, and see if they compare. If they are not equal, the -;;; region may still be the same as that highlighted on the screen. If this -;;; is the last font mark, not at the beginning of the line, and it is at the -;;; region's end, then this last font mark is in the middle of a line somewhere -;;; changing the font from the highlighting font to the default font. Return -;;; t. -;;; -;;; If our roving mark is not at the current font mark, but it is at or after -;;; the end of the active region, then the end of the active region has moved -;;; before its previous location. -;;; -;;; Otherwise, move on to the next font mark. -;;; -;;; If our roving mark never moved onto a next line, then the buffer ends on the -;;; previous line, and the last font mark changes from the highlighting font to -;;; the default font. -;;; -(defun check-active-region-font-marks () - (let* ((region (current-region nil nil)) - (end (region-end region))) - (with-mark ((mark (region-start region))) - (let ((first-active-mark (car *active-region-font-marks*)) - (last-active-mark (last *active-region-font-marks*))) - (if (and (mark/= mark end) - (eq (current-buffer) - (line-buffer (mark-line first-active-mark))) - (mark= first-active-mark mark)) - (let ((marks (cdr *active-region-font-marks*))) - (loop - (unless marks - (let ((res (and (line-offset mark 1 0) - (mark= mark end)))) - (when (and (not res) - (line-offset mark 1 0) - (mark= mark end) - (start-line-p (car last-active-mark))) - (setf (cdr last-active-mark) - (list (font-mark (line-previous (mark-line mark)) - 0 - *active-region-highlight-font*))) - (return t)) - (return res))) - (let ((fmark (car marks))) - (if (line-offset mark 1 0) - (cond ((mark/= mark fmark) - (return (and (not (cdr marks)) - (not (start-line-p fmark)) - (mark= fmark end)))) - ((mark>= mark end) - (return nil)) - (t (setf marks (cdr marks)))) - - (return (and (not (cdr marks)) - (not (start-line-p fmark)) - (mark= fmark end)))))))))))) - diff --git a/hemlock/htext1.lisp b/hemlock/htext1.lisp deleted file mode 100644 index d082af5033eb6183faba3a7c2021035e4babfba2..0000000000000000000000000000000000000000 --- a/hemlock/htext1.lisp +++ /dev/null @@ -1,645 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock Text-Manipulation functions. -;;; Written by Skef Wholey. -;;; -;;; The code in this file implements the functions in the "Representation -;;; of Text," "Buffers," and "Predicates" chapters of the Hemlock design -;;; document. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(line-length line-buffer line-string line-character mark mark-kind - copy-mark delete-mark move-to-position region make-empty-region - start-line-p end-line-p empty-line-p blank-line-p blank-before-p - blank-after-p same-line-p mark< mark<= mark> mark>= mark= mark/= - line< line<= line> line>= first-line-p last-line-p buffer-signature - lines-related)) - - - -;;;; Representation of Text: - -;;; Line cache mechanism. -;;; -;;; The "open line" is used when inserting and deleting characters from a line. -;;; It acts as a cache that provides a more flexible (but more expensive) -;;; representation of the line for multiple insertions and deletions. When a -;;; line is open, it is represented as a vector of characters and two indices: -;;; -;;; +-----------------------------------------------------------+ -;;; | F | O | O | | B | x | x | x | x | x | x | x | x | A | R | -;;; +-----------------------------------------------------------+ -;;; ^ ^ -;;; Left Pointer Right Pointer -;;; -;;; The open line is represented by 4 special variables: -;;; Open-Line: the line object that is opened -;;; Open-Chars: the vector of cached characters -;;; Left-Open-Pos: index of first free character in the gap -;;; Right-Open-Pos: index of first used character after the gap -;;; -;;; Note: -;;; Any modificiation of the line cache must be protected by -;;; Without-Interrupts. This is done automatically by modifying-buffer; other -;;; users beware. - -(defvar line-cache-length 200 - "Length of Open-Chars.") - -(defvar open-line () - "Line open for hacking on.") - -(defvar open-chars (make-string line-cache-length) - "Vector of characters for hacking on.") - -(defvar left-open-pos 0 - "Index to first free character to left of mark in Open-Chars.") - -(defvar right-open-pos 0 - "Index to first used character to right of mark in Open-Chars.") - -(defun grow-open-chars (&optional (new-length (* line-cache-length 2))) - "Grows Open-Chars to twice its current length, or the New-Length if - specified." - (let ((new-chars (make-string new-length)) - (new-right (- new-length (- line-cache-length right-open-pos)))) - (%sp-byte-blt open-chars 0 new-chars 0 left-open-pos) - (%sp-byte-blt open-chars right-open-pos new-chars new-right new-length) - (setq right-open-pos new-right) - (setq open-chars new-chars) - (setq line-cache-length new-length))) - -(defun close-line () - "Stuffs the characters in the currently open line back into the line they - came from, and sets open-line to Nil." - (when open-line - (without-interrupts - (let* ((length (+ left-open-pos (- line-cache-length right-open-pos))) - (string (make-string length))) - (%sp-byte-blt open-chars 0 string 0 left-open-pos) - (%sp-byte-blt open-chars right-open-pos string left-open-pos length) - (setf (line-chars open-line) string) - (setf open-line nil))))) - -;;; We stick decrementing fixnums in the line-chars slot of the open line -;;; so that whenever the cache is changed the chars are no longer eq. -;;; They decrement so that they will be distinct from positive fixnums, -;;; which might mean something else. -;;; -(defvar *cache-modification-tick* -1 - "The counter for the fixnums we stick in the chars of the cached line.") - -(defun open-line (line mark) - "Closes the current Open-Line and opens the given Line at the Mark. - Don't call this, use modifying-line instead." - (cond ((eq line open-line) - (let ((charpos (mark-charpos mark))) - (cond ((< charpos left-open-pos) ; BLT 'em right! - (let ((right-start (- right-open-pos - (- left-open-pos charpos)))) - (%sp-byte-blt open-chars charpos - open-chars right-start - right-open-pos) - (setq left-open-pos charpos) - (setq right-open-pos right-start))) - ((> charpos left-open-pos) ; BLT 'em left! - (%sp-byte-blt open-chars right-open-pos - open-chars left-open-pos - charpos) - (setq right-open-pos - (+ right-open-pos (- charpos left-open-pos))) - (setq left-open-pos charpos))))) - - (t - (close-line) - (let* ((chars (line-chars line)) - (len (length chars))) - (declare (simple-string chars)) - (when (> len line-cache-length) - (setq line-cache-length (* len 2)) - (setq open-chars (make-string line-cache-length))) - (setq open-line line) - (setq left-open-pos (mark-charpos mark)) - (setq right-open-pos - (- line-cache-length (- (length chars) left-open-pos))) - (%sp-byte-blt chars 0 open-chars 0 left-open-pos) - (%sp-byte-blt chars left-open-pos open-chars right-open-pos - line-cache-length))))) - -;;;; Some macros for Text hacking: - - -(defmacro modifying-line (line mark) - "Checks to see if the Line is already opened at the Mark, and calls Open-Line - if not. Sticks a tick in the open-line's chars. This must be called within - the body of a Modifying-Buffer form." - `(progn - (unless (and (= (mark-charpos ,mark) left-open-pos) (eq ,line open-line)) - (open-line ,line ,mark)) - (setf (line-chars open-line) (decf *cache-modification-tick*)))) - -;;; Now-Tick tells us when now is and isn't. -;;; -(defvar now-tick 0 "Current tick.") - -(defmacro tick () - "Increments the ``now'' tick." - `(incf now-tick)) - - -;;; Yeah, the following is kind of obscure, but at least it doesn't -;;; call Bufferp twice. The without-interrupts is just to prevent -;;; people from being screwed by interrupting when the buffer structure -;;; is in an inconsistent state. -;;; -(defmacro modifying-buffer (buffer &body forms) - "Does groovy stuff for modifying buffers." - `(progn - (when (bufferp ,buffer) - (unless (buffer-writable ,buffer) - (error "Buffer ~S is read only." (buffer-name ,buffer))) - (when (< (buffer-modified-tick ,buffer) - (buffer-unmodified-tick ,buffer)) - (invoke-hook ed::buffer-modified-hook ,buffer t)) - (setf (buffer-modified-tick ,buffer) (tick))) - (without-interrupts ,@forms))) - -(defmacro always-change-line (mark new-line) - (let ((scan (gensym)) - (prev (gensym)) - (old-line (gensym))) - `(let ((,old-line (mark-line ,mark))) - (when (not (eq (mark-%kind ,mark) :temporary)) - (do ((,scan (line-marks ,old-line) (cdr ,scan)) - (,prev () ,scan)) - ((eq (car ,scan) ,mark) - (if ,prev - (setf (cdr ,prev) (cdr ,scan)) - (setf (line-marks ,old-line) (cdr ,scan))) - (setf (cdr ,scan) (line-marks ,new-line) - (line-marks ,new-line) ,scan)))) - (setf (mark-line ,mark) ,new-line)))) - -(defmacro change-line (mark new-line) - (let ((scan (gensym)) - (prev (gensym)) - (old-line (gensym))) - `(let ((,old-line (mark-line ,mark))) - (unless (or (eq (mark-%kind ,mark) :temporary) - (eq ,old-line ,new-line)) - (do ((,scan (line-marks ,old-line) (cdr ,scan)) - (,prev () ,scan)) - ((eq (car ,scan) ,mark) - (if ,prev - (setf (cdr ,prev) (cdr ,scan)) - (setf (line-marks ,old-line) (cdr ,scan))) - (setf (cdr ,scan) (line-marks ,new-line) - (line-marks ,new-line) ,scan)))) - (setf (mark-line ,mark) ,new-line)))) - -;;; MOVE-SOME-MARKS -- Internal -;;; -;;; Move all the marks from the line Old to New, performing some -;;; function on their charpos'es. Charpos is bound to the charpos of -;;; the mark, and the result of the evaluation of the last form in -;;; the body should be the new charpos for the mark. If New is -;;; not supplied then the marks are left on the old line. -;;; -(defmacro move-some-marks ((charpos old &optional new) &body body) - (let ((last (gensym)) (mark (gensym)) (marks (gensym))) - (if new - `(let ((,marks (line-marks ,old))) - (do ((,mark ,marks (cdr ,mark)) - (,last nil ,mark)) - ((null ,mark) - (when ,last - (shiftf (cdr ,last) (line-marks ,new) ,marks)) - (setf (line-marks ,old) nil)) - (setf (mark-line (car ,mark)) ,new) - (setf (mark-charpos (car ,mark)) - (let ((,charpos (mark-charpos (car ,mark)))) - ,@body)))) - `(dolist (,mark (line-marks ,old)) - (setf (mark-charpos ,mark) - (let ((,charpos (mark-charpos ,mark))) - ,@body)))))) - -;;; Maybe-Move-Some-Marks -- Internal -;;; -;;; Like Move-Some-Marks, but only moves the mark if the -;;; charpos is greater than the bound, OR the charpos equals the bound -;;; and the marks %kind is :left-inserting. -;;; -(defmacro maybe-move-some-marks ((charpos old &optional new) bound &body body) - (let ((mark (gensym)) (marks (gensym)) (prev (gensym))) - (if new - `(do ((,mark (line-marks ,old)) - (,marks (line-marks ,new)) - (,prev ())) - ((null ,mark) - (setf (line-marks ,new) ,marks)) - (let ((,charpos (mark-charpos (car ,mark)))) - (cond - ((or (> ,charpos ,bound) - (and (= ,charpos ,bound) - (eq (mark-%kind (car ,mark)) :left-inserting))) - (setf (mark-line (car ,mark)) ,new) - (setf (mark-charpos (car ,mark)) (progn ,@body)) - (if ,prev - (setf (cdr ,prev) (cdr ,mark)) - (setf (line-marks ,old) (cdr ,mark))) - (rotatef (cdr ,mark) ,marks ,mark)) - (t - (setq ,prev ,mark ,mark (cdr ,mark)))))) - `(dolist (,mark (line-marks ,old)) - (let ((,charpos (mark-charpos ,mark))) - (when (or (> ,charpos ,bound) - (and (= ,charpos ,bound) - (eq (mark-%kind ,mark) :left-inserting))) - (setf (mark-charpos ,mark) (progn ,@body)))))))) - - -;;; Maybe-Move-Some-Marks* -- Internal -;;; -;;; Like Maybe-Move-Some-Marks, but ignores the mark %kind. -;;; -(defmacro maybe-move-some-marks* ((charpos old &optional new) bound &body body) - (let ((mark (gensym)) (marks (gensym)) (prev (gensym))) - (if new - `(do ((,mark (line-marks ,old)) - (,marks (line-marks ,new)) - (,prev ())) - ((null ,mark) - (setf (line-marks ,new) ,marks)) - (let ((,charpos (mark-charpos (car ,mark)))) - (cond - ((> ,charpos ,bound) - (setf (mark-line (car ,mark)) ,new) - (setf (mark-charpos (car ,mark)) (progn ,@body)) - (if ,prev - (setf (cdr ,prev) (cdr ,mark)) - (setf (line-marks ,old) (cdr ,mark))) - (rotatef (cdr ,mark) ,marks ,mark)) - (t - (setq ,prev ,mark ,mark (cdr ,mark)))))) - `(dolist (,mark (line-marks ,old)) - (let ((,charpos (mark-charpos ,mark))) - (when (> ,charpos ,bound) - (setf (mark-charpos ,mark) (progn ,@body)))))))) - -;;;; Lines. - -(defun line-length (line) - "Returns the number of characters on the line." - (if (linep line) - (line-length* line) - (error "~S is not a line!" line))) - -(defun line-buffer (line) - "Returns the buffer with which the Line is associated. If the line is - not in any buffer then Nil is returned." - (let ((buffer (line-%buffer line))) - (if (bufferp buffer) buffer))) - -(defun line-string (line) - "Returns the characters in the line as a string. The resulting string - must not be destructively modified. This may be set with Setf." - (if (eq line open-line) - (close-line)) - (line-chars line)) - -(defun %set-line-string (line string) - (let ((buffer (line-%buffer line))) - (modifying-buffer buffer - (unless (simple-string-p string) - (setq string (coerce string 'simple-string))) - (when (eq line open-line) (setq open-line nil)) - (let ((length (length (the simple-string string)))) - (dolist (m (line-marks line)) - (if (eq (mark-%kind m) :left-inserting) - (setf (mark-charpos m) length) - (setf (mark-charpos m) 0)))) - (setf (line-chars line) string)))) - -(defun line-character (line index) - "Return the Index'th character in Line. If the index is the length of the - line then #\newline is returned." - (if (eq line open-line) - (if (< index left-open-pos) - (schar open-chars index) - (let ((index (+ index (- right-open-pos left-open-pos)))) - (if (= index line-cache-length) - #\newline - (schar open-chars index)))) - (let ((chars (line-chars line))) - (declare (simple-string chars)) - (if (= index (length chars)) - #\newline - (schar chars index))))) - -;;;; Marks. - -(defun mark (line charpos &optional (kind :temporary)) - "Returns a mark to the Charpos'th character of the Line. Kind is the - kind of mark to make, one of :temporary (the default), :left-inserting - or :right-inserting." - (let ((mark (internal-make-mark line charpos kind))) - (if (not (eq kind :temporary)) - (push mark (line-marks line))) - mark)) - -(defun mark-kind (mark) - "Returns the kind of the given Mark, :Temporary, :Left-Inserting, or - :Right-Inserting. This may be set with Setf." - (mark-%kind mark)) - -(defun %set-mark-kind (mark kind) - (let ((line (mark-line mark))) - (cond ((eq kind :temporary) - (setf (line-marks line) (delq mark (line-marks line))) - (setf (mark-%kind mark) kind)) - ((or (eq kind :left-inserting) (eq kind :right-inserting)) - (if (not (memq mark (line-marks line))) - (push mark (line-marks line))) - (setf (mark-%kind mark) kind)) - (t - (error "~S is an invalid mark type." kind))))) - -(defun copy-mark (mark &optional (kind (mark-%kind mark))) - "Returns a new mark pointing to the same position as Mark. The kind - of mark created may be specified by Kind, which defaults to the - kind of the copied mark." - (let ((mark (internal-make-mark (mark-line mark) (mark-charpos mark) kind))) - (if (not (eq kind :temporary)) - (push mark (line-marks (mark-line mark)))) - mark)) - -(defun delete-mark (mark) - "Deletes the Mark. This should be done to any mark that may not be - temporary which is no longer needed." - (if (not (eq (mark-%kind mark) :temporary)) - (let ((line (mark-line mark))) - (when line - (setf (line-marks line) (delq mark (line-marks line)))) - nil)) - (setf (mark-line mark) nil)) - -(defun move-to-position (mark charpos &optional (line (mark-line mark))) - "Changes the Mark to point to the given character position on the Line, - which defaults to the line the mark is currently on." - (change-line mark line) - (setf (mark-charpos mark) charpos) - mark) - -;;;; Regions. - -(defun region (start end) - "Returns a region constructed from the marks Start and End." - (let ((l1 (mark-line start)) - (l2 (mark-line end))) - (unless (eq (line-%buffer l1) (line-%buffer l2)) - (error "Can't make a region with lines of different buffers.")) - (unless (if (eq l1 l2) - (<= (mark-charpos start) (mark-charpos end)) - (< (line-number l1) (line-number l2))) - (error "Start ~S is after end ~S." start end))) - (internal-make-region start end)) - -;;; The *Disembodied-Buffer-Counter* exists to give that are not in any buffer -;;; unique buffer slots. - -(defvar *Disembodied-Buffer-Counter* 0 - "``Buffer'' given to lines in regions not in any buffer.") - -(defun make-empty-region () - "Returns a region with start and end marks pointing to the start of one empty - line. The start mark is right-inserting and the end mark is left-inserting." - (let* ((line (make-line :chars "" :number 0 - :%buffer (incf *disembodied-buffer-counter*))) - (start (mark line 0 :right-inserting)) - (end (mark line 0 :left-inserting))) - (internal-make-region start end))) - -;;; Line-Increment is the default difference for line numbers when we don't -;;; know any better. - -(defconstant line-increment 256 "Default difference for line numbers.") - -;;; Renumber-Region is used internally to keep line numbers in ascending order. -;;; The lines in the region are numbered starting with the given Start value -;;; by increments of the given Step value. It returns the region. - -(defun renumber-region (region &optional (start 0) (step line-increment)) - (do ((line (mark-line (region-start region)) (line-next line)) - (last-line (mark-line (region-end region))) - (number start (+ number step))) - ((eq line last-line) - (setf (line-number line) number) - region) - (setf (line-number line) number)) - region) - -;;; Renumber-Region-Containing renumbers the region containing the given line. - -(defun renumber-region-containing (line) - (cond ((line-buffer line) - (renumber-region (buffer-region (line-%buffer line)))) - (t - (do ((line line (line-previous line)) - (number 0 (- number line-increment))) - ((null line)) - (setf (line-number line) number)) - (do ((line (line-next line) (line-next line)) - (number line-increment (+ number line-increment))) - ((null line)) - (setf (line-number line) number))))) - - -;;; Number-Line numbers a newly created line. The line has to have a previous -;;; line. -(defun number-line (line) - (let ((prev (line-number (line-previous line))) - (next (line-next line))) - (if (null next) - (setf (line-number line) (+ prev line-increment)) - (let ((new (+ prev (truncate (- (line-number next) prev) 2)))) - (if (= new prev) - (renumber-region-containing line) - (setf (line-number line) new)))))) - - - -;;;; Buffers. - -;;; BUFFER-SIGNATURE is the exported interface to the internal function, -;;; BUFFER-MODIFIED-TICK -;;; -(defun buffer-signature (buffer) - "Returns an arbitrary number which reflects the buffers current - \"signature.\" The value returned by buffer-signature is guaranteed - to be eql to the value returned by a previous call of buffer-signature - iff the buffer has not been modified between the calls." - (unless (bufferp buffer) - (error "~S is not a buffer." buffer)) - (buffer-modified-tick buffer)) - - - -;;;; Predicates: - - -(defun start-line-p (mark) - "Returns T if the Mark points before the first character in a line, Nil - otherwise." - (= (mark-charpos mark) 0)) - -(defun end-line-p (mark) - "Returns T if the Mark points after the last character in a line, Nil - otherwise." - (= (mark-charpos mark) (line-length (mark-line mark)))) - -(defun empty-line-p (mark) - "Returns T if the line pointer to by Mark contains no characters, Nil - or otherwise." - (let ((line (mark-line mark))) - (if (eq line open-line) - (and (= left-open-pos 0) (= right-open-pos line-cache-length)) - (= (length (line-chars line)) 0)))) - -;;; blank-between-positions -- Internal -;;; -;;; Check if a line is blank between two positions. Used by blank-XXX-p. -;;; -(eval-when (compile eval) -(defmacro check-range (chars start end) - `(do ((i ,start (1+ i))) - ((= i ,end) t) - (when (zerop (character-attribute :whitespace (schar ,chars i))) - (return nil))))) -;;; -(defun blank-between-positions (line start end) - (if (eq line open-line) - (let ((gap (- right-open-pos left-open-pos))) - (cond ((>= start left-open-pos) - (check-range open-chars (+ start gap) (+ end gap))) - ((<= end left-open-pos) - (check-range open-chars start end)) - (t - (and (check-range open-chars start left-open-pos) - (check-range open-chars right-open-pos (+ end gap)))))) - (let ((chars (line-chars line))) - (check-range chars start end)))) - -(defun blank-line-p (line) - "True if line contains only characters with a :whitespace attribute of 1." - (blank-between-positions line 0 (line-length line))) - -(defun blank-before-p (mark) - "True is all of the characters before Mark on the line it is on have a - :whitespace attribute of 1." - (blank-between-positions (mark-line mark) 0 (mark-charpos mark))) - -(defun blank-after-p (mark) - "True if all characters on the part part of the line after Mark have - a :whitespace attribute of 1." - (let ((line (mark-line mark))) - (blank-between-positions line (mark-charpos mark) - (line-length line)))) - -(defun same-line-p (mark1 mark2) - "Returns T if Mark1 and Mark2 point to the same line, Nil otherwise." - (eq (mark-line mark1) (mark-line mark2))) - -(defun mark< (mark1 mark2) - "Returns T if Mark1 points to a character before Mark2, Nil otherwise." - (if (not (eq (line-%buffer (mark-line mark1)) - (line-%buffer (mark-line mark2)))) - (error "Marks in different buffers have no relation.")) - (or (< (line-number (mark-line mark1)) (line-number (mark-line mark2))) - (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2))) - (< (mark-charpos mark1) (mark-charpos mark2))))) - -(defun mark<= (mark1 mark2) - "Returns T if Mark1 points to a character at or before Mark2, Nil otherwise." - (if (not (eq (line-%buffer (mark-line mark1)) - (line-%buffer (mark-line mark2)))) - (error "Marks in different buffers have no relation.")) - (or (< (line-number (mark-line mark1)) (line-number (mark-line mark2))) - (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2))) - (<= (mark-charpos mark1) (mark-charpos mark2))))) - -(defun mark> (mark1 mark2) - "Returns T if Mark1 points to a character after Mark2, Nil otherwise." - (if (not (eq (line-%buffer (mark-line mark1)) - (line-%buffer (mark-line mark2)))) - (error "Marks in different buffers have no relation.")) - (or (> (line-number (mark-line mark1)) (line-number (mark-line mark2))) - (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2))) - (> (mark-charpos mark1) (mark-charpos mark2))))) - -(defun mark>= (mark1 mark2) - "Returns T if Mark1 points to a character at or after Mark2, Nil otherwise." - (if (not (eq (line-%buffer (mark-line mark1)) - (line-%buffer (mark-line mark2)))) - (error "Marks in different buffers have no relation.")) - (or (> (line-number (mark-line mark1)) (line-number (mark-line mark2))) - (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2))) - (>= (mark-charpos mark1) (mark-charpos mark2))))) - -(defun mark= (mark1 mark2) - "Returns T if both marks point to the same position, Nil otherwise." - (and (eq (mark-line mark1) (mark-line mark2)) - (= (mark-charpos mark1) (mark-charpos mark2)))) - -(defun mark/= (mark1 mark2) - "Returns T if both marks point to different positions, Nil otherwise." - (not (and (eq (mark-line mark1) (mark-line mark2)) - (= (mark-charpos mark1) (mark-charpos mark2))))) - -(defun line< (line1 line2) - "Returns T if Line1 comes before Line2, NIL otherwise." - (if (neq (line-%buffer line1) (line-%buffer line2)) - (error "Lines in different buffers have no relation.")) - (< (line-number line1) (line-number line2))) - -(defun line<= (line1 line2) - "Returns T if Line1 comes before or is the same as Line2, NIL otherwise." - (if (neq (line-%buffer line1) (line-%buffer line2)) - (error "Lines in different buffers have no relation.")) - (<= (line-number line1) (line-number line2))) - -(defun line>= (line1 line2) - "Returns T if Line1 comes after or is the same as Line2, NIL otherwise." - (if (neq (line-%buffer line1) (line-%buffer line2)) - (error "Lines in different buffers have no relation.")) - (>= (line-number line1) (line-number line2))) - -(defun line> (line1 line2) - "Returns T if Line1 comes after Line2, NIL otherwise." - (if (neq (line-%buffer line1) (line-%buffer line2)) - (error "Lines in different buffers have no relation.")) - (> (line-number line1) (line-number line2))) - -(defun lines-related (line1 line2) - "Returns T if an order relation exists between Line1 and Line2." - (eq (line-%buffer line1) (line-%buffer line2))) - -(defun first-line-p (mark) - "Returns T if the line pointed to by mark has no previous line, - Nil otherwise." - (null (line-previous (mark-line mark)))) - -(defun last-line-p (mark) - "Returns T if the line pointed to by mark has no next line, - Nil otherwise." - (null (line-next (mark-line mark)))) diff --git a/hemlock/htext2.lisp b/hemlock/htext2.lisp deleted file mode 100644 index edfd0a8380dda27685e57998d50a12118d85462e..0000000000000000000000000000000000000000 --- a/hemlock/htext2.lisp +++ /dev/null @@ -1,498 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; More Hemlock Text-Manipulation functions. -;;; Written by Skef Wholey. -;;; -;;; The code in this file implements the non-insert/delete functions in the -;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(region-to-string string-to-region line-to-region - previous-character next-character count-lines - count-characters line-start line-end buffer-start - buffer-end move-mark mark-before mark-after - character-offset line-offset region-bounds - set-region-bounds *print-region*)) - - - -(defun region-to-string (region) - "Returns a string containing the characters in the given Region." - (close-line) - (let* ((dst-length (count-characters region)) - (string (make-string dst-length)) - (start-mark (region-start region)) - (end-mark (region-end region)) - (start-line (mark-line start-mark)) - (end-line (mark-line end-mark)) - (start-charpos (mark-charpos start-mark))) - (declare (simple-string string)) - (if (eq start-line end-line) - (%sp-byte-blt (line-chars start-line) start-charpos string 0 - dst-length) - (let ((index ())) - (let* ((line-chars (line-chars start-line)) - (dst-end (- (length line-chars) start-charpos))) - (declare (simple-string line-chars)) - (%sp-byte-blt line-chars start-charpos string 0 dst-end) - (setf (char string dst-end) #\newline) - (setq index (1+ dst-end))) - (do* ((line (line-next start-line) (line-next line)) - (chars (line-chars line) (line-chars line))) - ((eq line end-line) - (%sp-byte-blt (line-chars line) 0 string index dst-length)) - (declare (simple-string chars)) - (%sp-byte-blt (line-chars line) 0 string index - (incf index (length chars))) - (setf (char string index) #\newline) - (setq index (1+ index))))) - string)) - -(defun string-to-region (string) - "Returns a region containing the characters in the given String." - (let* ((string (if (simple-string-p string) - string (coerce string 'simple-string))) - (end (length string))) - (declare (simple-string string)) - (do* ((index 0) - (buffer (incf *disembodied-buffer-counter*)) - (previous-line) - (line (make-line :%buffer buffer)) - (first-line line)) - (()) - (let ((right-index (%sp-find-character string index end #\newline))) - (cond (right-index - (let* ((length (- right-index index)) - (chars (make-string length))) - (%sp-byte-blt string index chars 0 length) - (setf (line-chars line) chars)) - (setq index (1+ right-index)) - (setq previous-line line) - (setq line (make-line :%buffer buffer)) - (setf (line-next previous-line) line) - (setf (line-previous line) previous-line)) - (t - (let* ((length (- end index)) - (chars (make-string length))) - (%sp-byte-blt string index chars 0 length) - (setf (line-chars line) chars)) - (return (renumber-region - (internal-make-region - (mark first-line 0 :right-inserting) - (mark line (length (line-chars line)) - :left-inserting)))))))))) - -(defun line-to-region (line) - "Returns a region containing the specified line." - (internal-make-region (mark line 0 :right-inserting) - (mark line (line-length* line) :left-inserting))) - -(defun previous-character (mark) - "Returns the character immediately before the given Mark." - (let ((line (mark-line mark)) - (charpos (mark-charpos mark))) - (if (= charpos 0) - (if (line-previous line) - #\newline - nil) - (if (eq line open-line) - (char (the simple-string open-chars) - (if (<= charpos left-open-pos) - (1- charpos) - (1- (+ right-open-pos (- charpos left-open-pos))))) - (schar (line-chars line) (1- charpos)))))) - -(defun next-character (mark) - "Returns the character immediately after the given Mark." - (let ((line (mark-line mark)) - (charpos (mark-charpos mark))) - (if (eq line open-line) - (if (= charpos (- line-cache-length (- right-open-pos left-open-pos))) - (if (line-next line) - #\newline - nil) - (schar open-chars - (if (< charpos left-open-pos) - charpos - (+ right-open-pos (- charpos left-open-pos))))) - (let ((chars (line-chars line))) - (if (= charpos (strlen chars)) - (if (line-next line) - #\newline - nil) - (schar chars charpos)))))) - -;;; %Set-Next-Character -- Internal -;;; -;;; This is the setf form for Next-Character. Since we may change a -;;; character to or from a newline, we must be prepared to split and -;;; join lines. We cannot just delete a character and insert the new one -;;; because the marks would not be right. -;;; -(defun %set-next-character (mark character) - (let* ((line (mark-line mark)) - (buffer (line-%buffer line)) - (next (line-next line))) - (modifying-buffer buffer - (modifying-line line mark) - (cond ((= right-open-pos line-cache-length) - ;; The mark is at the end of the line. - (unless next - (error "~S has no next character, so it cannot be set." mark)) - (unless (char= character #\newline) - ;; If the character is no longer a newline then mash two - ;; lines together. - (let ((chars (line-chars next))) - (declare (simple-string chars)) - (setq right-open-pos (- line-cache-length (length chars))) - (when (<= right-open-pos left-open-pos) - (grow-open-chars (* (+ (length chars) left-open-pos 1) 2))) - (%sp-byte-blt chars 0 open-chars right-open-pos - line-cache-length) - (setf (schar open-chars left-open-pos) character) - (incf left-open-pos)) - (move-some-marks (charpos next line) - (+ charpos left-open-pos)) - (setq next (line-next next)) - (setf (line-next line) next) - (when next (setf (line-previous next) line)))) - ((char= character #\newline) - ;; The char is being changed to a newline, so we must split lines. - (incf right-open-pos) - (let* ((len (- line-cache-length right-open-pos)) - (chars (make-string len)) - (new (make-line :chars chars :previous line - :next next :%buffer buffer))) - (%sp-byte-blt open-chars right-open-pos chars 0 len) - (maybe-move-some-marks* (charpos line new) left-open-pos - (- charpos left-open-pos 1)) - (setf (line-next line) new) - (when next (setf (line-previous next) new)) - (setq right-open-pos line-cache-length) - (number-line new))) - (t - (setf (char (the simple-string open-chars) right-open-pos) - character))))) - character) - -;;; %Set-Previous-Character -- Internal -;;; -;;; The setf form for Previous-Character. We just Temporarily move the -;;; mark back one and call %Set-Next-Character. -;;; -(defun %set-previous-character (mark character) - (unless (mark-before mark) - (error "~S has no previous character, so it cannot be set." mark)) - (%set-next-character mark character) - (mark-after mark) - character) - -(defun count-lines (region) - "Returns the number of lines in the region, first and last lines inclusive." - (do ((line (mark-line (region-start region)) (line-next line)) - (count 1 (1+ count)) - (last-line (mark-line (region-end region)))) - ((eq line last-line) count))) - -(defun count-characters (region) - "Returns the number of characters in the region." - (let* ((start (region-start region)) - (end (region-end region)) - (first-line (mark-line start)) - (last-line (mark-line end))) - (if (eq first-line last-line) - (- (mark-charpos end) (mark-charpos start)) - (do ((line (line-next first-line) (line-next line)) - (count (1+ (- (line-length* first-line) (mark-charpos start))))) - ((eq line last-line) - (+ count (mark-charpos end))) - (setq count (+ 1 count (line-length* line))))))) - -(defun line-start (mark &optional line) - "Changes the Mark to point to the beginning of the Line and returns it. - Line defaults to the line Mark is on." - (when line - (change-line mark line)) - (setf (mark-charpos mark) 0) - mark) - -(defun line-end (mark &optional line) - "Changes the Mark to point to the end of the line and returns it. - Line defaults to the line Mark is on." - (if line - (change-line mark line) - (setq line (mark-line mark))) - (setf (mark-charpos mark) (line-length* line)) - mark) - -(defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark)))) - "Change Mark to point to the beginning of Buffer, which defaults to - the buffer Mark is currently in." - (unless buffer (error "Mark ~S does not point into a buffer.")) - (move-mark mark (buffer-start-mark buffer))) - -(defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark)))) - "Change Mark to point to the end of Buffer, which defaults to - the buffer Mark is currently in." - (unless buffer (error "Mark ~S does not point into a buffer.")) - (move-mark mark (buffer-end-mark buffer))) - -(defun move-mark (mark new-position) - "Changes the Mark to point to the same position as New-Position." - (let ((line (mark-line new-position))) - (change-line mark line)) - (setf (mark-charpos mark) (mark-charpos new-position)) - mark) - -(defun mark-before (mark) - "Changes the Mark to point one character before where it currently points. - NIL is returned if there is no previous character." - (let ((charpos (mark-charpos mark))) - (cond ((zerop charpos) - (let ((prev (line-previous (mark-line mark)))) - (when prev - (always-change-line mark prev) - (setf (mark-charpos mark) (line-length* prev)) - mark))) - (t - (setf (mark-charpos mark) (1- charpos)) - mark)))) - -(defun mark-after (mark) - "Changes the Mark to point one character after where it currently points. - NIL is returned if there is no previous character." - (let ((line (mark-line mark)) - (charpos (mark-charpos mark))) - (cond ((= charpos (line-length* line)) - (let ((next (line-next line))) - (when next - (always-change-line mark next) - (setf (mark-charpos mark) 0) - mark))) - (t - (setf (mark-charpos mark) (1+ charpos)) - mark)))) - -(defun character-offset (mark n) - "Changes the Mark to point N characters after (or -N before if N is negative) - where it currently points. If there aren't N characters before (or after) - the mark, Nil is returned." - (let ((charpos (mark-charpos mark))) - (if (< n 0) - (let ((n (- n))) - (if (< charpos n) - (do ((line (line-previous (mark-line mark)) (line-previous line)) - (n (- n charpos 1))) - ((null line) nil) - (let ((length (line-length* line))) - (cond ((<= n length) - (always-change-line mark line) - (setf (mark-charpos mark) (- length n)) - (return mark)) - (t - (setq n (- n (1+ length))))))) - (progn (setf (mark-charpos mark) (- charpos n)) - mark))) - (let* ((line (mark-line mark)) - (length (line-length* line))) - (if (> (+ charpos n) length) - (do ((line (line-next line) (line-next line)) - (n (- n (1+ (- length charpos))))) - ((null line) nil) - (let ((length (line-length* line))) - (cond ((<= n length) - (always-change-line mark line) - (setf (mark-charpos mark) n) - (return mark)) - (t - (setq n (- n (1+ length))))))) - (progn (setf (mark-charpos mark) (+ charpos n)) - mark)))))) - -(defun line-offset (mark n &optional charpos) - "Changes to Mark to point N lines after (-N before if N is negative) where - it currently points. If there aren't N lines after (or before) the Mark, - Nil is returned." - (if (< n 0) - (do ((line (mark-line mark) (line-previous line)) - (n n (1+ n))) - ((null line) nil) - (when (= n 0) - (always-change-line mark line) - (setf (mark-charpos mark) - (if charpos - (min (line-length line) charpos) - (min (line-length line) (mark-charpos mark)))) - (return mark))) - (do ((line (mark-line mark) (line-next line)) - (n n (1- n))) - ((null line) nil) - (when (= n 0) - (change-line mark line) - (setf (mark-charpos mark) - (if charpos - (min (line-length line) charpos) - (min (line-length line) (mark-charpos mark)))) - (return mark))))) - -;;; region-bounds -- Public -;;; -(defun region-bounds (region) - "Return as multiple-value the start and end of Region." - (values (region-start region) (region-end region))) - -(defun set-region-bounds (region start end) - "Set the start and end of Region to the marks Start and End." - (let ((sl (mark-line start)) - (el (mark-line end))) - (when (or (neq (line-%buffer sl) (line-%buffer el)) - (> (line-number sl) (line-number el)) - (and (eq sl el) (> (mark-charpos start) (mark-charpos end)))) - (error "Marks ~S and ~S cannot be made into a region." start end)) - (setf (region-start region) start (region-end region) end)) - region) - - -;;;; Debugging stuff. - -(defun slf (string) - "For a good time, figure out what this function does, and why it was written." - (delete #\linefeed (the simple-string string))) - -(defun %print-whole-line (structure stream) - (cond ((eq structure open-line) - (write-string open-chars stream :end left-open-pos) - (write-string open-chars stream :start right-open-pos - :end line-cache-length)) - (t - (write-string (line-chars structure) stream)))) - -(defun %print-before-mark (mark stream) - (if (mark-line mark) - (let* ((line (mark-line mark)) - (chars (line-chars line)) - (charpos (mark-charpos mark)) - (length (line-length line))) - (declare (simple-string chars)) - (cond ((or (> charpos length) (< charpos 0)) - (write-string "{bad mark}" stream)) - ((eq line open-line) - (cond ((< charpos left-open-pos) - (write-string open-chars stream :end charpos)) - (t - (write-string open-chars stream :end left-open-pos) - (let ((p (+ charpos (- right-open-pos left-open-pos)))) - (write-string open-chars stream :start right-open-pos - :end p))))) - (t - (write-string chars stream :end charpos)))) - (write-string "{deleted mark}" stream))) - - -(defun %print-after-mark (mark stream) - (declare (ignore d)) - (if (mark-line mark) - (let* ((line (mark-line mark)) - (chars (line-chars line)) - (charpos (mark-charpos mark)) - (length (line-length line))) - (declare (simple-string chars)) - (cond ((or (> charpos length) (< charpos 0)) - (write-string "{bad mark}" stream)) - ((eq line open-line) - (cond ((< charpos left-open-pos) - (write-string open-chars stream :start charpos - :end left-open-pos) - (write-string open-chars stream :start right-open-pos - :end line-cache-length)) - (t - (let ((p (+ charpos (- right-open-pos left-open-pos)))) - (write-string open-chars stream :start p - :end line-cache-length))))) - (t - (write-string chars stream :start charpos :end length)))) - (write-string "{deleted mark}" stream))) - -(defun %print-hline (structure stream d) - (declare (ignore d)) - (write-string "#<Hemlock Line \"" stream) - (%print-whole-line structure stream) - (write-string "\">" stream)) - -(defun %print-hmark (structure stream d) - (declare (ignore d)) - (write-string "#<Hemlock Mark \"" stream) - (%print-before-mark structure stream) - (write-string "/\\" stream) - (%print-after-mark structure stream) - (write-string "\">" stream)) - -(defvar *print-region* 10 - "The number of lines to print out of a region, or NIL if none.") - -(defun %print-hregion (region stream d) - (declare (ignore d)) - (write-string "#<Hemlock Region \"" stream) - (let* ((start (region-start region)) - (end (region-end region)) - (first-line (mark-line start)) - (last-line (mark-line end))) - (cond - ((not (and (linep first-line) (linep last-line) - (eq (line-%buffer first-line) (line-%buffer last-line)) - (mark<= start end))) - (write-string "{bad region}" stream)) - (*print-region* - (cond ((eq first-line last-line) - (let ((cs (mark-charpos start)) - (ce (mark-charpos end)) - (len (line-length first-line))) - (cond - ((or (< cs 0) (> ce len)) - (write-string "{bad region}" stream)) - ((eq first-line open-line) - (let ((gap (- right-open-pos left-open-pos))) - (cond - ((<= ce left-open-pos) - (write-string open-chars stream :start cs :end ce)) - ((>= cs left-open-pos) - (write-string open-chars stream :start (+ cs gap) - :end (+ ce gap))) - (t - (write-string open-chars stream :start cs - :end left-open-pos) - (write-string open-chars stream :start right-open-pos - :end (+ gap ce)))))) - (t - (write-string (line-chars first-line) stream :start cs - :end ce))))) - (t - (%print-after-mark start stream) - (write-char #\/ stream) - (do ((line (line-next first-line) (line-next line)) - (last-line (mark-line end)) - (cnt *print-region* (1- cnt))) - ((or (eq line last-line) - (when (zerop cnt) (write-string "..." stream) t)) - (%print-before-mark end stream)) - (%print-whole-line line stream) - (write-char #\/ stream))))) - (t - (write-string "{mumble}" stream)))) - (write-string "\">" stream)) - -(defun %print-hbuffer (structure stream d) - (declare (ignore d)) - (write-string "#<Hemlock Buffer \"" stream) - (write-string (buffer-name structure) stream) - (write-string "\">" stream)) diff --git a/hemlock/htext3.lisp b/hemlock/htext3.lisp deleted file mode 100644 index 21c5fa4dfb7a425d5fa5f80791f07b30e032c081..0000000000000000000000000000000000000000 --- a/hemlock/htext3.lisp +++ /dev/null @@ -1,236 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; More Hemlock Text-Manipulation functions. -;;; Written by Skef Wholey. -;;; -;;; The code in this file implements the insert functions in the -;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(insert-character insert-string insert-region ninsert-region)) - - - -(defun insert-character (mark character) - "Inserts the Character at the specified Mark." - (unless (and character (string-char-p character)) - (error "Character must be non-nil and a string-char -- ~S" character)) - (let* ((line (mark-line mark)) - (buffer (line-%buffer line))) - (modifying-buffer buffer - (modifying-line line mark) - (cond ((char= character #\newline) - (let* ((next (line-next line)) - (new-chars (subseq (the simple-string open-chars) - 0 left-open-pos)) - (new-line (make-line :%buffer buffer - :chars (decf *cache-modification-tick*) - :previous line - :next next))) - (maybe-move-some-marks (charpos line new-line) left-open-pos - (- charpos left-open-pos)) - (setf (line-%chars line) new-chars) - (setf (line-next line) new-line) - (if next (setf (line-previous next) new-line)) - (number-line new-line) - (setq open-line new-line left-open-pos 0))) - (t - (if (= right-open-pos left-open-pos) - (grow-open-chars)) - - (maybe-move-some-marks (charpos line) left-open-pos - (1+ charpos)) - - (cond - ((eq (mark-%kind mark) :right-inserting) - (decf right-open-pos) - (setf (char (the simple-string open-chars) right-open-pos) - character)) - (t - (setf (char (the simple-string open-chars) left-open-pos) - character) - (incf left-open-pos)))))))) - - -(defun insert-string (mark string &optional (start 0) (end (length string))) - "Inserts the String at the Mark. Do not use Start and End unless you - know what you're doing!" - (let* ((line (mark-line mark)) - (buffer (line-%buffer line)) - (string (coerce string 'simple-string))) - (declare (simple-string string)) - (unless (zerop (- end start)) - (modifying-buffer buffer - (modifying-line line mark) - (if (%sp-find-character string start end #\newline) - (with-mark ((mark mark :left-inserting)) - (do ((left-index start (1+ right-index)) - (right-index - (%sp-find-character string start end #\newline) - (%sp-find-character string (1+ right-index) end #\newline))) - ((null right-index) - (if (/= left-index end) - (insert-string mark string left-index end))) - (insert-string mark string left-index right-index) - (insert-character mark #\newline))) - (let ((length (- end start))) - (if (<= right-open-pos (+ left-open-pos end)) - (grow-open-chars (* (+ line-cache-length end) 2))) - - (maybe-move-some-marks (charpos line) left-open-pos - (+ charpos length)) - (cond - ((eq (mark-%kind mark) :right-inserting) - (let ((new (- right-open-pos length))) - (%sp-byte-blt string start open-chars new right-open-pos) - (setq right-open-pos new))) - (t - (let ((new (+ left-open-pos length))) - (%sp-byte-blt string start open-chars left-open-pos new) - (setq left-open-pos new)))))))))) - - -(defconstant line-number-interval-guess 8 - "Our first guess at how we should number an inserted region's lines.") - -(defun insert-region (mark region) - "Inserts the given Region at the Mark." - (let* ((start (region-start region)) - (end (region-end region)) - (first-line (mark-line start)) - (last-line (mark-line end)) - (first-charpos (mark-charpos start)) - (last-charpos (mark-charpos end))) - (cond - ((eq first-line last-line) - ;; simple case -- just BLT the characters in with insert-string - (if (eq first-line open-line) (close-line)) - (insert-string mark (line-chars first-line) first-charpos last-charpos)) - (t - (close-line) - (let* ((line (mark-line mark)) - (next (line-next line)) - (charpos (mark-charpos mark)) - (buffer (line-%buffer line)) - (old-chars (line-chars line))) - (declare (simple-string old-chars)) - (modifying-buffer buffer - ;;hack marked line's chars - (let* ((first-chars (line-chars first-line)) - (first-length (length first-chars)) - (new-length (+ charpos (- first-length first-charpos))) - (new-chars (make-string new-length))) - (declare (simple-string first-chars new-chars)) - (%sp-byte-blt old-chars 0 new-chars 0 charpos) - (%sp-byte-blt first-chars first-charpos new-chars charpos new-length) - (setf (line-chars line) new-chars)) - - ;; Copy intervening lines. We don't link the lines in until we are - ;; done in case the mark is within the region we are inserting. - (do* ((this-line (line-next first-line) (line-next this-line)) - (number (+ (line-number line) line-number-interval-guess) - (+ number line-number-interval-guess)) - (first (%copy-line this-line :previous line - :%buffer buffer :number number)) - (previous first) - (new-line first (%copy-line this-line :previous previous - :%buffer buffer :number number))) - ((eq this-line last-line) - ;;make last line - (let* ((last-chars (line-chars new-line)) - (old-length (length old-chars)) - (new-length (+ last-charpos (- old-length charpos))) - (new-chars (make-string new-length))) - (%sp-byte-blt last-chars 0 new-chars 0 last-charpos) - (%sp-byte-blt old-chars charpos new-chars last-charpos - new-length) - (setf (line-next line) first) - (setf (line-chars new-line) new-chars) - (setf (line-next previous) new-line) - (setf (line-next new-line) next) - (when next - (setf (line-previous next) new-line) - (if (<= (line-number next) number) - (renumber-region-containing new-line))) - ;;fix up the marks - (maybe-move-some-marks (this-charpos line new-line) charpos - (+ last-charpos (- this-charpos charpos))))) - (setf (line-next previous) new-line previous new-line)))))))) - -(defun ninsert-region (mark region) - "Inserts the given Region at the Mark, possibly destroying the Region. - Region may not be a part of any buffer's region." - (let* ((start (region-start region)) - (end (region-end region)) - (first-line (mark-line start)) - (last-line (mark-line end)) - (first-charpos (mark-charpos start)) - (last-charpos (mark-charpos end))) - (cond - ((eq first-line last-line) - ;; Simple case -- just BLT the characters in with insert-string. - (if (eq first-line open-line) (close-line)) - (insert-string mark (line-chars first-line) first-charpos last-charpos)) - (t - (when (bufferp (line-%buffer first-line)) - (error "Region is linked into Buffer ~S." (line-%buffer first-line))) - (close-line) - (let* ((line (mark-line mark)) - (second-line (line-next first-line)) - (next (line-next line)) - (charpos (mark-charpos mark)) - (buffer (line-%buffer line)) - (old-chars (line-chars line))) - (declare (simple-string old-chars)) - (modifying-buffer buffer - ;; Make new chars for first and last lines. - (let* ((first-chars (line-chars first-line)) - (first-length (length first-chars)) - (new-length (+ charpos (- first-length first-charpos))) - (new-chars (make-string new-length))) - (declare (simple-string first-chars new-chars)) - (%sp-byte-blt old-chars 0 new-chars 0 charpos) - (%sp-byte-blt first-chars first-charpos new-chars charpos - new-length) - (setf (line-chars line) new-chars)) - (let* ((last-chars (line-chars last-line)) - (old-length (length old-chars)) - (new-length (+ last-charpos (- old-length charpos))) - (new-chars (make-string new-length))) - (%sp-byte-blt last-chars 0 new-chars 0 last-charpos) - (%sp-byte-blt old-chars charpos new-chars last-charpos new-length) - (setf (line-chars last-line) new-chars)) - - ;;; Link stuff together. - (setf (line-next last-line) next) - (setf (line-next line) second-line) - (setf (line-previous second-line) line) - - ;;Number the inserted stuff and mash any marks. - (do ((line second-line (line-next line)) - (number (+ (line-number line) line-number-interval-guess) - (+ number line-number-interval-guess))) - ((eq line next) - (when next - (setf (line-previous next) last-line) - (if (<= (line-number next) number) - (renumber-region-containing last-line)))) - (when (line-marks line) - (dolist (m (line-marks line)) - (setf (mark-line m) nil)) - (setf (line-marks line) nil)) - (setf (line-number line) number (line-%buffer line) buffer)) - - ;; Fix up the marks in the line inserted into. - (maybe-move-some-marks (this-charpos line last-line) charpos - (+ last-charpos (- this-charpos charpos))))))))) diff --git a/hemlock/htext4.lisp b/hemlock/htext4.lisp deleted file mode 100644 index 78627cf911df39a36f38006cea7496e5c1591839..0000000000000000000000000000000000000000 --- a/hemlock/htext4.lisp +++ /dev/null @@ -1,416 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; More Hemlock Text-Manipulation functions. -;;; Written by Skef Wholey and Rob MacLachlan. -;;; Modified by Bill Chiles. -;;; -;;; The code in this file implements the delete and copy functions in the -;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(delete-characters delete-region delete-and-save-region copy-region - filter-region)) - - - -;;;; DELETE-CHARACTERS. - -(defvar *internal-temp-region* (make-empty-region)) -(defvar *internal-temp-mark* (internal-make-mark nil nil :temporary)) - -(defun delete-characters (mark &optional (n 1)) - "Deletes N characters after the mark (or -N before if N is negative)." - (let* ((line (mark-line mark)) - (charpos (mark-charpos mark)) - (length (line-length* line))) - (cond - ((zerop n) t) - ;; Deleting chars on one line, just bump the pointers. - ((<= 0 (+ charpos n) length) - (modifying-buffer (line-%buffer line) - (modifying-line line mark) - (cond - ((minusp n) - (setq left-open-pos (+ left-open-pos n)) - (move-some-marks (pos line) - (if (> pos left-open-pos) - (if (<= pos charpos) left-open-pos (+ pos n)) - pos))) - - (t - (setq right-open-pos (+ right-open-pos n)) - (let ((bound (+ charpos n))) - (move-some-marks (pos line) - (if (> pos charpos) - (if (<= pos bound) left-open-pos (- pos n)) - pos))))) t)) - - ;; Deleting some newlines, punt out to delete-region. - (t - (setf (mark-line *internal-temp-mark*) line - (mark-charpos *internal-temp-mark*) charpos) - (let ((other-mark (character-offset *internal-temp-mark* n))) - (cond - (other-mark - (if (< n 0) - (setf (region-start *internal-temp-region*) other-mark - (region-end *internal-temp-region*) mark) - (setf (region-start *internal-temp-region*) mark - (region-end *internal-temp-region*) other-mark)) - (delete-region *internal-temp-region*) t) - (t nil))))))) - - - -;;;; DELETE-REGION. - -(defun delete-region (region) - "Deletes the Region." - (let* ((start (region-start region)) - (end (region-end region)) - (first-line (mark-line start)) - (last-line (mark-line end)) - (first-charpos (mark-charpos start)) - (last-charpos (mark-charpos end)) - (buffer (line-%buffer first-line))) - (unless (and (eq first-line last-line) - (= first-charpos last-charpos)) - (modifying-buffer buffer - (cond ((eq first-line last-line) - ;; Simple case -- just skip over the characters: - (modifying-line first-line start) - (let ((num (- last-charpos first-charpos))) - (setq right-open-pos (+ right-open-pos num)) - ;; and fix up any marks in there: - (move-some-marks (charpos first-line) - (if (> charpos first-charpos) - (if (<= charpos last-charpos) - first-charpos - (- charpos num)) - charpos)))) - (t - ;; hairy case -- squish lines together: - (close-line) - (let* ((first-chars (line-chars first-line)) - (last-chars (line-chars last-line)) - (last-length (length last-chars))) - (declare (simple-string last-chars first-chars)) - ;; Cons new chars for the first line. - (let* ((length (+ first-charpos (- last-length last-charpos))) - (new-chars (make-string length))) - (%sp-byte-blt first-chars 0 new-chars 0 first-charpos) - (%sp-byte-blt last-chars last-charpos new-chars first-charpos - length) - (setf (line-chars first-line) new-chars)) - ;; fix up the first line's marks: - (move-some-marks (charpos first-line) - (if (> charpos first-charpos) - first-charpos - charpos)) - ;; fix up the marks of the lines in the middle and mash - ;;line-%buffer: - (do* ((line (line-next first-line) (line-next line)) - (count (incf *disembodied-buffer-counter*))) - ((eq line last-line) - (setf (line-%buffer last-line) count)) - (setf (line-%buffer line) count) - (move-some-marks (ignore line first-line) - (declare (ignore ignore)) - first-charpos)) - ;; and fix up the last line's marks: - (move-some-marks (charpos last-line first-line) - (if (<= charpos last-charpos) - first-charpos - (+ (- charpos last-charpos) - first-charpos))) - ;; And splice the losers out: - (let ((next (line-next last-line))) - (setf (line-next first-line) next) - (when next (setf (line-previous next) first-line)))))))))) - - - -;;;; DELETE-AND-SAVE-REGION. - -(defun delete-and-save-region (region) - "Deletes Region and returns a region containing the deleted characters." - (let* ((start (region-start region)) - (end (region-end region)) - (first-line (mark-line start)) - (last-line (mark-line end)) - (first-charpos (mark-charpos start)) - (last-charpos (mark-charpos end)) - (buffer (line-%buffer first-line))) - (cond - ((and (eq first-line last-line) - (= first-charpos last-charpos)) - (make-empty-region)) - (t - (modifying-buffer buffer - (cond ((eq first-line last-line) - ;; simple case -- just skip over the characters: - (modifying-line first-line start) - (let* ((num (- last-charpos first-charpos)) - (new-right (+ right-open-pos num)) - (new-chars (make-string num)) - (new-line (make-line - :chars new-chars :number 0 - :%buffer (incf *disembodied-buffer-counter*)))) - (declare (simple-string new-chars)) - (%sp-byte-blt open-chars right-open-pos new-chars 0 num) - (setq right-open-pos new-right) - ;; and fix up any marks in there: - (move-some-marks (charpos first-line) - (if (> charpos first-charpos) - (if (<= charpos last-charpos) - first-charpos - (- charpos num)) - charpos)) - ;; And return the region with the nuked characters: - (internal-make-region (mark new-line 0 :right-inserting) - (mark new-line num :left-inserting)))) - (t - ;; hairy case -- squish lines together: - (close-line) - (let* ((first-chars (line-chars first-line)) - (last-chars (line-chars last-line)) - (first-length (length first-chars)) - (last-length (length last-chars)) - (saved-first-length (- first-length first-charpos)) - (saved-first-chars (make-string saved-first-length)) - (saved-last-chars (make-string last-charpos)) - (count (incf *disembodied-buffer-counter*)) - (saved-line (make-line :chars saved-first-chars - :%buffer count))) - (declare (simple-string first-chars last-chars - saved-first-chars saved-last-chars)) - ;; Cons new chars for victim line. - (let* ((length (+ first-charpos (- last-length last-charpos))) - (new-chars (make-string length))) - (%sp-byte-blt first-chars 0 new-chars 0 first-charpos) - (%sp-byte-blt last-chars last-charpos new-chars first-charpos - length) - (setf (line-chars first-line) new-chars)) - ;; Make a region with all the lost stuff: - (%sp-byte-blt first-chars first-charpos saved-first-chars 0 - saved-first-length) - (%sp-byte-blt last-chars 0 saved-last-chars 0 last-charpos) - ;; Mash the chars and buff of the last line. - (setf (line-chars last-line) saved-last-chars - (line-%buffer last-line) count) - ;; fix up the marks of the lines in the middle and mash - ;;line-%buffer: - (do ((line (line-next first-line) (line-next line))) - ((eq line last-line) - (setf (line-%buffer last-line) count)) - (setf (line-%buffer line) count) - (move-some-marks (ignore line first-line) - (declare (ignore ignore)) - first-charpos)) - ;; And splice the losers out: - (let ((next (line-next first-line)) - (after (line-next last-line))) - (setf (line-next saved-line) next - (line-previous next) saved-line - (line-next first-line) after) - (when after - (setf (line-previous after) first-line - (line-next last-line) nil))) - - ;; fix up the first line's marks: - (move-some-marks (charpos first-line) - (if (> charpos first-charpos) - first-charpos - charpos)) - ;; and fix up the last line's marks: - (move-some-marks (charpos last-line first-line) - (if (<= charpos last-charpos) - first-charpos - (+ (- charpos last-charpos) - first-charpos))) - ;; And return the region with the nuked characters: - (renumber-region - (internal-make-region - (mark saved-line 0 :right-inserting) - (mark last-line last-charpos :left-inserting))))))))))) - - - -;;;; COPY-REGION. - -(defun copy-region (region) - "Returns a region containing a copy of the text within Region." - (let* ((start (region-start region)) - (end (region-end region)) - (first-line (mark-line start)) - (last-line (mark-line end)) - (first-charpos (mark-charpos start)) - (last-charpos (mark-charpos end)) - (count (incf *disembodied-buffer-counter*))) - (cond - ((eq first-line last-line) - (when (eq first-line open-line) (close-line)) - (let* ((length (- last-charpos first-charpos)) - (chars (make-string length)) - (line (make-line :chars chars :%buffer count :number 0))) - (%sp-byte-blt (line-chars first-line) first-charpos chars 0 length) - (internal-make-region (mark line 0 :right-inserting) - (mark line length :left-inserting)))) - (t - (close-line) - (let* ((first-chars (line-chars first-line)) - (length (- (length first-chars) first-charpos)) - (chars (make-string length)) - (first-copied-line (make-line :chars chars :%buffer count - :number 0))) - (declare (simple-string first-chars)) - (%sp-byte-blt first-chars first-charpos chars 0 length) - (do ((line (line-next first-line) (line-next line)) - (previous first-copied-line) - (number line-increment (+ number line-increment))) - ((eq line last-line) - (let* ((chars (make-string last-charpos)) - (last-copied-line (make-line :chars chars - :number number - :%buffer count - :previous previous))) - (%sp-byte-blt (line-chars last-line) 0 chars 0 last-charpos) - (setf (line-next previous) last-copied-line) - (internal-make-region - (mark first-copied-line 0 :right-inserting) - (mark last-copied-line last-charpos :left-inserting)))) - (let* ((new-line (%copy-line line :%buffer count - :number number - :previous previous))) - (setf (line-next previous) new-line) - (setq previous new-line)))))))) - - - -;;;; FILTER-REGION. - -(eval-when (compile eval) -(defmacro fcs (fun str) - `(let ((rs (funcall ,fun ,str))) - (if (simple-string-p rs) rs - (coerce rs 'simple-string)))) -); eval-when (compile eval) - -;;; FILTER-REGION -- Public -;;; -;;; After we deal with the nasty boundry conditions of the first and -;;; last lines, we just scan through lines in the region replacing their -;;; chars with the result of applying the function to the chars. -;;; -(defun filter-region (function region) - "This function filters the text in a region though a Lisp function. The - argument function must map from a string to a string. It is passed each - line string from region in order, and each resulting string replaces the - original. The function must neither destructively modify its argument nor - modify the result string after it is returned. The argument will always be - a simple-string. It is an error for any string returned to contain - newlines." - (let* ((start (region-start region)) - (start-line (mark-line start)) - (first (mark-charpos start)) - (end (region-end region)) - (end-line (mark-line end)) - (last (mark-charpos end)) - (marks ())) - (modifying-buffer (line-%buffer start-line) - (modifying-line end-line end) - (cond ((eq start-line end-line) - (let* ((res (fcs function (subseq open-chars first last))) - (rlen (length res)) - (new-left (+ first rlen)) - (delta (- new-left left-open-pos))) - (declare (simple-string res)) - (when (> new-left right-open-pos) - (grow-open-chars (+ new-left line-cache-length))) - (%sp-byte-blt res 0 open-chars first left-open-pos) - ;; - ;; Move marks to start or end of region, depending on kind. - (dolist (m (line-marks start-line)) - (let ((charpos (mark-charpos m))) - (when (>= charpos first) - (setf (mark-charpos m) - (if (<= charpos last) - (if (eq (mark-%kind m) :left-inserting) - new-left first) - (+ charpos delta)))))) - (setq left-open-pos new-left))) - (t - ;; - ;; Do the chars for the first line. - (let* ((first-chars (line-chars start-line)) - (first-len (length first-chars)) - (res (fcs function (subseq first-chars first first-len))) - (rlen (length res)) - (nlen (+ first rlen)) - (new (make-string nlen))) - (declare (simple-string res first-chars new)) - (%sp-byte-blt first-chars 0 new 0 first) - (%sp-byte-blt res 0 new first nlen) - (setf (line-%chars start-line) new)) - ;; - ;; Fix up marks on the first line, saving any within the region - ;; to be dealt with later. - (let ((outside ())) - (dolist (m (line-marks start-line)) - (if (<= (mark-charpos m) first) - (push m outside) (push m marks))) - (setf (line-marks start-line) outside)) - ;; - ;; Do chars of intermediate lines in the region, saving their - ;; marks. - (do ((line (line-next start-line) (line-next line))) - ((eq line end-line)) - (when (line-marks line) - (setq marks (nconc (line-marks line) marks)) - (setf (line-marks line) nil)) - (setf (line-%chars line) (fcs function (line-chars line)))) - ;; - ;; Do the last line, which is cached. - (let* ((res (fcs function (subseq (the simple-string open-chars) - 0 last))) - (rlen (length res)) - (delta (- rlen last))) - (declare (simple-string res)) - (when (> rlen right-open-pos) - (grow-open-chars (+ rlen line-cache-length))) - (%sp-byte-blt res 0 open-chars 0 rlen) - (setq left-open-pos rlen) - ;; - ;; Adjust marks after the end of the region and save ones in it. - (let ((outside ())) - (dolist (m (line-marks end-line)) - (let ((charpos (mark-charpos m))) - (cond ((> charpos last) - (setf (mark-charpos m) (+ charpos delta)) - (push m outside)) - (t - (push m marks))))) - (setf (line-marks end-line) outside)) - ;; - ;; Scan over saved marks, moving them to the correct end of the - ;; region. - (dolist (m marks) - (cond ((eq (mark-%kind m) :left-inserting) - (setf (mark-charpos m) rlen) - (setf (mark-line m) end-line) - (push m (line-marks end-line))) - (t - (setf (mark-charpos m) first) - (setf (mark-line m) start-line) - (push m (line-marks start-line))))))))) - region)) diff --git a/hemlock/hunk-draw.lisp b/hemlock/hunk-draw.lisp deleted file mode 100644 index 39462830d1ab52c3720fc5eee28c1e51be9498d6..0000000000000000000000000000000000000000 --- a/hemlock/hunk-draw.lisp +++ /dev/null @@ -1,464 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles and Rob MacLachlan. -;;; -;;; Hemlock screen painting routines for the IBM RT running X. -;;; -(in-package 'hemlock-internals) - - -(defparameter hunk-height-limit 80 "Maximum possible height for any hunk.") -(defparameter hunk-width-limit 200 "Maximum possible width for any hunk.") -(defparameter hunk-top-border 2 "Clear area at beginning.") -(defparameter hunk-left-border 1 "Clear area before first character.") -(defparameter hunk-bottom-border 3 "Minimum Clear area at end.") -(defparameter hunk-thumb-bar-bottom-border 10 - "Minimum Clear area at end including room for thumb bar." ) -(defparameter hunk-modeline-top 2 "Extra black pixels above modeline chars.") -(defparameter hunk-modeline-bottom 2 "Extra black pixels below modeline chars.") - - - -;;;; Character translations for CLX - -;;; HEMLOCK-TRANSLATE-DEFAULT. -;;; -;;; CLX glyph drawing routines allow for a character translation function. The -;;; default one takes a string (any kind) or a vector of numbers and slams them -;;; into the outgoing request buffer. When the argument is a string, it stops -;;; processing if it sees a character that is not GRAPHIC-CHAR-P. For each -;;; graphical character, the function ultimately calls CHAR-CODE. -;;; -;;; Hemlock only passes simple-strings in, and these can only contain graphical -;;; characters because of the line image builder, except for one case -- -;;; *line-wrap-char* which anyone can set. Those who want to do evil things -;;; with this should know what they are doing: if they want a funny glyph as -;;; a line wrap char, then they should use CODE-CHAR on the font index. This -;;; allows the following function to translate everything with CHAR-CODE, and -;;; everybody's happy. -;;; -;;; Actually, Hemlock can passes the line string when doing random-typeout which -;;; does contain ^L's, tabs, etc. Under X10 these came out as funny glyphs, -;;; and under X11 the output is aborted without this function. -;;; -(defun hemlock-translate-default (src src-start src-end font dst dst-start) - (declare (simple-string src) - (fixnum src-start src-end dst-start) - (vector dst) - (ignore font)) - (do ((i src-start (1+ i)) - (j dst-start (1+ j))) - ((>= i src-end) i) - (declare (fixnum i j)) - (setf (aref dst j) (char-code (schar src i))))) - -(defvar *glyph-translate-function* #'xlib:translate-default) - - - -;;;; Drawing a line. - -(eval-when (compile eval) - -;;; HUNK-PUT-STRING takes a character (x,y) pair and computes at which pixel -;;; coordinate to draw string with font from start to end. This macros assumes -;;; hunk and font-family to be bound by the caller. -;;; -(defmacro hunk-put-string (x y font string start end) - (let ((gcontext (gensym))) - `(let ((,gcontext (bitmap-hunk-gcontext hunk))) - (xlib:with-gcontext (,gcontext :font ,font) - (xlib:draw-image-glyphs - (bitmap-hunk-xwindow hunk) ,gcontext - (+ hunk-left-border (* ,x (font-family-width font-family))) - (+ hunk-top-border (* ,y (font-family-height font-family)) - (font-family-baseline font-family)) - ,string :start ,start :end ,end - :translate *glyph-translate-function*))))) - -); eval-when (compile eval) - - -;;; Hunk-Write-String -- Internal -;;; -;;; A historical vestige used by bitmap hunk streams. Use default font (0), -;;; and bind font-family for HUNK-PUT-STRING. -;;; -(defun hunk-write-string (hunk x y string start end) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font (svref (font-family-map font-family) 0))) - (hunk-put-string x y font string start end))) - - -;;; Hunk-Write-Line -- Internal -;;; -;;; Paint a dis-line on a hunk, taking font-changes into consideration. -;;; The area of the hunk drawn on is assumed to be cleared. If supplied, -;;; the line is written at Position, and the position in the dis-line -;;; is ignored. -;;; -(defun hunk-write-line (hunk dl &optional - (position (dis-line-position dl))) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (map (font-family-map font-family)) - (chars (dis-line-chars dl)) - (length (dis-line-length dl))) - (let ((last 0) - (last-font (svref map 0))) - (do ((change (dis-line-font-changes dl) (font-change-next change))) - ((null change) - (hunk-put-string last position last-font chars last length)) - (let ((x (font-change-x change))) - (hunk-put-string last position last-font chars last x) - (setq last x last-font (svref map (font-change-font change)))))))) - - -;;; We hack this since the X11 server's aren't clever about DRAW-IMAGE-GLYPHS; -;;; that is, they literally clear the line, and then blast the new glyphs. -;;; We don't hack replacing the line when reverse video is turned on because -;;; this doesn't seem to work too well. Also, hacking replace line on the -;;; color Megapel display is SLOW! -;;; -(defvar *hack-hunk-replace-line* t) - -;;; Hunk-Replace-Line -- Internal -;;; -;;; Similar to Hunk-Write-Line, but the line need not be clear. -;;; -(defun hunk-replace-line (hunk dl &optional - (position (dis-line-position dl))) - (if *hack-hunk-replace-line* - (hunk-replace-line-on-a-pixmap hunk dl position) - (old-hunk-replace-line hunk dl position))) - -(defun old-hunk-replace-line (hunk dl &optional - (position (dis-line-position dl))) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (map (font-family-map font-family)) - (chars (dis-line-chars dl)) - (length (dis-line-length dl)) - (height (font-family-height font-family))) - (let ((last 0) - (last-font (svref map 0))) - (do ((change (dis-line-font-changes dl) (font-change-next change))) - ((null change) - (hunk-put-string last position last-font chars last length) - (let ((dx (+ hunk-left-border - (* (font-family-width font-family) length)))) - (xlib:clear-area (bitmap-hunk-xwindow hunk) - :x dx - :y (+ hunk-top-border (* position height)) - :width (- (bitmap-hunk-width hunk) dx) - :height height))) - (let ((x (font-change-x change))) - (hunk-put-string last position last-font chars last x) - (setq last x last-font (svref map (font-change-font change)))))))) - -(defvar *hunk-replace-line-pixmap* nil) - -(defun hunk-replace-line-pixmap () - (if *hunk-replace-line-pixmap* - *hunk-replace-line-pixmap* - (let* ((hunk (window-hunk *current-window*)) - (gcontext (bitmap-hunk-gcontext hunk)) - (screen (xlib:display-default-screen - (bitmap-device-display (device-hunk-device hunk)))) - (height (font-family-height *default-font-family*)) - (pixmap (xlib:create-pixmap - :width (* hunk-width-limit - (font-family-width *default-font-family*)) - :height height :depth (xlib:screen-root-depth screen) - :drawable (xlib:screen-root screen)))) - (xlib:with-gcontext (gcontext :function boole-1 - :foreground *default-background-pixel*) - (xlib:draw-rectangle pixmap gcontext 0 0 hunk-left-border height t)) - (setf *hunk-replace-line-pixmap* pixmap)))) - - -(eval-when (compile eval) - -;;; HUNK-REPLACE-LINE-STRING takes a character (x,y) pair and computes at which -;;; pixel coordinate to draw string with font from start to end. This macros -;;; assumes hunk and font-family to be bound by the caller. We draw the text -;;; on a pixmap and later blast it out to avoid line flicker since server on -;;; the RT is not very clever; it clears the entire line before drawing text. -;;; -(defmacro hunk-replace-line-string (x y font string start end) - (declare (ignore y)) - `(xlib:with-gcontext (gcontext :font ,font) - (xlib:draw-image-glyphs - (hunk-replace-line-pixmap) gcontext - (+ hunk-left-border (* ,x (font-family-width font-family))) - (font-family-baseline font-family) - ,string :start ,start :end ,end - :translate *glyph-translate-function*))) -) ;eval-when - -(defun hunk-replace-line-on-a-pixmap (hunk dl position) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (map (font-family-map font-family)) - (chars (dis-line-chars dl)) - (length (dis-line-length dl)) - (height (font-family-height font-family)) - (last 0) - (last-font (svref map 0)) - (gcontext (bitmap-hunk-gcontext hunk))) - (do ((change (dis-line-font-changes dl) (font-change-next change))) - ((null change) - (hunk-replace-line-string last position last-font chars last length) - (let* ((dx (+ hunk-left-border - (* (font-family-width font-family) length))) - (dy (+ hunk-top-border (* position height))) - (xwin (bitmap-hunk-xwindow hunk))) - (xlib:with-gcontext (gcontext :exposures nil) - (xlib:copy-area (hunk-replace-line-pixmap) gcontext - 0 0 dx height xwin 0 dy)) - (xlib:clear-area xwin :x dx :y dy - :width (- (bitmap-hunk-width hunk) dx) - :height height))) - (let ((x (font-change-x change))) - (hunk-replace-line-string last position last-font chars last x) - (setq last x last-font (svref map (font-change-font change))))))) - - -;;; HUNK-REPLACE-MODELINE sets the entire mode line to the the foreground -;;; color, so the initial bits where no characters go also is highlighted. -;;; Then the text is drawn background on foreground (hightlighted). This -;;; function assumes that BITMAP-HUNK-MODELINE-POS will not return nil; -;;; that is, there is a modeline. This function should assume the gcontext's -;;; font is the default font of the hunk. We must LET bind the foreground and -;;; background values before entering XLIB:WITH-GCONTEXT due to a non-obvious -;;; or incorrect implementation. -;;; -(defun hunk-replace-modeline (hunk) - (let* ((dl (bitmap-hunk-modeline-dis-line hunk)) - (font-family (bitmap-hunk-font-family hunk)) - (default-font (svref (font-family-map font-family) 0)) - (modeline-pos (bitmap-hunk-modeline-pos hunk)) - (xwindow (bitmap-hunk-xwindow hunk)) - (gcontext (bitmap-hunk-gcontext hunk))) - (xlib:draw-rectangle xwindow gcontext 0 modeline-pos - (bitmap-hunk-width hunk) - (+ hunk-modeline-top hunk-modeline-bottom - (font-family-height font-family)) - t) - (xlib:with-gcontext (gcontext :foreground - (xlib:gcontext-background gcontext) - :background - (xlib:gcontext-foreground gcontext) - :font default-font) - (xlib:draw-image-glyphs xwindow gcontext hunk-left-border - (+ modeline-pos hunk-modeline-top - (font-family-baseline font-family)) - (dis-line-chars dl) - :end (dis-line-length dl) - :translate *glyph-translate-function*)))) -#| -(defun hunk-replace-modeline (hunk) - (let* ((dl (bitmap-hunk-modeline-dis-line hunk)) - (font-family (bitmap-hunk-font-family hunk)) - (default-font (svref (font-family-map font-family) 0)) - (modeline-pos (bitmap-hunk-modeline-pos hunk)) - (xwindow (bitmap-hunk-xwindow hunk)) - (gcontext (bitmap-hunk-gcontext hunk))) - (xlib:draw-rectangle xwindow gcontext 0 modeline-pos - (bitmap-hunk-width hunk) - (+ hunk-modeline-top hunk-modeline-bottom - (font-family-height font-family)) - t) - (let ((foreground (xlib:gcontext-background gcontext)) - (background (xlib:gcontext-foreground gcontext))) - (xlib:with-gcontext (gcontext :foreground foreground - :background background - :font default-font) - (xlib:draw-image-glyphs xwindow gcontext hunk-left-border - (+ modeline-pos hunk-modeline-top - (font-family-baseline font-family)) - (dis-line-chars dl) - :end (dis-line-length dl) - :translate *glyph-translate-function*))))) -|# - - -;;;; Cursor/Border color manipulation. - -;;; *hemlock-listener* is set to t by default because we can't know from X -;;; whether we come up with the pointer in our window. There is no initial -;;; :enter-window event. Defaulting this to nil causes the cursor to be hollow -;;; when the window comes up under the mouse, and you have to know how to fix -;;; it. Defaulting it to t causes the cursor to always come up full, as if -;;; Hemlock is the X listener, but this recovers naturally as you move into the -;;; window. This also coincides with Hemlock's border coming up highlighted, -;;; even when Hemlock is not the listener. -;;; -(defvar *hemlock-listener* t - "Highlight border when the cursor is dropped and Hemlock can receive input.") -(defvar *current-highlighted-border* nil - "When non-nil, the bitmap-hunk with the highlighted border.") - -(defvar *hunk-cursor-x* 0 "The current cursor X position in pixels.") -(defvar *hunk-cursor-y* 0 "The current cursor Y position in pixels.") -(defvar *cursor-hunk* nil "Hunk the cursor is displayed on.") -(defvar *cursor-dropped* nil) ; True if the cursor is currently displayed. - -;;; HUNK-SHOW-CURSOR locates the cursor at character position (x,y) in hunk. -;;; If the cursor is currently displayed somewhere, then lift it, and display -;;; it at its new location. -;;; -(defun hunk-show-cursor (hunk x y) - (unless (and (= x *hunk-cursor-x*) - (= y *hunk-cursor-y*) - (eq hunk *cursor-hunk*)) - (let ((cursor-down *cursor-dropped*)) - (when cursor-down (lift-cursor)) - (setf *hunk-cursor-x* x) - (setf *hunk-cursor-y* y) - (setf *cursor-hunk* hunk) - (when cursor-down (drop-cursor))))) - -;;; FROB-CURSOR is the note-read-wait method for bitmap redisplay. We -;;; show a cursor and highlight the listening window's border when waiting -;;; for input. -;;; -(defun frob-cursor (on) - (if on (drop-cursor) (lift-cursor))) - -(proclaim '(special *default-border-pixmap* *highlight-border-pixmap*)) - -;;; DROP-CURSOR and LIFT-CURSOR are separate functions from FROB-CURSOR -;;; because they are called a couple places (e.g., HUNK-EXPOSED-REGION -;;; and SMART-WINDOW-REDISPLAY). When the cursor is being dropped, since -;;; this means Hemlock is listening in the *cursor-hunk*, make sure the -;;; border of the window is highlighted as well. -;;; -(defun drop-cursor () - (unless *cursor-dropped* - (unless *hemlock-listener* (cursor-invert-center)) - (cursor-invert) - (when *hemlock-listener* - (cond (*current-highlighted-border* - (unless (eq *current-highlighted-border* *cursor-hunk*) - (setf (xlib:window-border - (bitmap-hunk-xwindow *current-highlighted-border*)) - *default-border-pixmap*) - (setf (xlib:window-border (bitmap-hunk-xwindow *cursor-hunk*)) - *highlight-border-pixmap*) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *cursor-hunk*))))) - (t (setf (xlib:window-border (bitmap-hunk-xwindow *cursor-hunk*)) - *highlight-border-pixmap*) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *cursor-hunk*))))) - (setf *current-highlighted-border* *cursor-hunk*)) - (setq *cursor-dropped* t))) - -;;; -(defun lift-cursor () - (when *cursor-dropped* - (unless *hemlock-listener* (cursor-invert-center)) - (cursor-invert) - (setq *cursor-dropped* nil))) - - -(defun cursor-invert-center () - (let ((family (bitmap-hunk-font-family *cursor-hunk*)) - (gcontext (bitmap-hunk-gcontext *cursor-hunk*))) - (xlib:with-gcontext (gcontext :function boole-xor - :foreground *foreground-background-xor*) - (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*) - gcontext - (+ hunk-left-border - (* *hunk-cursor-x* (font-family-width family)) - (font-family-cursor-x-offset family) - 1) - (+ hunk-top-border - (* *hunk-cursor-y* (font-family-height family)) - (font-family-cursor-y-offset family) - 1) - (- (font-family-cursor-width family) 2) - (- (font-family-cursor-height family) 2) - t))) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *cursor-hunk*)))) - -(defun cursor-invert () - (let ((family (bitmap-hunk-font-family *cursor-hunk*)) - (gcontext (bitmap-hunk-gcontext *cursor-hunk*))) - (xlib:with-gcontext (gcontext :function boole-xor - :foreground *foreground-background-xor*) - (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*) - gcontext - (+ hunk-left-border - (* *hunk-cursor-x* (font-family-width family)) - (font-family-cursor-x-offset family)) - (+ hunk-top-border - (* *hunk-cursor-y* (font-family-height family)) - (font-family-cursor-y-offset family)) - (font-family-cursor-width family) - (font-family-cursor-height family) - t))) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *cursor-hunk*)))) - - - -;;;; Clearing and Copying Lines. - -(defun hunk-clear-lines (hunk start count) - (let ((height (font-family-height (bitmap-hunk-font-family hunk)))) - (xlib:clear-area (bitmap-hunk-xwindow hunk) - :x 0 :y (+ hunk-top-border (* start height)) - :width (bitmap-hunk-width hunk) - :height (* count height)))) - -(defun hunk-copy-lines (hunk src dst count) - (let ((height (font-family-height (bitmap-hunk-font-family hunk))) - (xwindow (bitmap-hunk-xwindow hunk))) - (xlib:copy-area xwindow (bitmap-hunk-gcontext hunk) - 0 (+ hunk-top-border (* src height)) - (bitmap-hunk-width hunk) (* height count) - xwindow 0 (+ hunk-top-border (* dst height))))) - - - -;;;; Drawing bottom border meter. - -;;; HUNK-DRAW-BOTTOM-BORDER assumes eight-character-space tabs. The LOGAND -;;; calls in the loop are testing for no remainder when dividing by 8, 4, -;;; and other. This lets us quickly draw longer notches at tab stops and -;;; half way in between. This function assumes that -;;; BITMAP-HUNK-MODELINE-POS will not return nil; that is, that there is a -;;; modeline. -;;; -(defun hunk-draw-bottom-border (hunk) - (when (bitmap-hunk-thumb-bar-p hunk) - (let* ((xwindow (bitmap-hunk-xwindow hunk)) - (gcontext (bitmap-hunk-gcontext hunk)) - (modeline-pos (bitmap-hunk-modeline-pos hunk)) - (font-family (bitmap-hunk-font-family hunk)) - (font-width (font-family-width font-family))) - (xlib:clear-area xwindow :x 0 :y (- modeline-pos - hunk-thumb-bar-bottom-border) - :width (bitmap-hunk-width hunk) - :height hunk-bottom-border) - (let ((x (+ hunk-left-border (ash font-width -1))) - (y7 (- modeline-pos 7)) - (y5 (- modeline-pos 5)) - (y3 (- modeline-pos 3))) - (dotimes (i (bitmap-hunk-char-width hunk)) - (cond ((zerop (logand i 7)) - (xlib:draw-rectangle xwindow gcontext - x y7 (if (= i 80) 2 1) 7 t)) - ((zerop (logand i 3)) - (xlib:draw-rectangle xwindow gcontext x y5 1 5 t)) - (t - (xlib:draw-rectangle xwindow gcontext x y3 1 3 t))) - (incf x font-width)))))) diff --git a/hemlock/icom.lisp b/hemlock/icom.lisp deleted file mode 100644 index e74acd50ffa8c72f0aacdf977af76f1c4be0ddbf..0000000000000000000000000000000000000000 --- a/hemlock/icom.lisp +++ /dev/null @@ -1,65 +0,0 @@ -;;; -*- Package: hemlock; Log: hemlock.log -*- -;;; -;;; This is an italicized comment. - -(in-package "HEMLOCK") - -(defun delete-line-italic-marks (line) - (dolist (m (hi::line-marks line)) - (when (and (hi::fast-font-mark-p m) - (eql (hi::font-mark-font m) 1)) - (delete-font-mark m)))) - -(defun set-comment-font (region font) - (do ((line (mark-line (region-start region)) - (line-next line)) - (end (line-next (mark-line (region-end region))))) - ((eq line end)) - (delete-line-italic-marks line) - (let ((pos (position #\; (the simple-string (line-string line))))) - (when pos - (font-mark line pos font :left-inserting))))) - -(defun delete-italic-marks-region (region) - (do ((line (mark-line (region-start region)) - (line-next line)) - (end (line-next (mark-line (region-end region))))) - ((eq line end)) - (delete-line-italic-marks line))) - - -(defmode "Italic" - :setup-function - #'(lambda (buffer) (set-comment-font (buffer-region buffer) 1)) - :cleanup-function - #'(lambda (buffer) (delete-italic-marks-region (buffer-region buffer)))) - -(define-file-option "Italicize Comments" (buffer value) - (declare (ignore value)) - (setf (buffer-minor-mode buffer "Italic") t)) - -(defcommand "Italic Comment Mode" (p) - "Toggle \"Italic\" mode in the current buffer. When in \"Italic\" mode, - semicolon comments are displayed in an italic font." - "Toggle \"Italic\" mode in the current buffer." - (declare (ignore p)) - (setf (buffer-minor-mode (current-buffer) "Italic") - (not (buffer-minor-mode (current-buffer) "Italic")))) - - -(defcommand "Start Italic Comment" (p) - "Italicize the text in this comment." - "Italicize the text in this comment." - (declare (ignore p)) - (let* ((point (current-point)) - (pos (mark-charpos point)) - (line (mark-line point))) - (delete-line-italic-marks line) - (insert-character point #\;) - (font-mark - line - (or (position #\; (the simple-string (line-string line))) pos) - 1 - :left-inserting))) - -(bind-key "Start Italic Comment" #\; :mode "Italic") diff --git a/hemlock/indent.lisp b/hemlock/indent.lisp deleted file mode 100644 index a01e9dbc61aed72a5ba51fd7d22ec36abeba2721..0000000000000000000000000000000000000000 --- a/hemlock/indent.lisp +++ /dev/null @@ -1,283 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock indentation commands -;;; -;;; Written by Bill Maddox and Bill Chiles -;;; -(in-package "HEMLOCK") - - - -(defhvar "Spaces per Tab" - "The number of spaces a tab is equivalent to. NOTE: This is not incorporated - everywhere in Hemlock yet, so do not change it." - :value 8) - -(defun indent-using-tabs (mark column) - "Inserts at mark a maximum number of tabs and a minimum number of spaces to - move mark to column. This assumes mark is at the beginning of a line." - (multiple-value-bind (tabs spaces) (floor column (value spaces-per-tab)) - (dotimes (i tabs) (insert-character mark #\tab)) - (dotimes (i spaces) (insert-character mark #\space)))) - -(defhvar "Indent with Tabs" - "Function that takes a mark and a number of spaces and inserts tabs and spaces - to indent that number of spaces using \"Spaces per Tab\"." - :value #'indent-using-tabs) - - -(defun tab-to-tab-stop (mark) - (insert-character mark #\tab)) - -(defhvar "Indent Function" - "Indentation function which is invoked by \"Indent\" command. - It takes a :left-inserting mark that may be moved." - :value #'tab-to-tab-stop) - - -(defun generic-indent (mark) - (let* ((line (mark-line mark)) - (prev (do ((line (line-previous line) (line-previous line))) - ((or (null line) (not (blank-line-p line))) line)))) - (unless prev (editor-error)) - (line-start mark prev) - (find-attribute mark :space #'zerop) - (let ((indentation (mark-column mark))) - (line-start mark line) - (delete-horizontal-space mark) - (funcall (value indent-with-tabs) mark indentation)))) - - -(defcommand "Indent New Line" (p) - "Moves point to a new blank line and indents it. - Any whitespace before point is deleted. The value of \"Indent Function\" - is used for indentation unless there is a Fill Prefix, in which case it is - used. Any argument is passed onto \"New Line\"." - "Moves point to a new blank line and indents it. - Any whitespace before point is deleted. The value of \"Indent Function\" - is used for indentation unless there is a Fill Prefix, in which case it is - used. Any argument is passed onto \"New Line\"." - (let ((point (current-point)) - (prefix (value fill-prefix))) - (delete-horizontal-space point) - (new-line-command p) - (if prefix - (insert-string point prefix) - (funcall (value indent-function) point)))) - - -(defcommand "Indent" (p) - "Invokes function held by the Hemlock variable \"Indent Function\", - moving point past region if called with argument." - "Invokes function held by the Hemlock variable \"Indent Function\" - moving point past region if called with argument." - (let ((point (current-point))) - (with-mark ((mark point :left-inserting)) - (cond ((or (not p) (zerop p)) - (funcall (value indent-function) mark)) - (t - (if (plusp p) - (unless (line-offset point (1- p)) - (buffer-end point)) - (unless (line-offset mark (1+ p)) - (buffer-start mark))) - (indent-region-for-commands (region mark point)) - (find-attribute (line-start point) :whitespace #'zerop)))))) - -(defcommand "Indent Region" (p) - "Invokes function held by Hemlock variable \"Indent Function\" on every - line between point and mark, inclusively." - "Invokes function held by Hemlock variable \"Indent Function\" on every - line between point and mark, inclusively." - (declare (ignore p)) - (let* ((region (current-region))) - (with-mark ((start (region-start region) :left-inserting) - (end (region-end region) :left-inserting)) - (indent-region-for-commands (region start end))))) - -(defun indent-region-for-commands (region) - "Indents region undoably with INDENT-REGION." - (let* ((start (region-start region)) - (end (region-end region)) - (undo-region (copy-region (region (line-start start) (line-end end))))) - (indent-region region) - (make-region-undo :twiddle "Indent" - (region (line-start (copy-mark start :left-inserting)) - (line-end (copy-mark end :right-inserting))) - undo-region))) - -(defun indent-region (region) - "Invokes function held by Hemlock variable \"Indent Function\" on every - line of region." - (let ((indent-function (value indent-function))) - (with-mark ((start (region-start region) :left-inserting) - (end (region-end region))) - (line-start start) - (line-start end) - (loop (when (mark= start end) - (funcall indent-function start) - (return)) - (funcall indent-function start) - (line-offset start 1 0))))) - -(defcommand "Center Line" (p) - "Centers current line using \"Fill Column\". If an argument is supplied, - it is used instead of the \"Fill Column\"." - "Centers current line using fill-column." - (let* ((indent-function (value indent-with-tabs)) - (region (if (region-active-p) - (current-region) - (region (current-point) (current-point)))) - (end (region-end region))) - (with-mark ((temp (region-start region) :left-inserting)) - (loop - (when (mark> temp end) (return)) - (delete-horizontal-space (line-end temp)) - (delete-horizontal-space (line-start temp)) - (let* ((len (line-length (mark-line temp))) - (spaces (- (or p (value fill-column)) len))) - (if (and (plusp spaces) - (not (zerop len))) - (funcall indent-function temp (ceiling spaces 2))) - (line-start (line-offset temp 1))))))) - - -(defcommand "Quote Tab" (p) - "Insert tab character." - "Insert tab character." - (if (and p (> p 1)) - (insert-string (current-point) (make-string p :initial-element #\tab)) - (insert-character (current-point) #\tab))) - - -(defcommand "Open Line" (p) - "Inserts a newline into the buffer without moving the point." - "Inserts a newline into the buffer without moving the point. - With argument, inserts p newlines." - (let ((point (current-point)) - (count (if p p 1))) - (if (not (minusp count)) - (dotimes (i count) - (insert-character point #\newline) - (mark-before point)) - (editor-error)))) - - -(defcommand "New Line" (p) - "Moves the point to a new blank line. - A newline is inserted if the next two lines are not already blank. - With an argument, repeats p times." - "Moves the point to a new blank line." - (let ((point (current-point)) - (count (if p p 1))) - (if (not (minusp count)) - (do* ((next (line-next (mark-line point)) - (line-next (mark-line point))) - (i 1 (1+ i))) - ((> i count)) - (cond ((and (blank-after-p point) - next (blank-line-p next) - (let ((after (line-next next))) - (or (not after) (blank-line-p after)))) - (line-start point next) - (let ((len (line-length next))) - (unless (zerop len) - (delete-characters point len)))) - (t - (insert-character point #\newline)))) - (editor-error)))) - - -(defattribute "Space" - "This attribute is used by the indentation commands to determine which - characters are treated as space." - '(mod 2) 0) - -(setf (character-attribute :space #\space) 1) -(setf (character-attribute :space #\tab) 1) - -(defun delete-horizontal-space (mark) - "Deletes all :space characters on either side of mark." - (with-mark ((start mark)) - (reverse-find-attribute start :space #'zerop) - (find-attribute mark :space #'zerop) - (delete-region (region start mark)))) - - - -(defcommand "Delete Indentation" (p) - "Join current line with the previous one, deleting excess whitespace. - All whitespace is replaced with a single space, unless it is at the beginning - of a line, immmediately following a \"(\", or immediately preceding a \")\", - in which case the whitespace is merely deleted. If the preceeding character - is a sentence terminator, two spaces are left instead of one. If a prefix - argument is given, the following line is joined with the current line." - "Join current line with the previous one, deleting excess whitespace." - (with-mark ((m (current-point) :right-inserting)) - (when p (line-offset m 1)) - (line-start m) - (unless (delete-characters m -1) (editor-error "No previous line.")) - (delete-horizontal-space m) - (let ((prev (previous-character m))) - (when (and prev (char/= prev #\newline)) - (cond ((not (zerop (character-attribute :sentence-terminator prev))) - (insert-string m " ")) - ((not (or (eq (character-attribute :lisp-syntax prev) :open-paren) - (eq (character-attribute :lisp-syntax (next-character m)) - :close-paren))) - (insert-character m #\space))))))) - - -(defcommand "Delete Horizontal Space" (p) - "Delete spaces and tabs surrounding the point." - "Delete spaces and tabs surrounding the point." - (declare (ignore p)) - (delete-horizontal-space (current-point))) - -(defcommand "Just One Space" (p) - "Leave one space. - Surrounding space is deleted, and then one space is inserted. - with prefix argument insert that number of spaces." - "Delete surrounding space and insert P spaces." - (let ((point (current-point))) - (delete-horizontal-space point) - (dotimes (i (or p 1)) (insert-character point #\space)))) - -(defcommand "Back to Indentation" (p) - "Move point to the first non-whitespace character on the line." - "Move point to the first non-whitespace character on the line." - (declare (ignore p)) - (let ((point (current-point))) - (line-start point) - (find-attribute point :whitespace #'zerop))) - -(defcommand "Indent Rigidly" (p) - "Indent the region rigidly by p spaces. - Each line in the region is moved p spaces to the right (left if p is - negative). When moving a line to the left, tabs are converted to spaces." - "Indent the region rigidly p spaces to the right (left if p is negative)." - (let ((p (or p (value spaces-per-tab))) - (region (current-region))) - (with-mark ((mark1 (region-start region) :left-inserting) - (mark2 (region-end region) :left-inserting)) - (line-start mark1) - (line-start mark2) - (do () - ((mark= mark1 mark2)) - (cond ((empty-line-p mark1)) - ((blank-after-p mark1) - (delete-characters mark1 (line-length (mark-line mark1)))) - (t (find-attribute mark1 :whitespace #'zerop) - (let ((new-column (+ p (mark-column mark1)))) - (delete-characters mark1 (- (mark-charpos mark1))) - (if (plusp new-column) - (funcall (value indent-with-tabs) mark1 new-column))))) - (line-offset mark1 1 0))))) diff --git a/hemlock/interp.lisp b/hemlock/interp.lisp deleted file mode 100644 index 194b4018a4471419938083c542fd12e0a98493bb..0000000000000000000000000000000000000000 --- a/hemlock/interp.lisp +++ /dev/null @@ -1,549 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; -;;; This file contains the routines which define hemlock commands and -;;; the command interpreter. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(bind-key delete-key-binding get-command map-bindings - make-command command-name command-bindings last-command-type - prefix-argument exit-hemlock *invoke-hook* key-translation)) - - -(defun %print-hcommand (obj stream depth) - (declare (ignore depth)) - (write-string "#<Hemlock Command \"" stream) - (write-string (command-name obj) stream) - (write-string "\">" stream)) - - - -;;;; Key Tables: -;;; -;;; A key table provides a way to translate a sequence of characters to some -;;; lisp object. It is currently represented by a tree of vectors, with -;;; alternating levels being indexed by the bits and code. We wrap a Key-Table -;;; structure around the table so that we can discriminate bewteen a key table -;;; and a value. -;;; - -(defstruct (key-table - (:print-function - (lambda (x stream y) - (declare (ignore x y)) - (write-string "#<Key-Table>" stream)))) - (table (make-array command-char-bits-limit :initial-element nil) - :type simple-vector)) - - -;;; GET-TABLE-ENTRY -- Internal -;;; -;;; Return the value found by walking down a tree of command tables as -;;; specified by a key. If no such entry return NIL. -;;; -(defun get-table-entry (table key) - (let ((current table)) - (dotimes (i (length key) current) - (unless (key-table-p current) (return nil)) - (let* ((char (aref key i)) - (bits-vec (key-table-table current)) - (code-vec (svref bits-vec (key-char-bits char)))) - (unless code-vec (return nil)) - (setq current (svref code-vec (key-char-code char))))))) - - -;;; SET-TABLE-ENTRY -- Internal -;;; -;;; Set the entry for Key in Table to Val, creating new key tables as -;;; needed. -;;; -(defun set-table-entry (table key val) - (do ((keylast (1- (length key))) - (index 0 (1+ index)) - (current table)) - (()) - (let* ((char (aref key index)) - (bits (key-char-bits char)) - (code (key-char-code char)) - (bits-vec (key-table-table current)) - (code-vec (or (svref bits-vec bits) - (setf (svref bits-vec bits) - (make-array command-char-code-limit - :initial-element nil)))) - (next (svref code-vec code))) - (cond ((= index keylast) - (setf (svref code-vec code) val) - (return val)) - ((key-table-p next) - (setq current next)) - (t - (setq current (make-key-table)) - (setf (svref code-vec code) current)))))) - - -;;;; Key Translation: -;;; -;;; Key translations are maintained using a key table. If a value is an -;;; integer, then it is prefix bits to be OR'ed with the next character. If it -;;; is a key, then we translate to that key. - -(defvar *key-translations* (make-key-table)) -(defvar *translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t)) - - -;;; TRANSLATE-KEY -- Internal -;;; -;;; This is used internally to do key translations when we want the -;;; canonical representation for Key. Result, if supplied, is an adjustable -;;; vector with a fill pointer. We compute the output in this vector. If the -;;; key ends in the prefix of a translation, we just return that part -;;; untranslated and return the second value true. -;;; -(defun translate-key (key &optional (result (make-array 4 :fill-pointer 0 - :adjustable t))) - (let ((key-len (length key)) - (temp *translate-key-temp*) - (start 0) - (try-pos 0) - (prefix 0)) - (setf (fill-pointer temp) 0) - (setf (fill-pointer result) 0) - (loop - (when (= try-pos key-len) (return)) - (let ((ch (aref key try-pos))) - (vector-push-extend (make-char ch (logior (char-bits ch) prefix)) - temp) - (setq prefix 0)) - (let ((entry (get-table-entry *key-translations* temp))) - (unless (key-table-p entry) - (etypecase entry - (null - (vector-push-extend (aref temp 0) result) - (incf start)) - (simple-vector - (dotimes (i (length entry)) - (vector-push-extend (aref entry i) result)) - (setq start (1+ try-pos))) - (integer - (setq start (1+ try-pos)) - (when (= start key-len) (return)) - (setq prefix (logior entry prefix)))) - (setq try-pos start) - (setf (fill-pointer temp) 0)))) - - (dotimes (i (length temp)) - (vector-push-extend (aref temp i) result)) - (values result (not (zerop (length temp)))))) - - -;;; KEY-TRANSLATION -- Public -;;; -;;; Set the value, dealing with translating to and from symbolic bit names. -;;; -(defun key-translation (key) - "Return the key translation for Key, or NIL if there is none. If Key is a - prefix of a translation, then :Prefix is returned. Whenever Key appears as a - subsequence of a key argument to the binding manipulation functions, that - portion will be replaced with the translation. A key translation may also be - a list (:Bits {Bit-Name}*). In this case, the named bits will be set in the - next character in the key being translated." - (let ((entry (get-table-entry *key-translations* (crunch-key key)))) - (etypecase entry - (key-table :prefix) - ((or simple-vector null) entry) - (integer - (let ((ch (make-char #\? entry)) - (res ())) - (dolist (bit all-bit-names) - (when (char-bit ch bit) - (push bit res))) - (cons :bits res)))))) - -(defsetf key-translation %set-key-translation - "Set the key translation for a key. If set to null, deletes any - translation.") - -;;; %SET-KEY-TRANSLATION -- Internal -;;; -;;; Setf inverse for Key-Translation. -;;; -(defun %set-key-translation (key new-value) - (let ((entry (cond ((and (consp new-value) (eq (first new-value) :bits)) - (let ((res #\?)) - (dolist (bit (rest new-value) (char-bits res)) - (setf (char-bit res bit) t)))) - ((null new-value) new-value) - (t - (crunch-key new-value))))) - (set-table-entry *key-translations* (crunch-key key) entry) - new-value)) - - -;;;; Interface Utility Functions: - -(defvar *global-command-table* (make-key-table) - "The command table for global key bindings.") - -;;; GET-RIGHT-TABLE -- Internal -;;; -;;; Return a key-table depending on "kind" and checking for errors. -;;; -(defun get-right-table (kind where) - (case kind - (:global - (when where - (error "Where argument ~S is meaningless for :global bindings." - where)) - *global-command-table*) - (:mode (let ((mode (getstring where *mode-names*))) - (unless mode - (error "~S is not a defined mode." where)) - (mode-object-bindings mode))) - (:buffer (unless (bufferp where) - (error "~S is not a buffer." where)) - (buffer-bindings where)) - (t (error "~S is not a valid binding type." kind)))) - - -;;; CRUNCH-KEY -- Internal -;;; -;;; Take a key in one of the various specifications and turn it -;;; into the standard one: a simple-vector of characters. -;;; -(defun crunch-key (key) - (typecase key - (character (vector key)) - ((or list vector) - (when (zerop (length key)) - (error "Zero length key is illegal.")) - (unless (every #'characterp key) - (error "Key ~S has a non-character element." key)) - (coerce key 'simple-vector)) - (t - (error "Key ~S is not a character or sequence." key)))) - - -;;;; Exported Primitives: - -(proclaim '(special *command-names*)) - -;;; BIND-KEY -- Public -;;; -;;; Put the command specified in the correct key table. -;;; -(defun bind-key (name key &optional (kind :global) where) - "Bind a Hemlock command to some key somewhere. Name is the string name - of a Hemlock command, Key is either a character or a vector of characters. - Kind is one of :Global, :Mode or :Buffer, Where is the mode name or buffer - concerned. Kind defaults to :Global." - (let ((cmd (getstring name *command-names*)) - (table (get-right-table kind where)) - (key (copy-seq (translate-key (crunch-key key))))) - (cond (cmd - (set-table-entry table key cmd) - (push (list key kind where) (command-%bindings cmd)) - cmd) - (t - (with-simple-restart (continue "Go on, ignoring binding attempt.") - (error "~S is not a defined command." name)))))) - - -;;; DELETE-KEY-BINDING -- Public -;;; -;;; Stick NIL in the key table specified. -;;; -(defun delete-key-binding (key &optional (kind :global) where) - "Remove a Hemlock key binding somewhere. Name is the string name of - a Hemlock command, Key is either a character or a vector of - characters. Kind is one of :Global, :Mode or :Buffer, Where is the - mode name or buffer concerned. Kind defaults to :Global." - (set-table-entry (get-right-table kind where) - (translate-key (crunch-key key)) - nil)) - - -;;; GET-CURRENT-BINDING -- Internal -;;; -;;; Look up a key in the current environment. -;;; -(defun get-current-binding (key) - (let ((res (get-table-entry (buffer-bindings *current-buffer*) key))) - (cond - (res (values res nil)) - (t - (do ((mode (buffer-mode-objects *current-buffer*) (cdr mode)) - (t-bindings ())) - ((null mode) - (values (get-table-entry *global-command-table* key) - (nreverse t-bindings))) - (declare (list t-bindings)) - (let ((res (get-table-entry (mode-object-bindings (car mode)) key))) - (when res - (if (mode-object-transparent-p (car mode)) - (push res t-bindings) - (return (values res (nreverse t-bindings))))))))))) - - -;;; GET-COMMAND -- Public -;;; -;;; Look up the key binding, checking for :Prefix. -;;; -(defun get-command (key &optional (kind :global) where) - "Return the command object for the command bound to key somewhere. - If key is not bound return NIL, if Key is a prefix of a key-binding - then reutrn :Prefix. Name is the string name of a Hemlock command, - Key is either a character or a vector of characters. Kind is one of - :Global, :Mode or :Buffer, Where is the mode name or buffer - concerned. Kind defaults to :Global." - (multiple-value-bind (key prefix-p) - (translate-key (crunch-key key)) - (let ((entry (if (eq kind :current) - (get-current-binding key) - (get-table-entry (get-right-table kind where) key)))) - (etypecase entry - (null (if prefix-p :prefix nil)) - (command entry) - (key-table :prefix))))) - - -;;; MAP-BINDINGS -- Public -;;; -;;; map over a key table. -;;; -(defun map-bindings (fun kind &optional where) - "Map Fun over the bindings in some place. The function is passed the - Key and the command to which it is bound." - (sub-map-bindings fun (key-table-table (get-right-table kind where)) '#())) -;;; -(defun sub-map-bindings (fun tab key) - (declare (simple-vector tab key)) - (let ((key (concatenate 'simple-vector key '#(#\space))) - (index (length key))) - (dotimes (bits command-char-bits-limit) - (let ((vec (svref tab bits))) - (when vec - (dotimes (code command-char-code-limit) - (setf (svref key index) (code-char code bits)) - (let ((val (svref vec code))) - (cond ((null val)) - ((commandp val) - (funcall fun key val)) - (t - (sub-map-bindings fun (key-table-table val) - key)))))))))) - - -;;; MAKE-COMMAND -- Public -;;; -;;; If the command is already defined then alter the command object, -;;; otherwise make a new command object and enter it into the -;;; *command-names*. -;;; -(defun make-command (name documentation function) - "Create a new Hemlock command with Name and Documentation which is - implemented by calling the function-value of the symbol Function" - (let ((entry (getstring name *command-names*))) - (cond - (entry - (setf (command-name entry) name) - (setf (command-documentation entry) documentation) - (setf (command-function entry) function)) - (t - (setf (getstring name *command-names*) - (internal-make-command name documentation function)))))) - - -;;; COMMAND-NAME, %SET-COMMAND-NAME -- Public -;;; -;;; Filter the slot, updating *command-names* if it is set. -;;; -(defun command-name (command) - "Returns the string which is the name of Command." - (command-%name command)) -;;; -(defun %set-command-name (command new-name) - (check-type command command) - (check-type new-name string) - (setq new-name (coerce new-name 'simple-string)) - (delete-string (command-%name command) *command-names*) - (setf (getstring new-name *command-names*) command) - (setf (command-%name command) new-name)) - - -;;; COMMAND-BINDINGS -- Public -;;; -;;; Check that all the supposed bindings really exists. Bindings which -;;; were once made may have been overwritten. It is easier to filter -;;; out bogus bindings here than to catch all the cases that can make a -;;; binding go away. -;;; -(defun binding= (b1 b2) - (and (eq (second b1) (second b2)) - (equal (third b1) (third b2)) - (let* ((k1 (first b2)) - (l1 (length k1)) - (k2 (first b1))) - (declare (simple-vector k1 k2)) - (if (= l1 (length k2)) - (dotimes (i l1 t) - (when (char/= (svref k1 i) (svref k2 i)) - (return nil))))))) -;;; -(defun command-bindings (command) - "Return a list of lists of the form (key kind where) describing - all the places there Command is bound." - (check-type command command) - (let (res) - (declare (list res)) - (dolist (place (command-%bindings command)) - (let ((tab (case (cadr place) - (:global *global-command-table*) - (:mode - (let ((m (getstring (caddr place) *mode-names*))) - (when m (mode-object-bindings m)))) - (t - (when (memq (caddr place) *buffer-list*) - (buffer-bindings (caddr place))))))) - (when (and tab (eq (get-table-entry tab (car place)) command) - (not (find place res :test #'binding=))) - (push place res)))) - res)) - - -(defvar *last-command-type* () - "The command-type of the last command invoked.") -(defvar *command-type-set* () - "True if the last command set the command-type.") - -;;; LAST-COMMAND-TYPE -- Public -;;; -;;; -(defun last-command-type () - "Return the command-type of the last command invoked. - If no command-type has been set then return NIL. Setting this with - Setf sets the value for the next command." - *last-command-type*) - -;;; %SET-LAST-COMMAND-TYPE -- Internal -;;; -;;; Set the flag so we know not to clear the command-type. -;;; -(defun %set-last-command-type (type) - (setq *last-command-type* type *command-type-set* t)) - - -(defvar *prefix-argument* nil "The prefix argument or NIL.") -(defvar *prefix-argument-supplied* nil - "Should be set by functions which supply a prefix argument.") - -;;; PREFIX-ARGUMENT -- Public -;;; -;;; -(defun prefix-argument () - "Return the current value of the prefix argument. This can be set - with Setf." - *prefix-argument*) - -;;; %SET-PREFIX-ARGUMENT -- Internal -;;; -(defun %set-prefix-argument (argument) - "Set the prefix argument for the next command to Argument." - (unless (or (null argument) (integerp argument)) - (error "Prefix argument ~S is neither an integer nor Nil." argument)) - (setq *prefix-argument* argument *prefix-argument-supplied* t)) - -;;;; The Command Loop: - -;;; Buffers we use to read and translate keys. -;;; -(defvar *current-command* (make-array 10 :fill-pointer 0 :adjustable t)) -(defvar *current-translation* (make-array 10 :fill-pointer 0 :adjustable t)) - -(defvar *invoke-hook* #'(lambda (command p) - (funcall (command-function command) p)) - "This function is called by the command interpreter when it wants to invoke a - command. The arguments are the command to invoke and the prefix argument. - The default value just calls the Command-Function with the prefix argument.") - - -;;; %COMMAND-LOOP -- Internal -;;; -;;; Read commands from the terminal and execute them, forever. -;;; -(defun %command-loop () - (let ((cmd *current-command*) - (trans *current-translation*) - (*last-command-type* nil) - (*command-type-set* nil) - (*prefix-argument* nil) - (*prefix-argument-supplied* nil)) - (declare (special *last-command-type* *command-type-set* - *prefix-argument* *prefix-argument-supplied*)) - (setf (fill-pointer cmd) 0) - (handler-bind - ;; Bind this outside the invocation loop to save consing. - ((editor-error #'(lambda (condx) - (beep) - (let ((string (editor-error-format-string condx))) - (when string - (apply #'message string - (editor-error-format-arguments condx))) - (throw 'command-loop-catcher nil))))) - (loop - (unless (eq *current-buffer* *echo-area-buffer*) - (when (buffer-modified *echo-area-buffer*) (clear-echo-area)) - (unless (or (zerop (length cmd)) - (not (value ed::key-echo-delay))) - (editor-sleep (value ed::key-echo-delay)) - (unless (listen *editor-input*) - (clear-echo-area) - (dotimes (i (length cmd)) - (print-pretty-character (aref cmd i) *echo-area-stream*) - (write-char #\space *echo-area-stream*))))) - (vector-push-extend (read-char *editor-input*) cmd) - - (multiple-value-bind (trans-result prefix-p) - (translate-key cmd trans) - (multiple-value-bind (res t-bindings) - (get-current-binding trans-result) - (cond - ((commandp res) - (let ((punt t)) - (catch 'command-loop-catcher - (dolist (c t-bindings) - (funcall *invoke-hook* c *prefix-argument*)) - (funcall *invoke-hook* res *prefix-argument*) - (setf punt nil)) - (when punt (invoke-hook ed::command-abort-hook))) - (if *command-type-set* - (setq *command-type-set* nil) - (setq *last-command-type* nil)) - (if *prefix-argument-supplied* - (setq *prefix-argument-supplied* nil) - (setq *prefix-argument* nil)) - (setf (fill-pointer cmd) 0)) - ((null res) - (unless prefix-p - (beep) - (setq *prefix-argument* nil) - (setf (fill-pointer cmd) 0))) - ((not (key-table-p res)) - (error "Bad thing in key table: ~S" res))))))))) - - -;;; EXIT-HEMLOCK -- Public -;;; -(defun exit-hemlock (&optional (value t)) - "Exit from ED, returning the specified value." - (throw 'hemlock-exit value)) diff --git a/hemlock/kbdmac.lisp b/hemlock/kbdmac.lisp deleted file mode 100644 index 775bfcd34b412af76e928ea8120c8365a657f461..0000000000000000000000000000000000000000 --- a/hemlock/kbdmac.lisp +++ /dev/null @@ -1,464 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the implementation of keyboard macros for -;;; Hemlock. In itself it contains nothing particularly gross or -;;; implementation dependant, but it uses some hooks in the stream -;;; system and other stuff. -;;; -(in-package 'hemlock) - -;;; We have "Keyboard Macro Transforms" that help in making a keyboard -;;; macro. What they do is turn the sequence of commands into equivalent -;;; lisp code. They operate under the following principles: -;;; -;;; They are passed two arguments: -;;; 1] The command invoked. -;;; 2] A keyword, either :invoke, :start or :finish -;;; -;;; If the keyword is :invoke, then the transform is expected to -;;; invoke the command and do whatever is necessary to make the same -;;; thing happen again when the macro is invoked. The method does this -;;; by pushing forms on the list *current-kbdmac* and characters to -;;; simulate input of on *kbdmac-input*. *current-kbdmac* is kept -;;; in reverse order. Each form must be a function call, and none -;;; of the arguments are evaluated. If the transform is unwound, -;;; presumably due to an error in the invoked command, then nothing -;;; should be done at invocation time. -;;; -;;; If the keyword is :finish, then nothing need be done. This -;;; is to facilitate compaction of repetitions of the same command -;;; into one call. The transform is called with :finish when a run -;;; is broken. Similarly, the transform is called with :start -;;; before the first occurrence in a run. - -(defvar *kbdmac-transcript* (make-array 100 :fill-pointer 0 :adjustable t) - "The thing we bind *input-transcript* to during keyboard macro definition.") - -(defvar *kbdmac-input* (make-array 100 :fill-pointer 0 :adjustable t) - "Place where we stick input that will need to be simulated during keyboard - macro execution.") - -(defvar *current-kbdmac* () "Body of keyboard macro we are building.") - -(defvar *kbdmac-transforms* (make-hash-table :test #'eq) - "Hashtable of function that know how to do things.") - -(defvar *old-invoke-hook* () "Bound to *invoke-hook* by kbdmac-command-loop.") - -(defmacro define-kbdmac-transform (command function) - `(setf (gethash (getstring ,command *command-names*) - *kbdmac-transforms*) - ,function)) - -(defmacro kbdmac-emit (form) - `(push ,form *current-kbdmac*)) - -(defun trash-character () - "Throw away a character on *editor-input*." - (read-char *editor-input*)) - -;;; Save-Kbdmac-Input -- Internal -;;; -;;; Pushes any input read within the body on *kbdmac-input* so that -;;; it is read again at macro invocation time. It uses the (input-waiting) -;;; function which is a non-standard hook into the stream system. -;;; -(defmacro save-kbdmac-input (&body forms) - (let ((slen (gensym))) - `(let ((,slen (- (length *kbdmac-transcript*) (if (input-waiting) 1 0)))) - (multiple-value-prog1 - (progn ,@forms) - (do ((i ,slen (1+ i)) - (elen (length *kbdmac-transcript*))) - ((= i elen) - (when (input-waiting) - (kbdmac-emit '(trash-character)))) - (vector-push-extend (aref *kbdmac-transcript* i) - *kbdmac-input*)))))) - -;;;; The default transform -;;; -;;; This transform is called when none is defined for a command. -;;; -(defun default-kbdmac-transform (command key) - (case key - (:invoke - (let ((fun (command-function command)) - (arg (prefix-argument)) - (lastc *last-character-typed*)) - (save-kbdmac-input - (let ((*invoke-hook* *old-invoke-hook*)) - (funcall fun arg)) - (kbdmac-emit `(set *last-character-typed* ,lastc)) - (kbdmac-emit `(,fun ,arg))))))) - -;;;; Self insert transform: -;;; -;;; For self insert we accumulate the text in a string and then -;;; insert it all at once. -;;; - -(defvar *kbdmac-text* (make-array 100 :element-type 'string-char - :fill-pointer 0 - :adjustable t)) - -(defun insert-string-at-point (string) - (insert-string (buffer-point (current-buffer)) string)) -(defun insert-character-at-point (character) - (insert-character (buffer-point (current-buffer)) character)) - -(defun self-insert-kbdmac-transform (command key) - (case key - (:start - (setf (fill-pointer *kbdmac-text*) 0)) - (:invoke - (let ((p (or (prefix-argument) 1))) - (funcall (command-function command) p) - (dotimes (i p) - (vector-push-extend *last-character-typed* *kbdmac-text*)))) - (:finish - (if (> (length (the string *kbdmac-text*)) 1) - (kbdmac-emit `(insert-string-at-point - ,(copy-seq (the string *kbdmac-text*)))) - (kbdmac-emit `(insert-character-at-point ,(char *kbdmac-text* 0))))))) -;;; -(define-kbdmac-transform "Self Insert" #'self-insert-kbdmac-transform) -(define-kbdmac-transform "Lisp Insert )" #'self-insert-kbdmac-transform) - -;;;; Do-Nothing transform: -;;; -;;; These are useful for prefix-argument setting commands, since they have -;;; no semantics at macro-time. -;;; -(defun do-nothing-kbdmac-transform (command key) - (case key - (:invoke - (funcall (command-function command) (prefix-argument))))) -;;; -(define-kbdmac-transform "Argument Digit" #'do-nothing-kbdmac-transform) -(define-kbdmac-transform "Negative Argument" #'do-nothing-kbdmac-transform) -(define-kbdmac-transform "Universal Argument" #'do-nothing-kbdmac-transform) - -;;;; Multiplicative transform -;;; -;;; Repititions of many commands can be turned into a call with an -;;; argument. -;;; -(defvar *kbdmac-count* 0 - "The number of occurrences we have counted of a given command.") - -(defun multiplicative-kbdmac-transform (command key) - (case key - (:start - (setq *kbdmac-count* 0)) - (:invoke - (let ((p (or (prefix-argument) 1))) - (funcall (command-function command) p) - (incf *kbdmac-count* p))) - (:finish - (kbdmac-emit `(,(command-function command) ,*kbdmac-count*))))) -;;; -(define-kbdmac-transform "Forward Character" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Backward Character" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Forward Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Backward Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Uppercase Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Lowercase Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Capitalize Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Kill Next Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Kill Previous Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Forward Kill Form" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Backward Kill Form" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Forward Form" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Backward Form" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Delete Next Character" - #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Delete Previous Character" - #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Delete Previous Character Expanding Tabs" - #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Next Line" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Previous Line" #'multiplicative-kbdmac-transform) - - -;;;; Vanilla transform -;;; -;;; These commands neither read input nor look at random silly variables. -;;; -(defun vanilla-kbdmac-transform (command key) - (case key - (:invoke - (let ((fun (command-function command)) - (p (prefix-argument))) - (funcall fun p) - (kbdmac-emit `(,fun ,p)))))) -;;; -(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "End of Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Indent for Lisp" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Delete Horizontal Space" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Kill Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Backward Kill Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Un-Kill" #'vanilla-kbdmac-transform) - -;;;; MAKE-KBDMAC, INTERACTIVE, and kbdmac command loop. - -;;; Kbdmac-Command-Loop -- Internal -;;; -;;; Bind *invoke-hook* to call kbdmac transforms. -;;; -(defun kbdmac-command-loop () - (let* ((last-transform nil) - (last-command nil) - (last-ctype nil) - (*old-invoke-hook* *invoke-hook*) - (*invoke-hook* - #'(lambda (res p) - (declare (ignore p)) - (when (and (not (eq last-command res)) last-transform) - (funcall last-transform last-command :finish)) - (if (last-command-type) - (setq last-ctype t) - (when last-ctype - (kbdmac-emit '(clear-command-type)) - (setq last-ctype nil))) - (setq last-transform - (gethash res *kbdmac-transforms* #'default-kbdmac-transform)) - (unless (eq last-command res) - (funcall last-transform res :start)) - (funcall last-transform res :invoke) - (setq last-command res)))) - (declare (special *invoke-hook*)) - (setf (last-command-type) nil) - (recursive-edit nil))) - -(defun clear-command-type () - (setf (last-command-type) nil)) - - -(defvar *defining-a-keyboard-macro* ()) -(defvar *kbdmac-stream* (make-kbdmac-stream)) -(defvar *in-a-keyboard-macro* () - "True if we are currently executing a keyboard macro.") - -;;; Interactive -- Public -;;; -;;; See whether we are in a keyboard macro. -;;; -(defun interactive () - "Return true if we are in a command invoked by the user. - This is primarily useful for commands which want to know - whether do something when an error happens, or just signal - an Editor-Error." - (not *in-a-keyboard-macro*)) - -(defvar *kbdmac-done* () - "Setting this causes the keyboard macro being executed to terminate - after the current iteration.") - -(defvar *kbdmac-dont-ask* () - "Setting this inhibits \"Keyboard Macro Query\"'s querying.") - -;;; Make-Kbdmac -- Internal -;;; -;;; This guy grabs the stuff lying around in *current-kbdmac* and -;;; whatnot and makes a lexical closure that can be used as the -;;; definition of a command. The prefix argument is a repitition -;;; count. -;;; -(defun make-kbdmac () - (let ((code (nreverse *current-kbdmac*)) - (input (copy-seq *kbdmac-input*))) - (if (zerop (length input)) - #'(lambda (p) - (let ((*in-a-keyboard-macro* t) - (*kbdmac-done* nil) - (*kbdmac-dont-ask* nil)) - (setf (last-command-type) nil) - (catch 'exit-kbdmac - (dotimes (i (or p 1)) - (catch 'abort-kbdmac-iteration - (dolist (form code) - (apply (car form) (cdr form)))) - (when *kbdmac-done* (return nil)))))) - #'(lambda (p) - (let* ((stream (or *kbdmac-stream* (make-kbdmac-stream))) - (*kbdmac-stream* nil) - (*editor-input* stream) - (*in-a-keyboard-macro* t) - (*kbdmac-done* nil) - (*kbdmac-dont-ask* nil)) - (setf (last-command-type) nil) - (catch 'exit-kbdmac - (dotimes (i (or p 1)) - (setq stream (modify-kbdmac-stream stream input)) - (catch 'abort-kbdmac-iteration - (dolist (form code) - (apply (car form) (cdr form)))) - (when *kbdmac-done* (return nil))))))))) - - - -;;;; Commands. - -(defmode "Def" :major-p nil) - -(defcommand "Define Keyboard Macro" (p) - "Define a keyboard macro." - "Define a keyboard macro." - (declare (ignore p)) - (when *defining-a-keyboard-macro* - (editor-error "Already defining a keyboard macro.")) - (define-keyboard-macro)) - -(defhvar "Define Keyboard Macro Key Confirm" - "When set, \"Define Keyboard Macro Key\" asks for confirmation before - clobbering an existing key binding." - :value t) - -(defcommand "Define Keyboard Macro Key" (p) - "Prompts for a key before going into a mode for defining keyboard macros. - The macro definition is bound to the key. IF the key is already bound, - this asks for confirmation before clobbering the binding." - "Prompts for a key before going into a mode for defining keyboard macros. - The macro definition is bound to the key. IF the key is already bound, - this asks for confirmation before clobbering the binding." - (declare (ignore p)) - (when *defining-a-keyboard-macro* - (editor-error "Already defining a keyboard macro.")) - (multiple-value-bind (key kind where) - (get-keyboard-macro-key) - (when key - (setf (buffer-minor-mode (current-buffer) "Def") t) - (let ((name (format nil "Keyboard Macro ~S" (gensym)))) - (make-command name "This is a user-defined keyboard macro." - (define-keyboard-macro)) - (bind-key name key kind where) - (message "~A bound to ~A." - (with-output-to-string (s) (sub-print-key key s)) - name))))) - -;;; GET-KEYBOARD-MACRO-KEY gets a key from the user and confirms clobbering it -;;; if it is already bound to a command, or it is a :prefix. This returns nil -;;; if the user "aborts", otherwise it returns the key and location (kind -;;; where) of the binding. -;;; -(defun get-keyboard-macro-key () - (let* ((key (prompt-for-key :prompt "Bind keyboard macro to key: " - :must-exist nil))) - (multiple-value-bind (kind where) - (prompt-for-place "Kind of binding: " - "The kind of binding to make.") - (let* ((cmd (get-command key kind where))) - (cond ((not cmd) (values key kind where)) - ((commandp cmd) - (if (prompt-for-y-or-n - :prompt `("~A is bound to ~A. Rebind it? " - ,(with-output-to-string (s) - (sub-print-key key s)) - ,(command-name cmd)) - :default nil) - (values key kind where) - nil)) - ((eq cmd :prefix) - (if (prompt-for-y-or-n - :prompt `("~A is a prefix for more than one command. ~ - Clobber it? " - ,(with-output-to-string (s) - (sub-print-key key s))) - :default nil) - (values key kind where) - nil))))))) - -;;; DEFINE-KEYBOARD-MACRO gets input from the user and clobbers the function -;;; for the "Last Keyboard Macro" command. This returns the new function. -;;; -(defun define-keyboard-macro () - (setf (buffer-minor-mode (current-buffer) "Def") t) - (unwind-protect - (let* ((in *kbdmac-transcript*) - (*input-transcript* in) - (*defining-a-keyboard-macro* t)) - (setf (fill-pointer in) 0) - (setf (fill-pointer *kbdmac-input*) 0) - (setq *current-kbdmac* ()) - (catch 'punt-kbdmac - (kbdmac-command-loop)) - (setf (command-function (getstring "Last Keyboard Macro" *command-names*)) - (make-kbdmac))) - (setf (buffer-minor-mode (current-buffer) "Def") nil))) - - -(defcommand "End Keyboard Macro" (p) - "End the definition of a keyboard macro." - "End the definition of a keyboard macro." - (declare (ignore p)) - (unless *defining-a-keyboard-macro* - (editor-error "Not defining a keyboard macro.")) - (throw 'punt-kbdmac ())) -;;; -(define-kbdmac-transform "End Keyboard Macro" #'do-nothing-kbdmac-transform) - - -(defcommand "Last Keyboard Macro" (p) - "Execute the last keyboard macro defined. - With prefix argument execute it that many times." - "Execute the last keyboard macro P times." - (declare (ignore p)) - (editor-error "No keyboard macro defined.")) - -(defcommand "Name Keyboard Macro" (p &optional name) - "Name the \"Last Keyboard Macro\". - The last defined keboard macro is made into a named command." - "Make the \"Last Keyboard Macro\" a named command." - (declare (ignore p)) - (unless name - (setq name (prompt-for-string - :prompt "Macro name: " - :help "String name of command to make from keyboard macro."))) - (make-command - name "This is a named keyboard macro." - (command-function (getstring "Last Keyboard Macro" *command-names*)))) - -(defcommand "Keyboard Macro Query" (p) - "Keyboard macro conditional. - During the execution of a keyboard macro, this command prompts for - a single character command, similar to those of \"Query Replace\"." - "Prompt for action during keyboard macro execution." - (declare (ignore p)) - (unless (or (interactive) *kbdmac-dont-ask*) - (let ((*editor-input* *real-editor-input*)) - (command-case (:prompt "Keyboard Macro Query: " - :help "Type one of these characters to say what to do:" - :change-window nil - :bind ch) - (:exit - "Exit this keyboard macro immediately." - (throw 'exit-kbdmac nil)) - (:yes - "Proceed with this iteration of the keyboard macro.") - (:no - "Don't do this iteration of the keyboard macro, but continue to the next." - (throw 'abort-kbdmac-iteration nil)) - (:do-all - "Do all remaining repetitions of the keyboard macro without prompting." - (setq *kbdmac-dont-ask* t)) - (:do-once - "Do this iteration of the keyboard macro and then exit." - (setq *kbdmac-done* t)) - (:recursive-edit - "Do a recursive edit, then ask again." - (do-recursive-edit) - (reprompt)) - (t - (unread-char ch *editor-input*) - (throw 'exit-kbdmac nil)))))) diff --git a/hemlock/keytran.lisp b/hemlock/keytran.lisp deleted file mode 100644 index 32460101472ee775a59ac958b974d91e3facfb7f..0000000000000000000000000000000000000000 --- a/hemlock/keytran.lisp +++ /dev/null @@ -1,182 +0,0 @@ -;;; -*- Log: hemlock.log; Package: extensions -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains a default character translation mechanism for X11 -;;; scan codes, keysyms, button codes, and modifier bits. -;;; -;;; Written by Bill Chiles. -;;; - -(in-package "EXTENSIONS") - -(export '(define-keysym define-mouse-code define-keyboard-modifier - translate-character translate-mouse-character)) - - - -;;;; Keysym to character translation. - -;;; Hemlock uses its own keysym to character translation since this is easier -;;; and more versatile than the CLX design. Also, using CLX's mechanism is no -;;; more portable than writing our own translation based on the X11 protocol -;;; keysym specification. -;;; -;;; In the first table, nil indicates a non-event which is pertinent to -;;; ignoring modifier keys being pressed prior to pressing a key to be -;;; modified. In the second table, nil simply indicates that there is no -;;; special shift translation for the keysym, and that the CLX shifted keysym -;;; should be looked up as normal (see TRANSLATE-CHARACTER). -;;; -;;; This mapping is initialized with DEFINE-KEYSYM in Keytrandefs.Lisp -;;; -(defvar *keysym-translations* (make-hash-table)) -(defvar *shifted-keysym-translations* (make-hash-table)) - -(defun define-keysym (keysym char &optional shifted-char) - "Defines a keysym for Hemlock's translation. If shifted-char is supplied, - it is a character to use when the :shift modifier is on for an incoming - keysym. If shifted-char is not supplied, and the :shift modifier is set, - then XLIB:KEYCODE->KEYSYM is called with an index of 1 instead of 0. If - a :lock modifier is set, it is treated as a caps-lock. See - DEFINE-KEYBOARD-MODIFIER." - (check-type char character) - (setf (gethash keysym *keysym-translations*) char) - (when shifted-char - (check-type shifted-char character) - (setf (gethash keysym *shifted-keysym-translations*) shifted-char)) - t) - - -;;; X modifier bits translation -;;; -(defvar *modifier-translations* ()) - -(defun define-keyboard-modifier (clx-mask modifier-name) - "Causes clx-mask to be interpreted as modifier-name which must be one of - :control, :meta, :super, :hyper, :shift, or :lock." - (let ((map (assoc clx-mask *modifier-translations*))) - (if map - (rplacd map modifier-name) - (push (cons clx-mask modifier-name) *modifier-translations*)))) - -(define-keyboard-modifier (xlib:make-state-mask :control) :control) -(define-keyboard-modifier (xlib:make-state-mask :mod-1) :meta) -(define-keyboard-modifier (xlib:make-state-mask :shift) :shift) -(define-keyboard-modifier (xlib:make-state-mask :lock) :lock) - - -(defun translate-character (display scan-code bits) - "Translates scan-code and modifier bits to a Lisp character. The scan code - is first mapped to a keysym with index 0 for unshifted and index 1 for - shifted. If this keysym does not map to a character, and it is not a - modifier key (shift, ctrl, etc.), then an error is signaled. If the keysym - is a modifier key, then nil is returned. If we do have a character, and the - shift bit is off, and the lock bit is on, and the character is alphabetic, - then we get a new keysym with index 1, mapping it to a character. If this - does not result in a character, an error is signaled. If we have a - character, and the shift bit is on, then we look for a special shift mapping - for the original keysym. This allows for distinct characters for scan - codes that map to the same keysym, shifted or unshifted, (e.g., number pad - or arrow keys)." - (let ((dummy #\?) - shiftp lockp) - (dolist (ele *modifier-translations*) - (unless (zerop (logand (car ele) bits)) - (case (cdr ele) - (:shift (setf shiftp t)) - (:lock (setf lockp t)) - (t (setf dummy (set-char-bit dummy (cdr ele) t)))))) - (let* ((keysym (xlib:keycode->keysym display scan-code (if shiftp 1 0))) - (temp-char (gethash keysym *keysym-translations*))) - (cond ((not temp-char) - (if (<= 65505 keysym 65518) ;modifier keys. - nil - (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM." - keysym))) - ((and (not shiftp) lockp (alpha-char-p temp-char)) - (let* ((keysym (xlib:keycode->keysym display scan-code 1)) - (char (gethash keysym *keysym-translations*))) - (unless char - (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM." - keysym)) - (make-char char (logior (char-bits char) (char-bits dummy))))) - (shiftp - (let ((char (gethash keysym *shifted-keysym-translations*))) - (if char - (make-char char (logior (char-bits char) (char-bits dummy))) - (make-char temp-char (logior (char-bits temp-char) - (char-bits dummy)))))) - (t (make-char temp-char (logior (char-bits temp-char) - (char-bits dummy)))))))) - - - -;;;; Mouse to character translations. - -;;; Mouse codes come from the server numbered one through five. This table is -;;; indexed by the code to retrieve a list. The CAR is a cons of the char and -;;; shifted char associated with a :button-press event. The CDR is a cons of -;;; the char and shifted char associated with a :button-release event. Each -;;; of these is potentially nil (not a cons at all). -;;; -(defvar *mouse-translations* (make-array 6 :initial-element nil)) -;;; -(defmacro mouse-press-chars (ele) `(car ,ele)) -(defmacro mouse-release-chars (ele) `(cadr ,ele)) - -(defun define-mouse-code (button char shifted-char event-key) - "Causes X button code to be interpreted as char. Shift and Lock modifiers - associated with button map to shifted-char. For the same button code, - event-key may be :button-press or :button-release." - (check-type char character) - (check-type shifted-char character) - (check-type event-key (member :button-press :button-release)) - (let ((stuff (svref *mouse-translations* button)) - (trans (cons char shifted-char))) - (if stuff - (case event-key - (:button-press (setf (mouse-press-chars stuff) trans)) - (:button-release (setf (mouse-release-chars stuff) trans))) - (case event-key - (:button-press - (setf (svref *mouse-translations* button) (list trans nil))) - (:button-release - (setf (svref *mouse-translations* button) (list nil trans)))))) - t) - -(define-mouse-code 1 #\leftdown #\super-leftdown :button-press) -(define-mouse-code 1 #\leftup #\super-leftup :button-release) - -(define-mouse-code 2 #\middledown #\super-middledown :button-press) -(define-mouse-code 2 #\middleup #\super-middleup :button-release) - -(define-mouse-code 3 #\rightdown #\super-rightdown :button-press) -(define-mouse-code 3 #\rightup #\super-rightup :button-release) - -(defun translate-mouse-character (scan-code bits event-key) - "Translates X button code, scan-code, and modifier bits, bits, for event-key - (either :button-press or :button-release) to a Lisp character." - (let ((temp (svref *mouse-translations* scan-code))) - (unless temp (error "Unknown mouse button -- ~S." scan-code)) - (let ((trans (ecase event-key - (:button-press (mouse-press-chars temp)) - (:button-release (mouse-release-chars temp))))) - (unless trans (error "Undefined ~S characters for mouse button ~S." - event-key scan-code)) - (let ((dummy #\?) - shiftp) - (dolist (ele *modifier-translations*) - (unless (zerop (logand (car ele) bits)) - (let ((bit (cdr ele))) - (if (or (eq bit :shift) (eq bit :lock)) - (setf shiftp t) - (setf dummy (set-char-bit dummy bit t)))))) - (let ((char (if shiftp (cdr trans) (car trans)))) - (make-char char (logior (char-bits char) (char-bits dummy)))))))) diff --git a/hemlock/keytrandefs.lisp b/hemlock/keytrandefs.lisp deleted file mode 100644 index b150356554cff53c953b25e2f180f81bdc557a49..0000000000000000000000000000000000000000 --- a/hemlock/keytrandefs.lisp +++ /dev/null @@ -1,183 +0,0 @@ -;;; -*- Log: hemlock.log; Mode: Lisp; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file initializes character translation that would otherwise be done -;;; in Rompsite.Slisp, but there are no good hacks for mapping X11 keysyms -;;; to CMU Common Lisp character codes. -;;; -;;; Written by Bill Chiles. -;;; - -;;; The IBM RT keyboard has X11 keysyms defined for the following modifier -;;; keys, but we leave them mapped to nil indicating that they are non-events -;;; to be ignored: -;;; ctrl 65507 -;;; meta (left) 65513 -;;; meta (right) 65514 -;;; shift (left) 65505 -;;; shift (right) 65506 -;;; lock 65509 - -(in-package "HEMLOCK-INTERNALS") - - -;;; Function keys for the RT. -;;; -(define-keysym 65470 #\f1 #\s-f1) -(define-keysym 65471 #\f2 #\s-f2) -(define-keysym 65472 #\f3 #\s-f3) -(define-keysym 65473 #\f4 #\s-f4) -(define-keysym 65474 #\f5 #\s-f5) -(define-keysym 65475 #\f6 #\s-f6) -(define-keysym 65476 #\f7 #\s-f7) -(define-keysym 65477 #\f8 #\s-f8) -(define-keysym 65478 #\f9 #\s-f9) -(define-keysym 65479 #\f10 #\s-f10) -(define-keysym 65480 #\f11 #\s-f11) -(define-keysym 65481 #\f12 #\s-f12) - -;;; Function keys for the Sun (and other keyboards) -- L1-L10 and R1-R15. -;;; -(define-keysym 65482 #\f13 #\s-f13) -(define-keysym 65483 #\f14 #\s-f14) -(define-keysym 65484 #\f15 #\s-f15) -(define-keysym 65485 #\f16 #\s-f16) -(define-keysym 65486 #\f17 #\s-f17) -(define-keysym 65487 #\f18 #\s-f18) -(define-keysym 65488 #\f19 #\s-f19) -(define-keysym 65489 #\f20 #\s-f20) -(define-keysym 65490 #\f21 #\s-f21) -(define-keysym 65491 #\f22 #\s-f22) -(define-keysym 65492 #\f23 #\s-f23) -(define-keysym 65493 #\f24 #\s-f24) -(define-keysym 65494 #\f25 #\s-f25) -(define-keysym 65495 #\f26 #\s-f26) -(define-keysym 65496 #\f27 #\s-f27) -(define-keysym 65497 #\f28 #\s-f28) -(define-keysym 65498 #\f29 #\s-f29) -(define-keysym 65499 #\f30 #\s-f30) -(define-keysym 65500 #\f31 #\s-f31) -(define-keysym 65501 #\f32 #\s-f32) -(define-keysym 65502 #\f33 #\s-f33) -(define-keysym 65503 #\f34 #\s-f34) -(define-keysym 65504 #\f35 #\s-f35) - -;;; Upper right key bank. -;;; -(define-keysym 65377 #\printscreen #\s-printscreen) -;; Couldn't type scroll lock. -(define-keysym 65299 #\pause #\s-pause) - -;;; Middle right key bank. -;;; -(define-keysym 65379 #\insert #\s-insert) -(define-keysym 65535 #\delete #\delete) -(define-keysym 65360 #\home #\s-home) -(define-keysym 65365 #\pageup #\s-pageup) -(define-keysym 65367 #\end #\s-end) -(define-keysym 65366 #\pagedown #\s-pagedown) - -;;; Arrows. -;;; -(define-keysym 65361 #\leftarrow #\s-leftarrow) -(define-keysym 65362 #\uparrow #\s-uparrow) -(define-keysym 65364 #\downarrow #\s-downarrow) -(define-keysym 65363 #\rightarrow #\s-rightarrow) - -;;; Number pad. -;;; -(define-keysym 65407 #\numlock #\s-numlock) -(define-keysym 65421 #\s-return #\s-return) ;num-pad-enter -(define-keysym 65455 #\s-/ #\s-/) ;num-pad-/ -(define-keysym 65450 #\s-* #\s-*) ;num-pad-* -(define-keysym 65453 #\s-- #\s--) ;num-pad-- -(define-keysym 65451 #\s-+ #\s-+) ;num-pad-+ -(define-keysym 65456 #\s-0 #\s-0) ;num-pad-0 -(define-keysym 65457 #\s-1 #\s-1) ;num-pad-1 -(define-keysym 65458 #\s-2 #\s-2) ;num-pad-2 -(define-keysym 65459 #\s-3 #\s-3) ;num-pad-3 -(define-keysym 65460 #\s-4 #\s-4) ;num-pad-4 -(define-keysym 65461 #\s-5 #\s-5) ;num-pad-5 -(define-keysym 65462 #\s-6 #\s-6) ;num-pad-6 -(define-keysym 65463 #\s-7 #\s-7) ;num-pad-7 -(define-keysym 65464 #\s-8 #\s-8) ;num-pad-8 -(define-keysym 65465 #\s-9 #\s-9) ;num-pad-9 -(define-keysym 65454 #\s-. #\s-.) ;num-pad-. - -;;; "Named" keys. -;;; -(define-keysym 65289 #\tab #\tab) -(define-keysym 65307 #\escape #\escape) ;esc -(define-keysym 65288 #\backspace #\backspace) -(define-keysym 65293 #\return #\return) ;enter -(define-keysym 65512 #\linefeed #\linefeed) ;action -(define-keysym 32 #\space #\space) - -;;; Letters. -;;; -(define-keysym 97 #\a) (define-keysym 65 #\A) -(define-keysym 98 #\b) (define-keysym 66 #\B) -(define-keysym 99 #\c) (define-keysym 67 #\C) -(define-keysym 100 #\d) (define-keysym 68 #\D) -(define-keysym 101 #\e) (define-keysym 69 #\E) -(define-keysym 102 #\f) (define-keysym 70 #\F) -(define-keysym 103 #\g) (define-keysym 71 #\G) -(define-keysym 104 #\h) (define-keysym 72 #\H) -(define-keysym 105 #\i) (define-keysym 73 #\I) -(define-keysym 106 #\j) (define-keysym 74 #\J) -(define-keysym 107 #\k) (define-keysym 75 #\K) -(define-keysym 108 #\l) (define-keysym 76 #\L) -(define-keysym 109 #\m) (define-keysym 77 #\M) -(define-keysym 110 #\n) (define-keysym 78 #\N) -(define-keysym 111 #\o) (define-keysym 79 #\O) -(define-keysym 112 #\p) (define-keysym 80 #\P) -(define-keysym 113 #\q) (define-keysym 81 #\Q) -(define-keysym 114 #\r) (define-keysym 82 #\R) -(define-keysym 115 #\s) (define-keysym 83 #\S) -(define-keysym 116 #\t) (define-keysym 84 #\T) -(define-keysym 117 #\u) (define-keysym 85 #\U) -(define-keysym 118 #\v) (define-keysym 86 #\V) -(define-keysym 119 #\w) (define-keysym 87 #\W) -(define-keysym 120 #\x) (define-keysym 88 #\X) -(define-keysym 121 #\y) (define-keysym 89 #\Y) -(define-keysym 122 #\z) (define-keysym 90 #\Z) - -;;; Standard number keys. -;;; -(define-keysym 49 #\1) (define-keysym 33 #\!) -(define-keysym 50 #\2) (define-keysym 64 #\@) -(define-keysym 51 #\3) (define-keysym 35 #\#) -(define-keysym 52 #\4) (define-keysym 36 #\$) -(define-keysym 53 #\5) (define-keysym 37 #\%) -(define-keysym 54 #\6) (define-keysym 94 #\^) -(define-keysym 55 #\7) (define-keysym 38 #\&) -(define-keysym 56 #\8) (define-keysym 42 #\*) -(define-keysym 57 #\9) (define-keysym 40 #\() -(define-keysym 48 #\0) (define-keysym 41 #\)) - -;;; "Standard" symbol keys. -;;; -(define-keysym 96 #\`) (define-keysym 126 #\~) -(define-keysym 45 #\-) (define-keysym 95 #\_) -(define-keysym 61 #\=) (define-keysym 43 #\+) -(define-keysym 91 #\[) (define-keysym 123 #\{) -(define-keysym 93 #\]) (define-keysym 125 #\}) -(define-keysym 92 #\\) (define-keysym 124 #\|) -(define-keysym 59 #\;) (define-keysym 58 #\:) -(define-keysym 39 #\') (define-keysym 34 #\") -(define-keysym 44 #\,) (define-keysym 60 #\<) -(define-keysym 46 #\.) (define-keysym 62 #\>) -(define-keysym 47 #\/) (define-keysym 63 #\?) - - -;;; Sun keyboard. -;;; -(define-keysym 65387 #\break #\s-break) ;alternate (Sun). -(define-keysym 65290 #\linefeed #\s-linefeed) diff --git a/hemlock/killcoms.lisp b/hemlock/killcoms.lisp deleted file mode 100644 index 52359a858e3a95db0327c92414e17da72c2bf002..0000000000000000000000000000000000000000 --- a/hemlock/killcoms.lisp +++ /dev/null @@ -1,487 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Killing and unkilling things. -;;; -;;; Written by Bill Chiles and Rob MacLachlan. -;;; - -(in-package "HEMLOCK") - -(defvar *kill-ring* (make-ring 10) "The Hemlock kill ring.") - - - -;;;; Active Regions. - -(defhvar "Active Regions Enabled" - "When set, some commands that affect the current region only work when the - region is active." - :value t) - -(defhvar "Highlight Active Region" - "When set, the active region will be highlighted on the display if possible." - :value t) - - -(defvar *active-region-p* nil) -(defvar *active-region-buffer* nil) -(defvar *ephemerally-active-command-types* (list :ephemerally-active) - "This is a list of command types that permit the current region to be active - for the immediately following command.") - -(proclaim '(inline activate-region deactivate-region region-active-p)) - -(defun activate-region () - "Make the current region active." - (let ((buffer (current-buffer))) - (setf *active-region-p* (buffer-signature buffer)) - (setf *active-region-buffer* buffer))) - -(defun deactivate-region () - "Make the current region not active." - (setf *active-region-p* nil) - (setf *active-region-buffer* nil)) - -(defun region-active-p () - "Returns t or nil, depending on whether the current region is active." - (or (and *active-region-buffer* - (eql *active-region-p* (buffer-signature *active-region-buffer*))) - (member (last-command-type) *ephemerally-active-command-types* - :test #'equal))) - -(defun check-region-active () - "Signals an error when active regions are enabled and the current region - is not active." - (when (and (value active-regions-enabled) (not (region-active-p))) - (editor-error "The current region is not active."))) - -(defun current-region (&optional (error-if-not-active t) - (deactivate-region t)) - "Returns a region formed by CURRENT-MARK and CURRENT-POINT, optionally - signalling an editor error if the current region is not active. A new - region is cons'ed on each call. This optionally deactivates the region." - (when error-if-not-active (check-region-active)) - (when deactivate-region (deactivate-region)) - (let ((point (current-point)) - (mark (current-mark))) - (if (mark< mark point) (region mark point) (region point mark)))) - - -(defcommand "Activate Region" (p) - "Make the current region active. ^G deactivates the region." - "Make the current region active." - (declare (ignore p)) - (activate-region)) - - -;;; The following are hook functions for keeping things righteous. -;;; - -(defun set-buffer-deactivate-region (buffer) - (declare (ignore buffer)) - (deactivate-region)) -;;; -(add-hook set-buffer-hook 'set-buffer-deactivate-region) - -(defun set-window-deactivate-region (window) - (declare (ignore window)) - (unless (or (eq window *echo-area-window*) - (eq (current-window) *echo-area-window*)) - (deactivate-region))) -;;; -(add-hook set-window-hook 'set-window-deactivate-region) - -(defun control-g-deactivate-region () - (deactivate-region)) -;;; -(add-hook abort-hook 'control-g-deactivate-region) - - - -;;;; Buffer-Mark primitives and commands. - -;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the -;;; stack for each buffer. - -(defun current-mark () - "Returns the top of the current buffer's mark stack." - (ring-ref (value buffer-mark-ring) 0)) - -(defun buffer-mark (buffer) - "Returns the top of buffer's mark stack." - (ring-ref (variable-value 'buffer-mark-ring :buffer buffer) 0)) - -(defun pop-buffer-mark () - "Pops the current buffer's mark stack, returning the mark. If the stack - becomes empty, a mark is push on the stack pointing to the buffer's start. - This always makes the current region not active." - (let* ((ring (value buffer-mark-ring)) - (mark (ring-pop ring))) - (deactivate-region) - (if (zerop (ring-length ring)) - (ring-push (copy-mark - (buffer-start-mark (current-buffer)) :right-inserting) - ring)) - mark)) - -(defun push-buffer-mark (mark &optional (activate-region nil)) - "Pushes mark into buffer's mark ring, ensuring that the mark is in the right - buffer and :right-inserting. Optionally, the current region is made active. - This never deactivates the current region. Mark is returned." - (cond ((eq (line-buffer (mark-line mark)) (current-buffer)) - (setf (mark-kind mark) :right-inserting) - (ring-push mark (value buffer-mark-ring))) - (t (error "Mark not in the current buffer."))) - (when activate-region (activate-region)) - mark) - -(defcommand "Set/Pop Mark" (p) - "Set or Pop the mark ring. - With no C-U's, pushes point as the mark, activating the current region. - With one C-U's, pops the mark into point, de-activating the current region. - With two C-U's, pops the mark and throws it away, de-activating the current - region." - "Set or Pop the mark ring." - (cond ((not p) - (push-buffer-mark (copy-mark (current-point)) t) - (when (interactive) - (message "Mark pushed."))) - ((= p (value universal-argument-default)) - (pop-and-goto-mark-command nil)) - ((= p (expt (value universal-argument-default) 2)) - (delete-mark (pop-buffer-mark))) - (t (editor-error)))) - -(defcommand "Pop and Goto Mark" (p) - "Pop mark into point, de-activating the current region." - "Pop mark into point." - (declare (ignore p)) - (let ((mark (pop-buffer-mark))) - (move-mark (current-point) mark) - (delete-mark mark))) - -(defcommand "Pop Mark" (p) - "Pop mark and throw it away, de-activating the current region." - "Pop mark and throw it away." - (declare (ignore p)) - (delete-mark (pop-buffer-mark))) - -(defcommand "Exchange Point and Mark" (p) - "Swap the positions of the point and the mark." - "Swap the positions of the point and the mark." - (declare (ignore p)) - (let ((point (current-point)) - (mark (current-mark))) - (with-mark ((temp point)) - (move-mark point mark) - (move-mark mark temp)))) - -(defcommand "Mark Whole Buffer" (p) - "Set the region around the whole buffer, activating the region. - Pushes the point on the mark ring first, so two pops get it back. - With prefix argument, put mark at beginning and point at end." - "Put point at beginning and part at end of current buffer. - If P, do it the other way around." - (let* ((region (buffer-region (current-buffer))) - (start (region-start region)) - (end (region-end region)) - (point (current-point))) - (push-buffer-mark (copy-mark point)) - (cond (p (push-buffer-mark (copy-mark start) t) - (move-mark point end)) - (t (push-buffer-mark (copy-mark end) t) - (move-mark point start))))) - - - -;;;; KILL-REGION and KILL-CHARACTERS primitives. - -(proclaim '(special *delete-char-region*)) - -;;; KILL-REGION first checks for any characters that may need to be added to -;;; the region. If there are some, we possibly push a region onto *kill-ring*, -;;; and we use the top of *kill-ring*. If there are no characters to deal -;;; with, then we make sure the ring isn't empty; if it is, just push our -;;; region. If there is some region in *kill-ring*, then see if the last -;;; command type was a region kill. Otherwise, just push the region. -;;; -(defun kill-region (region current-type) - "Kills the region saving it in *kill-ring*. Current-type is either - :kill-forward or :kill-backward. When LAST-COMMAND-TYPE is one of these, - region is appended or prepended, respectively, to the top of *kill-ring*. - The killing of the region is undo-able with \"Undo\". LAST-COMMAND-TYPE - is set to current-type. This interacts with KILL-CHARACTERS." - (let ((last-type (last-command-type)) - (insert-mark (copy-mark (region-start region) :left-inserting))) - (cond ((or (eq last-type :char-kill-forward) - (eq last-type :char-kill-backward)) - (when *delete-char-region* - (ring-push *delete-char-region* *kill-ring*) - (setf *delete-char-region* nil)) - (setf region (kill-region-top-of-ring region current-type))) - ((zerop (ring-length *kill-ring*)) - (setf region (delete-and-save-region region)) - (ring-push region *kill-ring*)) - ((or (eq last-type :kill-forward) (eq last-type :kill-backward)) - (setf region (kill-region-top-of-ring region current-type))) - (t - (setf region (delete-and-save-region region)) - (ring-push region *kill-ring*))) - (make-region-undo :insert "kill" (copy-region region) insert-mark) - (setf (last-command-type) current-type))) - -(defun kill-region-top-of-ring (region current-type) - (let ((r (ring-ref *kill-ring* 0))) - (ninsert-region (if (eq current-type :kill-forward) - (region-end r) - (region-start r)) - (delete-and-save-region region)) - r)) - -(defhvar "Character Deletion Threshold" - "When this many characters are deleted contiguously via KILL-CHARACTERS, - they are saved on the kill ring -- for example, \"Delete Next Character\", - \"Delete Previous Character\", or \"Delete Previous Character Expanding - Tabs\"." - :value 5) - -(defvar *delete-char-region* nil) -(defvar *delete-char-count* 0) - -;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET. -;;; If the last command type was a region kill, we just use the top region -;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is -;;; over the threshold. We don't call KILL-REGION in this case to save making -;;; undo's -- no good reason. If we were just called, then increment our -;;; global counter. Otherwise, make an empty region to keep KILL-CHAR-REGION -;;; happy and increment the global counter. -;;; -(defun kill-characters (mark count) - "Kills count characters after mark if positive, before mark if negative. - If called multiple times contiguously such that the sum of the count values - equals \"Character Deletion Threshold\", then the characters are saved on - *kill-ring*. This relies on setting LAST-COMMAND-TYPE, and it interacts - with KILL-REGION. If there are not count characters in the appropriate - direction, no characters are deleted, and nil is returned; otherwise, mark - is returned." - (if (zerop count) - mark - (with-mark ((temp mark :left-inserting)) - (if (character-offset temp count) - (let ((current-type (if (plusp count) - :char-kill-forward - :char-kill-backward)) - (last-type (last-command-type)) - (del-region (if (mark< temp mark) - (region temp mark) - (region mark temp)))) - (cond ((or (eq last-type :kill-forward) - (eq last-type :kill-backward)) - (setf *delete-char-count* - (value character-deletion-threshold)) - (setf *delete-char-region* nil)) - ((or (eq last-type :char-kill-backward) - (eq last-type :char-kill-forward)) - (incf *delete-char-count* (abs count))) - (t - (setf *delete-char-region* (make-empty-region)) - (setf *delete-char-count* (abs count)))) - (kill-char-region del-region current-type) - mark) - nil)))) - -(defun kill-char-region (region current-type) - (let ((deleted-region (delete-and-save-region region))) - (cond ((< *delete-char-count* (value character-deletion-threshold)) - (ninsert-region (if (eq current-type :char-kill-forward) - (region-end *delete-char-region*) - (region-start *delete-char-region*)) - deleted-region) - (setf (last-command-type) current-type)) - (t - (when *delete-char-region* - (ring-push *delete-char-region* *kill-ring*) - (setf *delete-char-region* nil)) - (let ((r (ring-ref *kill-ring* 0))) - (ninsert-region (if (eq current-type :char-kill-forward) - (region-end r) - (region-start r)) - deleted-region)) - (setf (last-command-type) - (if (eq current-type :char-kill-forward) - :kill-forward - :kill-backward)))))) - - - -;;;; Commands. - -(defcommand "Kill Region" (p) - "Kill the region, pushing on the kill ring. - If the region is not active nor the last command a yank, signal an error." - "Kill the region, pushing on the kill ring." - (declare (ignore p)) - (kill-region (current-region) - (if (mark< (current-mark) (current-point)) - :kill-backward - :kill-forward))) - -(defcommand "Save Region" (p) - "Insert the region into the kill ring. - If the region is not active nor the last command a yank, signal an error." - "Insert the region into the kill ring." - (declare (ignore p)) - (ring-push (copy-region (current-region)) *kill-ring*)) - -(defcommand "Kill Next Word" (p) - "Kill a word at the point. - With prefix argument delete that many words. The text killed is - appended to the text currently at the top of the kill ring if it was - next to the text being killed." - "Kill p words at the point" - (let ((point (current-point)) - (num (or p 1))) - (with-mark ((mark point :temporary)) - (if (word-offset mark num) - (if (minusp num) - (kill-region (region mark point) :kill-backward) - (kill-region (region point mark) :kill-forward)) - (editor-error))))) - -(defcommand "Kill Previous Word" (p) - "Kill a word before the point. - With prefix argument kill that many words before the point. The text - being killed is appended to the text currently at the top of the kill - ring if it was next to the text being killed." - "Kill p words before the point" - (kill-next-word-command (- (or p 1)))) - - -(defcommand "Kill Line" (p) - "Kills the characters to the end of the current line. - If the line is empty then the line is deleted. With prefix argument, - deletes that many lines past the point (or before if the prefix is negative)." - "Kills p lines after the point." - (let* ((point (current-point)) - (line (mark-line point))) - (with-mark ((mark point)) - (cond - (p - (when (and (/= (mark-charpos point) 0) (minusp p)) - (incf p)) - (unless (line-offset mark p 0) - (if (plusp p) - (kill-region (region point (buffer-end mark)) :kill-forward) - (kill-region (region (buffer-start mark) point) :kill-backward)) - (editor-error)) - (if (plusp p) - (kill-region (region point mark) :kill-forward) - (kill-region (region mark point) :kill-backward))) - (t - (cond ((not (blank-after-p mark)) - (line-end mark)) - ((line-next line) - (line-start mark (line-next line))) - ((not (end-line-p mark)) - (line-end mark)) - (t - (editor-error))) - (kill-region (region point mark) :kill-forward)))))) - -(defcommand "Backward Kill Line" (p) - "Kill from the point to the beginning of the line. - If at the beginning of the line, kill the newline and any trailing space - on the previous line. With prefix argument, call \"Kill Line\" with - the argument negated." - "Kills p lines before the point." - (if p - (kill-line-command (- p)) - (with-mark ((m (current-point))) - (cond ((zerop (mark-charpos m)) - (mark-before m) - (unless (reverse-find-attribute m :space #'zerop) - (buffer-start m))) - (t - (line-start m))) - (kill-region (region m (current-point)) :kill-backward)))) - - -(defcommand "Delete Blank Lines" (p) - "On a blank line, deletes all surrounding blank lines, leaving just - one. On an isolated blank line, deletes that one. On a non-blank line, - deletes all blank following that one." - "Kill blank lines around the point" - (declare (ignore p)) - (let ((point (current-point))) - (with-mark ((beg-mark point :left-inserting) - (end-mark point :right-inserting)) - ;; handle case when the current line is blank - (when (blank-line-p (mark-line point)) - ;; back up to last non-whitespace character - (reverse-find-attribute beg-mark :whitespace #'zerop) - (when (previous-character beg-mark) - ;; that is, we didn't back up to the beginning of the buffer - (unless (same-line-p beg-mark end-mark) - (line-offset beg-mark 1 0))) - ;; if isolated, zap the line else zap the blank ones above - (cond ((same-line-p beg-mark end-mark) - (line-offset end-mark 1 0)) - (t - (line-start end-mark))) - (delete-region (region beg-mark end-mark))) - ;; always delete all blank lines after the current line - (move-mark beg-mark point) - (when (line-offset beg-mark 1 0) - (move-mark end-mark beg-mark) - (find-attribute end-mark :whitespace #'zerop) - (when (next-character end-mark) - ;; that is, we didn't go all the way to the end of the buffer - (line-start end-mark)) - (delete-region (region beg-mark end-mark)))))) - - -(defcommand "Un-Kill" (p) - "Inserts the top item in the kill-ring at the point. - The mark is left mark before the insertion and the point after. With prefix - argument inserts the prefix'th most recent item." - "Inserts the item with index p in the kill ring at the point, leaving - the mark before and the point after." - (let ((idx (1- (or p 1)))) - (cond ((> (ring-length *kill-ring*) idx -1) - (let* ((region (ring-ref *kill-ring* idx)) - (point (current-point)) - (mark (copy-mark point))) - (push-buffer-mark mark) - (insert-region point region) - (make-region-undo :delete "Un-Kill" - (region (copy-mark mark) (copy-mark point)))) - (setf (last-command-type) :unkill)) - (t (editor-error))))) -;;; -(push :unkill *ephemerally-active-command-types*) - -(defcommand "Rotate Kill Ring" (p) - "Replace un-killed text with previously killed text. - Kills the current region, rotates the kill ring, and inserts the new top - item. With prefix argument rotates the kill ring that many times." - "This function will not behave in any reasonable fashion when - called as a lisp function." - (let ((point (current-point)) - (mark (current-mark))) - (cond ((or (not (eq (last-command-type) :unkill)) - (zerop (ring-length *kill-ring*))) - (editor-error)) - (t (delete-region (region mark point)) - (rotate-ring *kill-ring* (or p 1)) - (insert-region point (ring-ref *kill-ring* 0)) - (make-region-undo :delete "Un-Kill" - (region (copy-mark mark) (copy-mark point))) - (setf (last-command-type) :unkill))))) diff --git a/hemlock/line.lisp b/hemlock/line.lisp deleted file mode 100644 index f5eb2e963fd49b1e67322441ce4d6b2d4b173fa0..0000000000000000000000000000000000000000 --- a/hemlock/line.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains definitions for the Line structure, and some -;;; functions and macros to manipulate them. -;;; -;;; This stuff was allowed to become implementation dependant because -;;; you make thousands of lines, so speed is real important. In some -;;; implementations (the Perq for example) it may be desirable to -;;; not actually cons the strings in the line objects until someone -;;; touches them, and just keep a pointer in the line to where the file -;;; is mapped in memory. Such lines are called "buffered". This stuff -;;; links up with the file-reading stuff and the line-image building stuff. -;;; -(in-package 'hemlock-internals) -(export '(line linep line-previous line-next line-plist line-signature)) - -(setf (documentation 'linep 'function) - "Returns true if its argument is a Hemlock line object, Nil otherwise.") -(setf (documentation 'line-previous 'function) - "Return the Hemlock line that precedes this one, or Nil if there is no - previous line.") -(setf (documentation 'line-next 'function) - "Return the Hemlock line that follows this one, or Nil if there is no - next line.") -(setf (documentation 'line-plist 'function) - "Return a line's property list. This may be manipulated with Setf and Getf.") - - -;;;; The line object: - -(defstruct (line (:print-function %print-hline) - (:predicate linep) - (:constructor nil)) - "A Hemlock line object. See Hemlock design document for details." - ;; - ;; Something that represents the contents of the line. This is - ;; guaranteed to change (as compared by EQL) whenver the contents of the - ;; line changes, but might at arbitarary other times. There are - ;; currently about three different cases: - ;; - ;; Normal: - ;; A simple string holding the contents of the line. - ;; - ;; A cached line: - ;; The line is eq to Open-Line, and the actual contents are in the - ;; line cache. The %Chars may be either the original contents or a - ;; negative fixnum. - ;; - ;; A buffered line: - ;; The line hasn't been touched since it was read from a file, and the - ;; actual contents are in some system I/O area. This is indicated by - ;; the Line-Buffered-P slot being true. In buffered lines on the RT, - ;; the %Chars slot contains the system-area-pointer to the beginning - ;; of the characters. - (%chars "") - ;; - ;; Pointers to the next and previous lines in the doubly linked list of - ;; line structures. - previous - next - ;; - ;; A list of all the permanent marks pointing into this line. - (marks ()) - ;; - ;; The buffer to which this line belongs, or a *disembodied-buffer-count* - ;; if the line is not in any buffer. - %buffer - ;; - ;; A non-negative integer (fixnum) that represents the ordering of lines - ;; within continguous range of lines (a buffer or disembuffered region). - ;; The number of the Line-Next is guaranteed to be strictly greater than - ;; our number, and the Line-Previous is guaranteed to be strictly less. - (number 0) - ;; - ;; The line property list, used by user code to annotate the text. - plist - ;; - ;; A slot that indicates whether this line is a buffered line, and if so - ;; contains information about how the text is stored. On the RT, this is - ;; the length of the text pointed to by the Line-%Chars. - #+Buffered-Lines - (buffered-p ())) - -;;; Make Line-Chars the same as Line-%Chars on implementations without -;;; buffered lines. -;;; -#-Buffered-Lines -(defmacro line-chars (x) - `(line-%chars ,x)) - - -;;; If buffered lines are supported, then we create the string -;;; representation for the characters when someone uses Line-Chars. People -;;; who are prepared to handle buffered lines or who just want a signature -;;; for the contents can use Line-%chars directly. -;;; -#+Buffered-Lines -(defmacro line-chars (line) - `(the simple-string (if (line-buffered-p ,line) - (read-buffered-line ,line) - (line-%chars ,line)))) -;;; -#+Buffered-Lines -(defsetf line-chars %set-line-chars) -;;; -#+Buffered-Lines -(defmacro %set-line-chars (line chars) - `(setf (line-%chars ,line) ,chars)) - - -;;; Line-Signature -- Public -;;; -;;; We can just return the Line-%Chars. -;;; -(proclaim '(inline line-signature)) -(defun line-signature (line) - "This function returns an object which serves as a signature for a 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 EQL to any previous value. - Note that the signature may change even when the text hasn't been modified, but - this probably won't happen often." - (line-%chars line)) - - -;;; Fast version of Make-Line does keyword hacking at compile time. -;;; -(defmacro make-line (&key chars previous next marks %buffer number - plist #+Buffered-Lines buffered-p) - `(lisp::%sp-set-vector-subtype - (vector 'line - ,chars - ,previous - ,next - ,marks - ,%buffer - ,number - ,plist - #+Buffered-Lines ,buffered-p) - 1)) - -;;; Return a copy of Line in buffer Buffer with the same chars. We use -;;; this macro where we want to copy a line because it takes care of -;;; the case where the line is buffered. -;;; -(defmacro %copy-line (line &key previous number %buffer) - `(make-line :chars (line-%chars ,line) - :previous ,previous - :number ,number - :%buffer ,%buffer - #+Buffered-Lines :buffered-p - #+Buffered-Lines (line-buffered-p ,line))) - -(defmacro line-length* (line) - "Returns the number of characters on the line, but it's a macro!" - `(cond ((eq ,line open-line) - (+ left-open-pos (- line-cache-length right-open-pos))) - ((line-buffered-p ,line)) - (t - (length (the simple-string (line-%chars ,line)))))) diff --git a/hemlock/linimage.lisp b/hemlock/linimage.lisp deleted file mode 100644 index 504aedfedf406672ed47b6936cf6d43a31bf88bf..0000000000000000000000000000000000000000 --- a/hemlock/linimage.lisp +++ /dev/null @@ -1,508 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; -;;; This file contains functions related to building line images. -;;; -(in-package 'hemlock-internals) - -;;; The code in here is factored out in this way because it is more -;;; or less implementation dependant. The reason this code is -;;; implementation dependant is not because it is not written in -;;; Common Lisp per se, but because it uses this thing called -;;; %SP-Find-Character-With-Attribute to find any characters that -;;; are to be displayed on the line which do not print as themselves. -;;; This permits us to have an arbitrary string or even string-valued -;;; function to as the representation for such a "Funny" character -;;; with minimal penalty for the normal case. This function can be written -;;; in lisp, and is included commented-out below, but if this function -;;; is not real fast then redisplay performance will suffer. -;;; -;;; Theres also code in here that special-cases "Buffered" lines, -;;; which is not exactly Common Lisp, but if you aren't on a perq, -;;; you won't have to worry about it. -;;; -;(defun %sp-find-character-with-attribute (string start end table mask) -; (declare (type (simple-array (mod 256) char-code-max) table)) -; (declare (simple-string string)) -; (declare (fixnum start end)) -; "%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." -; (do ((index start (1+ index))) -; ((= index end) nil) -; (declare (fixnum index)) -; (if (/= (logand (aref table (char-code (elt string index))) mask) 0) -; (return index)))) -; -;(defun %sp-reverse-find-character-with-attribute (string start end table -; mask) -; (declare (type (simple-array (mod 256) char-code-max) table)) -; (declare (simple-string string)) -; (declare (fixnum start end)) -; "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." -; (do ((index (1- end) (1- index))) -; ((< index start) nil) -; (declare (fixnum index)) -; (if (/= (logand (aref table (char-code (elt string index))) mask) 0) -; (return index)))) - -(defconstant winning-char #b01 "Bit for a char that prints normally") -(defconstant losing-char #b10 "Bit for char with funny representation.") -(defvar *losing-character-mask* - (make-array char-code-limit :element-type '(mod 256) - :initial-element winning-char) - "This is a character set used by redisplay to find funny chars.") -(defvar *print-representation-vector* nil - "Redisplay's handle on the :print-representation attribute") - -;;; Do a find-character-with-attribute on the *losing-character-mask*. -(defmacro %fcwa (str start end mask) - `(%sp-find-character-with-attribute - ,str ,start ,end *losing-character-mask* ,mask)) - -;;; Get the print-representation of a character. -(defmacro get-rep (ch) - `(svref *print-representation-vector* (char-code ,ch))) - - - -(proclaim '(special *character-attributes*)) - -;;; %init-line-image -- Internal -;;; -;;; Set up the print-representations for funny chars. We make the -;;; attribute vector by hand and do funny stuff so that chars > 127 -;;; will have a losing print-representation, so redisplay will not -;;; die if you visit a binary file or do something stupid like that. -;;; -(defun %init-line-image () - (defattribute "Print Representation" - "The value of this attribute determines how a character is displayed - on the screen. If the value is a string this string is literally - displayed. If it is a function, then that function is called with - the current X position to get the string to display.") - (setq *print-representation-vector* (make-array char-code-limit)) - (setf (attribute-descriptor-vector - (gethash :print-representation *character-attributes*)) - *print-representation-vector*) - (do ((code syntax-char-code-limit (1+ code)) - (str (make-string 4) (make-string 4))) - ((= code char-code-limit)) - (setf (aref *losing-character-mask* code) losing-char) - (setf (aref *print-representation-vector* code) str) - (setf (schar str 0) #\<) - (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16))) - (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16))) - (setf (schar str 3) #\>)) - - (add-hook ed::character-attribute-hook - #'redis-set-char-attribute-hook-fun) - (do ((i (1- (char-code #\space)) (1- i)) str) - ((minusp i)) - (setq str (make-string 2)) - (setf (elt (the simple-string str) 0) #\^) - (setf (elt (the simple-string str) 1) - (code-char (+ i (char-code #\@)))) - (setf (character-attribute :print-representation (code-char i)) str)) - (setf (character-attribute :print-representation (code-char #o177)) "^?") - (setf (character-attribute :print-representation #\tab) - #'redis-tab-display-fun)) - -;;; redis-set-char-attribute-hook-fun -;;; -;;; Keep track of which characters have funny representations. -;;; -(defun redis-set-char-attribute-hook-fun (attribute char new-value) - (when (eq attribute :print-representation) - (cond - ((simple-string-p new-value) - (if (and (= (length (the simple-string new-value)) 1) - (char= char (elt (the simple-string new-value) 0))) - (setf (aref *losing-character-mask* (char-code char)) winning-char) - (setf (aref *losing-character-mask* (char-code char)) - losing-char))) - ((functionp new-value) - (setf (aref *losing-character-mask* (char-code char)) losing-char)) - (t (error "Bad print representation: ~S" new-value))))) - -;;; redis-tab-display-fun -;;; -;;; This function is initially the :print-representation for tab. -;;; -(defun redis-tab-display-fun (xpos) - (svref '#(" " - " " - " " - " " - " " - " " - " " - " ") - (logand xpos 7))) - - -;;;; The actual line image computing functions. -;;;; - -(eval-when (compile eval) -;;; display-some-chars -- internal -;;; -;;; Put some characters into a window. Characters from src-start -;;; to src-end in src are are put in the window's dis-line's. Lines -;;; are wrapped as necessary. dst is the dis-line-chars of the dis-line -;;; currently being written. Dis-lines is the window's vector of dis-lines. -;;; dis-line is the dis-line currently being written. Line is the index -;;; into dis-lines of the current dis-line. dst-start is the index to -;;; start writing chars at. Height and width are the height and width of the -;;; window. src-start, dst, dst-start, line and dis-line are updated. -;;; Done-P indicates whether there are more characters after this sequence. -;;; -(defmacro display-some-chars (src src-start src-end dst dst-start width done-p) - `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start)))) - (declare (fixnum dst-end)) - (cond - ((>= dst-end ,width) - (cond - ((and ,done-p (= dst-end ,width)) - (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end) - (setq ,dst-start dst-end ,src-start ,src-end)) - (t - (let ((1-width (1- ,width))) - (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width) - (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*) - (setq ,src-start (+ ,src-start (- 1-width ,dst-start))) - (setq ,dst-start nil))))) - (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end) - (setq ,dst-start dst-end ,src-start ,src-end))))) - -;;; These macros are given as args to display-losing-chars to get the -;;; print representation of whatever is in the data vector. -(defmacro string-get-rep (string index) - `(get-rep (schar ,string ,index))) - -(defmacro u-vec-get-rep (u-vec index) - `(svref *print-representation-vector* - (%primitive 8bit-system-ref ,u-vec ,index))) - -;;; display-losing-chars -- Internal -;;; -;;; This macro is called by the compute-line-image functions to -;;; display a group of losing characters. -;;; -(defmacro display-losing-chars (line-chars index end dest xpos width - string underhang access-fun - &optional (done-p `(= ,index ,end))) - `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end)) - str len zero) - (()) - (declare (fixnum last len zero)) - (setq str (,access-fun ,line-chars ,index)) - (unless (simple-string-p str) (setq str (funcall str ,xpos))) - (setq len (strlen str) zero 0) - (incf ,index) - (display-some-chars str zero len ,dest ,xpos ,width ,done-p) - (cond ((not ,xpos) - ;; We wrapped in the middle of a losing char. - (setq ,underhang zero ,string str) - (return nil)) - ((= ,index last) - ;; No more losing chars in this bunch. - (return nil))))) - -(defmacro update-and-punt (dis-line length string underhang end) - `(progn (setf (dis-line-length ,dis-line) ,length) - (return (values ,string ,underhang - (setf (dis-line-end ,dis-line) ,end))))) - -); eval-when (compile eval) - -;;; compute-normal-line-image -- Internal -;;; -;;; Compute the screen representation of Line starting at Start -;;; putting it in Dis-Line beginning at Xpos. Width is the width of the -;;; window we are displaying in. If the line will wrap then we display -;;; as many chars as we can then put in *line-wrap-char*. The values -;;; returned are described in Compute-Line-Image, which tail-recursively -;;; returns them. The length slot in Dis-Line is updated. -;;; -;;; We use the *losing-character-mask* to break the line to be displayed -;;; up into chunks of characters with normal print representation and -;;; those with funny representations. -;;; -(defun compute-normal-line-image (line start dis-line xpos width) - (declare (fixnum start xpos width)) - (do* ((index start) - (line-chars (line-%chars line)) - (end (strlen line-chars)) - (dest (dis-line-chars dis-line)) losing underhang string) - (()) - (declare (fixnum index end losing) - (simple-string line-chars dest)) - (cond - (underhang - (update-and-punt dis-line width string underhang index)) - ((null xpos) - (update-and-punt dis-line width nil 0 index)) - ((= index end) - (update-and-punt dis-line xpos nil nil index))) - (setq losing (%fcwa line-chars index end losing-char)) - (when (null losing) - (display-some-chars line-chars index end dest xpos width t) - (if (or xpos (= index end)) - (update-and-punt dis-line xpos nil nil index) - (update-and-punt dis-line width nil 0 index))) - (display-some-chars line-chars index losing dest xpos width nil) - (cond - ;; Did we wrap? - ((null xpos) - (update-and-punt dis-line width nil 0 index)) - ;; Are we about to cause the line to wrap? If so, wrap before - ;; it's too late. - ((= xpos width) - (setf (char dest (1- width)) *line-wrap-char*) - (update-and-punt dis-line width nil 0 index)) - (t - (display-losing-chars line-chars index end dest xpos width string - underhang string-get-rep))))) - -;;; compute-buffered-line-image -- Internal -;;; -;;; Compute the line image for a "Buffered" line, that is, one whose -;;; chars have not been consed yet. - -(defun compute-buffered-line-image (line start dis-line xpos width) - (declare (fixnum start xpos width)) - (do* ((index start) - (line-chars (line-%chars line)) - (end (line-buffered-p line)) - (dest (dis-line-chars dis-line)) losing underhang string) - (()) - (declare (fixnum index end losing) - (simple-string line-chars dest)) - (cond - (underhang - (update-and-punt dis-line width string underhang index)) - ((null xpos) - (update-and-punt dis-line width nil 0 index)) - ((= index end) - (update-and-punt dis-line xpos nil nil index))) - (setq losing (%fcwa line-chars index end losing-char)) - (when (null losing) - (display-some-chars line-chars index end dest xpos width t) - (if (or xpos (= index end)) - (update-and-punt dis-line xpos nil nil index) - (update-and-punt dis-line width nil 0 index))) - (display-some-chars line-chars index losing dest xpos width nil) - (cond - ;; Did we wrap? - ((null xpos) - (update-and-punt dis-line width nil 0 index)) - ;; Are we about to cause the line to wrap? If so, wrap before - ;; it's too late. - ((= xpos width) - (setf (char dest (1- width)) *line-wrap-char*) - (update-and-punt dis-line width nil 0 index)) - (t - (display-losing-chars line-chars index end dest xpos width string - underhang u-vec-get-rep))))) - -;;; compute-cached-line-image -- Internal -;;; -;;; Like compute-normal-line-image, only works on the cached line. -;;; -(defun compute-cached-line-image (index dis-line xpos width) - (declare (fixnum start xpos width)) - (prog ((gap (- right-open-pos left-open-pos)) - (dest (dis-line-chars dis-line)) - (done-p (= right-open-pos line-cache-length)) - losing string underhang) - (declare (fixnum index gap losing) (simple-string dest)) - LEFT-LOOP - (cond - (underhang - (update-and-punt dis-line width string underhang index)) - ((null xpos) - (update-and-punt dis-line width nil 0 index)) - ((>= index left-open-pos) - (go RIGHT-START))) - (setq losing (%fcwa open-chars index left-open-pos losing-char)) - (cond - (losing - (display-some-chars open-chars index losing dest xpos width nil) - ;; If we we didn't wrap then display some losers... - (if xpos - (display-losing-chars open-chars index left-open-pos dest xpos - width string underhang string-get-rep - (and done-p (= index left-open-pos))) - (update-and-punt dis-line width nil 0 index))) - (t - (display-some-chars open-chars index left-open-pos dest xpos width done-p))) - (go LEFT-LOOP) - - RIGHT-START - (setq index (+ index gap)) - RIGHT-LOOP - (cond - (underhang - (update-and-punt dis-line width string underhang (- index gap))) - ((null xpos) - (update-and-punt dis-line width nil 0 (- index gap))) - ((= index line-cache-length) - (update-and-punt dis-line xpos nil nil (- index gap)))) - (setq losing (%fcwa open-chars index line-cache-length losing-char)) - (cond - (losing - (display-some-chars open-chars index losing dest xpos width nil) - (cond - ;; Did we wrap? - ((null xpos) - (update-and-punt dis-line width nil 0 (- index gap))) - (t - (display-losing-chars open-chars index line-cache-length dest xpos - width string underhang string-get-rep)))) - (t - (display-some-chars open-chars index line-cache-length dest xpos width t))) - (go RIGHT-LOOP))) - -(defun make-some-font-changes () - (do ((res nil (make-font-change res)) - (i 42 (1- i))) - ((zerop i) res))) - -(defvar *free-font-changes* (make-some-font-changes) - "Font-Change structures that nobody's using at the moment.") - -(defmacro alloc-font-change (x font mark) - `(progn - (unless *free-font-changes* - (setq *free-font-changes* (make-some-font-changes))) - (let ((new-fc *free-font-changes*)) - (setq *free-font-changes* (font-change-next new-fc)) - (setf (font-change-x new-fc) ,x - (font-change-font new-fc) ,font - (font-change-next new-fc) nil - (font-change-mark new-fc) ,mark) - new-fc))) - -;;; -;;; compute-line-image -- Internal -;;; -;;; This function builds a full line image from some characters in -;;; a line and from some characters which may be left over from the previous -;;; line. -;;; -;;; Parameters: -;;; String - This is the string which contains the characters left over -;;; from the previous line. This is NIL if there are none. -;;; Underhang - Characters from here to the end of String are put at the -;;; beginning of the line image. -;;; Line - This is the line to display characters from. -;;; Offset - This is the index of the first character to display in Line. -;;; Dis-Line - This is the dis-line to put the line-image in. The only -;;; slots affected are the chars and the length. -;;; Width - This is the width of the field to display in. -;;; -;;; Three values are returned: -;;; 1) The new overhang string, if none this is NIL. -;;; 2) The new underhang, if this is NIL then the entire line was -;;; displayed. If the entire line was not displayed, but there was no -;;; underhang, then this is 0. -;;; 3) The index in line after the last character displayed. -;;; -(defun compute-line-image (string underhang line offset dis-line width) - ;; - ;; Release any old font-changes. - (let ((changes (dis-line-font-changes dis-line))) - (when changes - (do ((prev changes current) - (current (font-change-next changes) - (font-change-next current))) - ((null current) - (setf (dis-line-font-changes dis-line) nil) - (shiftf (font-change-next prev) *free-font-changes* changes)) - (setf (font-change-mark current) nil)))) - ;; - ;; If the line has any Font-Marks, add Font-Changes for them. - (let ((marks (line-marks line))) - (when (dolist (m marks nil) - (when (fast-font-mark-p m) (return t))) - (let ((prev nil)) - ;; - ;; Find the last Font-Mark with charpos less than Offset. If there is - ;; such a Font-Mark, then there is a font-change to this font at X = 0. - (let ((max -1) - (max-mark nil)) - (dolist (m marks) - (when (fast-font-mark-p m) - (let ((charpos (mark-charpos m))) - (when (and (< charpos offset) (> charpos max)) - (setq max charpos max-mark m))))) - (when max-mark - (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark)) - (setf (dis-line-font-changes dis-line) prev))) - ;; - ;; Repeatedly scan through marks, adding a font-change for the - ;; smallest Font-Mark with a charpos greater than Bound, until - ;; we find no such mark. - (do ((bound (1- offset) min) - (min most-positive-fixnum most-positive-fixnum) - (min-mark nil nil)) - (()) - (dolist (m marks) - (when (fast-font-mark-p m) - (let ((charpos (mark-charpos m))) - (when (and (> charpos bound) (< charpos min)) - (setq min charpos min-mark m))))) - (unless min-mark (return nil)) - (let ((len (if (eq line open-line) - (cached-real-line-length line 10000 offset min) - (real-line-length line 10000 offset min)))) - (when (< len width) - (let ((new (alloc-font-change - (+ len - (if string - (- (length (the simple-string string)) underhang) - 0)) - (font-mark-font min-mark) - min-mark))) - (if prev - (setf (font-change-next prev) new) - (setf (dis-line-font-changes dis-line) new)) - (setq prev new)))))))) - ;; - ;; Recompute the line image. - (cond - (string - (let ((len (strlen string)) - (chars (dis-line-chars dis-line)) - (xpos 0)) - (declare (fixnum xpos len) (simple-string chars)) - (display-some-chars string underhang len chars xpos width nil) - (cond - ((null xpos) - (values string underhang offset)) - ((eq line open-line) - (compute-cached-line-image offset dis-line xpos width)) - #+Buffered-Lines - ((line-buffered-p line) - (compute-buffered-line-image line offset dis-line xpos width)) - (t - (compute-normal-line-image line offset dis-line xpos width))))) - ((eq line open-line) - (compute-cached-line-image offset dis-line 0 width)) - #+Buffered-Lines - ((line-buffered-p line) - (compute-buffered-line-image line offset dis-line 0 width)) - (t - (compute-normal-line-image line offset dis-line 0 width)))) diff --git a/hemlock/lisp-lib.lisp b/hemlock/lisp-lib.lisp deleted file mode 100644 index b33b42d0ea768637b1fb4862bcb257329c1405a8..0000000000000000000000000000000000000000 --- a/hemlock/lisp-lib.lisp +++ /dev/null @@ -1,180 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains code to peruse the CMU Common Lisp library of hacks. -;;; -;;; Written by Blaine Burks. -;;; - -(in-package "HEMLOCK") - - -(defmode "Lisp-Lib" :major-p t) - -;;; The library should be in *lisp-library-directory* - -(defvar *lisp-library-directory* "/afs/cs.cmu.edu/project/clisp/library/") - -(defvar *selected-library-buffer* nil) - - -;;;; Commands. - -(defcommand "Lisp Library" (p) - "Goto buffer in 'Lisp-Lib' mode, creating one if necessary." - "Goto buffer in 'Lisp-Lib' mode, creating one if necessary." - (declare (ignore p)) - (when (not (and *selected-library-buffer* - (member *selected-library-buffer* *buffer-list*))) - (when (getstring "Lisp Library" *buffer-names*) - (editor-error "There is already a buffer named \"Lisp Library\".")) - (setf *selected-library-buffer* - (make-buffer "Lisp Library" :modes '("Lisp-Lib"))) - (message "Groveling library ...") - (let ((lib-directory (directory *lisp-library-directory*)) - (lib-entries ())) - (with-output-to-mark (s (buffer-point *selected-library-buffer*)) - (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 (directoryp lib-spec) - (probe-file (merge-pathnames - (make-pathname :type "catalog") - raw-pathname))) - (push raw-pathname lib-entries) - (format s "~d~%" last))))) - (defhvar "Library Entries" - "Holds a list of library entries for the 'Lisp Library' buffer" - :buffer *selected-library-buffer* - :value (coerce (nreverse lib-entries) 'simple-vector)))) - (setf (buffer-writable *selected-library-buffer*) nil) - (setf (buffer-modified *selected-library-buffer*) nil) - (change-to-buffer *selected-library-buffer*) - (buffer-start (current-point))) - -(defcommand "Describe Pointer Library Entry" (p) - "Finds the file that describes the lisp library entry indicated by the - pointer." - "Finds the file that describes the lisp library entry indicated by the - pointer." - (declare (ignore p)) - (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) - (editor-error "Not in a Lisp Library buffer.")) - (describe-library-entry (array-element-from-pointer-pos - (value library-entries) "No entry on current line"))) - -(defcommand "Describe Library Entry" (p) - "Find the file that describes the lisp library entry on the current line." - "Find the file that describes the lisp library entry on the current line." - (declare (ignore p)) - (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) - (editor-error "Not in a Lisp Library buffer.")) - (describe-library-entry (array-element-from-mark (current-point) - (value library-entries) "No entry on current line"))) - -(defun describe-library-entry (pathname) - (let ((lisp-buf (current-buffer)) - (buffer (view-file-command - nil - (merge-pathnames (make-pathname :type "catalog") pathname)))) - (push #'(lambda (buffer) - (declare (ignore buffer)) - (setf lisp-buf nil)) - (buffer-delete-hook lisp-buf)) - (setf (variable-value 'view-return-function :buffer buffer) - #'(lambda () (if lisp-buf - (change-to-buffer lisp-buf) - (lisp-library-command nil)))))) - -(defcommand "Load Library Entry" (p) - "Loads the current library entry into the current slave." - "Loads the current library entry into the current slave." - (declare (ignore p)) - (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) - (editor-error "Not in a Lisp Library buffer.")) - (string-eval (format nil "(load ~S)" - (namestring (library-entry-load-file nil))))) - -(defcommand "Load Pointer Library Entry" (p) - "Loads the library entry indicated by the mouse into the current slave." - "Loads the library entry indicated by the mouse into the current slave." - (declare (ignore p)) - (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) - (editor-error "Not in a Lisp Library buffer.")) - (string-eval (format nil "(load ~S)" - (namestring (library-entry-load-file t))))) - -(defcommand "Editor Load Library Entry" (p) - "Loads the current library entry into the editor Lisp." - "Loads the current library entry into the editor Lisp." - (declare (ignore p)) - (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) - (editor-error "Not in a Lisp Library buffer.")) - (in-lisp (load (library-entry-load-file nil)))) - -(defcommand "Editor Load Pointer Library Entry" (p) - "Loads the library entry indicated by the mouse into the editor Lisp." - "Loads the library entry indicated by the mouse into the editor Lisp." - (declare (ignore p)) - (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) - (editor-error "Not in a Lisp Library buffer.")) - (in-lisp (load (library-entry-load-file t)))) - -;;; LIBRARY-ENTRY-LOAD-FILE uses the mouse's position or the current point, -;;; depending on pointerp, to return a file that will load that library entry. -;;; -(defun library-entry-load-file (pointerp) - (let* ((lib-entries (value library-entries)) - (error-msg "No entry on current-line") - (base-name (if pointerp - (array-element-from-pointer-pos lib-entries error-msg) - (array-element-from-mark (current-point) lib-entries - error-msg))) - (parts (pathname-directory base-name)) - (load-name (concatenate 'simple-string - "load-" (svref parts (1- (length parts))))) - (load-pathname (merge-pathnames load-name base-name)) - (file-to-load - (or (probe-file (merge-pathnames (make-pathname :type "fasl") - load-pathname)) - (probe-file (merge-pathnames (make-pathname :type "lisp") - load-pathname)) - (probe-file (merge-pathnames (make-pathname :type "fasl") - base-name)) - (probe-file (merge-pathnames (make-pathname :type "lisp") - base-name))))) - (unless file-to-load (editor-error "You'll have to load it yourself.")) - file-to-load)) - -(defcommand "Exit Lisp Library" (p) - "Exit Lisp-Lib Mode, deleting the buffer when possible." - "Exit Lisp-Lib Mode, deleting the buffer when possible." - (declare (ignore p)) - (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) - (editor-error "Not in a Lisp Library buffer.")) - (delete-buffer-if-possible (getstring "Lisp Library" *buffer-names*))) - -(defcommand "Lisp Library Help" (p) - "Show this help." - "Show this help." - (declare (ignore p)) - (describe-mode-command nil "Lisp-Lib")) - - -;;;; Utilities - -(defun array-element-from-pointer-pos (vector &optional - (error-msg "Invalid line.")) - (multiple-value-bind (x y window) (last-key-event-cursorpos) - (declare (ignore x window)) - (when (>= y (length vector)) - (editor-error error-msg)) - (svref vector y))) diff --git a/hemlock/lispbuf.lisp b/hemlock/lispbuf.lisp deleted file mode 100644 index 3def78bff75313afcc7b4d54ba4ca71c4b7785ed..0000000000000000000000000000000000000000 --- a/hemlock/lispbuf.lisp +++ /dev/null @@ -1,766 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Stuff to do a little lisp hacking in the editor's Lisp environment. -;;; - -(in-package "HEMLOCK") - - -(defmacro in-lisp (&body body) - "Evaluates body inside HANDLE-LISP-ERRORS. *package* is bound to the package - named by \"Current Package\" if it is non-nil." - (let ((name (gensym)) (package (gensym))) - `(handle-lisp-errors - (let* ((,name (value current-package)) - (,package (and ,name (find-package ,name)))) - (progv (if ,package '(*package*)) (if ,package (list ,package)) - ,@body))))) - - -(define-file-option "Package" (buffer value) - (defhvar "Current Package" - "The package used for evaluation of Lisp in this buffer." - :buffer buffer - :value - (let* ((eof (list nil)) - (thing (read-from-string value nil eof))) - (when (eq thing eof) (error "Bad package file option value.")) - (cond - ((stringp thing) - thing) - ((symbolp thing) - (symbol-name thing)) - ((and (characterp thing) (string-char-p thing)) - (string thing)) - (t - (message - "Ignoring \"package\" file option -- cannot convert to a string.")))))) - - -;;;; Eval Mode Interaction. - -(proclaim '(special * ** *** - + ++ +++ / // /// *prompt*)) - -(defun setup-eval-mode (buffer) - (let ((point (buffer-point buffer))) - (setf (buffer-minor-mode buffer "Eval") t) - (setf (buffer-minor-mode buffer "Editor") t) - (setf (buffer-major-mode buffer) "Lisp") - (buffer-end point) - (defhvar "Current Package" - "This variable holds the name of the package currently used for Lisp - evaluation and compilation. If it is Nil, the value of *Package* is used - instead." - :value nil - :buffer buffer) - (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer) - (defhvar "Buffer Input Mark" - "Mark used for Eval Mode input." - :buffer buffer - :value (copy-mark point :right-inserting)) - (defhvar "Eval Output Stream" - "Output stream used for Eval Mode output in this buffer." - :buffer buffer - :value (make-hemlock-output-stream point)) - (defhvar "Interactive History" - "A ring of the regions input to an interactive mode (Eval or Typescript)." - :buffer buffer - :value (make-ring (value interactive-history-length))) - (defhvar "Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0) - (defhvar "Searching Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0)) - (let ((*standard-output* - (variable-value 'eval-output-stream :buffer buffer))) - (fresh-line) - (princ (if (functionp *prompt*) - (funcall *prompt*) - *prompt*))) - (move-mark (variable-value 'buffer-input-mark :buffer buffer) point))) - -(defmode "Eval" :major-p nil :setup-function #'setup-eval-mode) - -(defun eval-mode-lisp-mode-hook (buffer on) - "Turn on Lisp mode when we go into Eval Mode." - (when on - (setf (buffer-major-mode buffer) "Lisp"))) -;;; -(add-hook eval-mode-hook 'eval-mode-lisp-mode-hook) - -(defhvar "Editor Definition Info" - "When this is non-nil, the editor Lisp is used to determine definition - editing information; otherwise, the slave Lisp is used." - :value t - :mode "Eval") - - -(defvar *selected-eval-buffer* nil) - -(defcommand "Select Eval Buffer" (p) - "Goto buffer in \"Eval\" mode, creating one if necessary." - "Goto buffer in \"Eval\" mode, creating one if necessary." - (declare (ignore p)) - (unless *selected-eval-buffer* - (when (getstring "Eval" *buffer-names*) - (editor-error "There is already a buffer named \"Eval\"!")) - (setf *selected-eval-buffer* - (make-buffer "Eval" - :delete-hook - (list #'(lambda (buf) - (declare (ignore buf)) - (setf *selected-eval-buffer* nil))))) - (setf (buffer-minor-mode *selected-eval-buffer* "Eval") t)) - (change-to-buffer *selected-eval-buffer*)) - - -(defvar lispbuf-eof '(nil)) - -(defhvar "Unwedge Interactive Input Confirm" - "When set (the default), trying to confirm interactive input when the - point is not after the input mark causes Hemlock to ask the user if he - needs to be unwedged. When not set, an editor error is signaled - informing the user that the point is before the input mark." - :value t) - -(defun unwedge-eval-buffer () - (abort-eval-input-command nil)) - -(defhvar "Unwedge Interactive Input Fun" - "Function to call when input is confirmed, but the point is not past the - input mark." - :value #'unwedge-eval-buffer - :mode "Eval") - -(defhvar "Unwedge Interactive Input String" - "String to add to \"Point not past input mark. \" explaining what will - happen if the the user chooses to be unwedged." - :value "Prompt again at the end of the buffer? " - :mode "Eval") - -(defcommand "Confirm Eval Input" (p) - "Evaluate Eval Mode input between point and last prompt." - "Evaluate Eval Mode input between point and last prompt." - (declare (ignore p)) - (let ((input-region (get-interactive-input))) - (when input-region - (let* ((output (value eval-output-stream)) - (*standard-output* output) - (*error-output* output) - (*trace-output* output)) - (fresh-line) - (in-lisp - ;; Copy the region to keep the output and input streams from interacting - ;; since input-region is made of permanent marks into the buffer. - (with-input-from-region (stream (copy-region input-region)) - (loop - (let ((form (read stream nil lispbuf-eof))) - (when (eq form lispbuf-eof) - ;; Move the buffer's input mark to the end of the buffer. - (move-mark (region-start input-region) - (region-end input-region)) - (return)) - (setq +++ ++ ++ + + - - form) - (let ((this-eval (multiple-value-list (eval form)))) - (fresh-line) - (dolist (x this-eval) (prin1 x) (terpri)) - (princ (if (functionp *prompt*) - (funcall *prompt*) - *prompt*)) - (setq /// // // / / this-eval) - (setq *** ** ** * * (car this-eval))))))))))) - -(defcommand "Abort Eval Input" (p) - "Move to the end of the buffer and prompt." - "Move to the end of the buffer and prompt." - (declare (ignore p)) - (let ((point (current-point))) - (buffer-end point) - (insert-character point #\newline) - (insert-string point "Aborted.") - (insert-character point #\newline) - (insert-string point - (if (functionp *prompt*) - (funcall *prompt*) - *prompt*)) - (move-mark (value buffer-input-mark) point))) - - - -;;;; General interactive commands used in eval and typescript buffers. - -(defun get-interactive-input () - "Tries to return a region. When the point is not past the input mark, and - the user has \"Unwedge Interactive Input Confirm\" set, the buffer is - optionally fixed up, and nil is returned. Otherwise, an editor error is - signalled. When a region is returned, the start is the current buffer's - input mark, and the end is the current point moved to the end of the buffer." - (let ((point (current-point)) - (mark (value buffer-input-mark))) - (cond - ((mark>= point mark) - (buffer-end point) - (let* ((input-region (region mark point)) - (string (region-to-string input-region)) - (ring (value interactive-history))) - (when (and (or (zerop (ring-length ring)) - (string/= string (region-to-string (ring-ref ring 0)))) - (> (length string) (value minimum-interactive-input-length))) - (ring-push (copy-region input-region) ring)) - input-region)) - ((value unwedge-interactive-input-confirm) - (beep) - (when (prompt-for-y-or-n - :prompt (concatenate 'simple-string - "Point not past input mark. " - (value unwedge-interactive-input-string)) - :must-exist t :default t :default-string "yes") - (funcall (value unwedge-interactive-input-fun)) - (message "Unwedged.")) - nil) - (t - (editor-error "Point not past input mark."))))) - -(defhvar "Interactive History Length" - "This is the length used for the history ring in interactive buffers. - It must be set before turning on the mode." - :value 10) - -(defhvar "Minimum Interactive Input Length" - "When the number of characters in an interactive buffer exceeds this value, - it is pushed onto the interactive history, otherwise it is lost forever." - :value 2) - - -(defvar *previous-input-search-string* "ignore") - -(defvar *previous-input-search-pattern* - ;; Give it a bogus string since you can't give it the empty string. - (new-search-pattern :string-insensitive :forward "ignore")) - -(defun get-previous-input-search-pattern (string) - (if (string= *previous-input-search-string* string) - *previous-input-search-pattern* - (new-search-pattern :string-insensitive :forward - (setf *previous-input-search-string* string) - *previous-input-search-pattern*))) - -(defcommand "Search Previous Interactive Input" (p) - "Search backward through the interactive history using the current input as - a search string. Consecutive invocations repeat the previous search." - "Search backward through the interactive history using the current input as - a search string. Consecutive invocations repeat the previous search." - (declare (ignore p)) - (let* ((mark (value buffer-input-mark)) - (ring (value interactive-history)) - (point (current-point)) - (just-invoked (eq (last-command-type) :searching-interactive-input))) - (when (mark<= point mark) - (editor-error "Point not past input mark.")) - (when (zerop (ring-length ring)) - (editor-error "No previous input in this buffer.")) - (unless just-invoked - (get-previous-input-search-pattern (region-to-string (region mark point)))) - (let ((found-it (find-previous-input ring just-invoked))) - (unless found-it - (editor-error "Couldn't find ~a." *previous-input-search-string*)) - (delete-region (region mark point)) - (insert-region point (ring-ref ring found-it)) - (setf (value searching-interactive-pointer) found-it)) - (setf (last-command-type) :searching-interactive-input))) - -(defun find-previous-input (ring againp) - (let ((ring-length (ring-length ring)) - (base (if againp - (+ (value searching-interactive-pointer) 1) - 0))) - (loop - (when (= base ring-length) - (if againp - (setf base 0) - (return nil))) - (with-mark ((m (region-start (ring-ref ring base)))) - (when (find-pattern m *previous-input-search-pattern*) - (return base))) - (incf base)))) - -(defcommand "Previous Interactive Input" (p) - "Insert the previous input in an interactive mode (Eval or Typescript). - If repeated, keep rotating the history. With prefix argument, rotate - that many times." - "Pop the *interactive-history* at the point." - (let* ((point (current-point)) - (mark (value buffer-input-mark)) - (ring (value interactive-history)) - (length (ring-length ring)) - (p (or p 1))) - (declare (simple-string current)) - (when (or (mark< point mark) (zerop length)) (editor-error)) - (cond - ((eq (last-command-type) :interactive-history) - (let ((base (mod (+ (value interactive-pointer) p) length))) - (delete-region (region mark point)) - (insert-region point (ring-ref ring base)) - (setf (value interactive-pointer) base))) - (t - (let ((base (mod (if (minusp p) p (1- p)) length)) - (region (delete-and-save-region (region mark point)))) - (insert-region point (ring-ref ring base)) - (when (mark/= (region-start region) (region-end region)) - (ring-push region ring) - (incf base)) - (setf (value interactive-pointer) base))))) - (setf (last-command-type) :interactive-history)) - -(defcommand "Next Interactive Input" (p) - "Rotate the interactive history backwards. The region is left around the - inserted text. With prefix argument, rotate that many times." - "Call previous-interactive-input-command with negated arg." - (previous-interactive-input-command (- (or p 1)))) - -(defcommand "Kill Interactive Input" (p) - "Kill any input to an interactive mode (Eval or Typescript)." - "Kill any input to an interactive mode (Eval or Typescript)." - (declare (ignore p)) - (let ((point (buffer-point (current-buffer))) - (mark (value buffer-input-mark))) - (when (mark< point mark) (editor-error)) - (kill-region (region mark point) :kill-backward))) - -(defcommand "Interactive Beginning of Line" (p) - "If on line with current prompt, go to after it, otherwise do what - \"Beginning of Line\" always does." - "Go to after prompt when on prompt line." - (let ((mark (value buffer-input-mark)) - (point (current-point))) - (if (and (same-line-p point mark) (or (not p) (= p 1))) - (move-mark point mark) - (beginning-of-line-command p)))) - -(defcommand "Reenter Interactive Input" (p) - "Copies the form to the left of point to be after the interactive buffer's - input mark. When the current region is active, it is copied instead." - "Copies the form to the left of point to be after the interactive buffer's - input mark. When the current region is active, it is copied instead." - (declare (ignore p)) - (unless (hemlock-bound-p 'buffer-input-mark) - (editor-error "Not in an interactive buffer.")) - (let ((point (current-point))) - (let ((region (if (region-active-p) - ;; Copy this, so moving point doesn't affect the region. - (copy-region (current-region)) - (with-mark ((start point) - (end point)) - (pre-command-parse-check start) - (unless (form-offset start -1) - (editor-error "Not after complete form.")) - (region (copy-mark start) (copy-mark end)))))) - (buffer-end point) - (push-buffer-mark (copy-mark point)) - (insert-region point region) - (setf (last-command-type) :ephemerally-active)))) - - - -;;; Other stuff. - -(defmode "Editor") - -(defcommand "Editor Mode" (p) - "Turn on \"Editor\" mode in the current buffer. If it is already on, turn it - off. When in editor mode, most lisp compilation and evaluation commands - manipulate the editor process instead of the current eval server." - "Toggle \"Editor\" mode in the current buffer." - (declare (ignore p)) - (setf (buffer-minor-mode (current-buffer) "Editor") - (not (buffer-minor-mode (current-buffer) "Editor")))) - -(define-file-option "Editor" (buffer value) - (declare (ignore value)) - (setf (buffer-minor-mode buffer "Editor") t)) - -(defhvar "Editor Definition Info" - "When this is non-nil, the editor Lisp is used to determine definition - editing information; otherwise, the slave Lisp is used." - :value t - :mode "Editor") - -(defcommand "Editor Compile Defun" (p) - "Compiles the current or next top-level form in the editor Lisp. - First the form is evaluated, then the result of this evaluation - is passed to compile. If the current region is active, this - compiles the region." - "Evaluates the current or next top-level form in the editor Lisp." - (declare (ignore p)) - (if (region-active-p) - (editor-compile-region (current-region)) - (editor-compile-region (defun-region (current-point)) t))) - -(defcommand "Editor Compile Region" (p) - "Compiles lisp forms between the point and the mark in the editor Lisp." - "Compiles lisp forms between the point and the mark in the editor Lisp." - (declare (ignore p)) - (editor-compile-region (current-region))) - -(defun defun-region (mark) - "This returns a region around the current or next defun with respect to mark. - Mark is not used to form the region. If there is no appropriate top level - form, this signals an editor-error. This calls PRE-COMMAND-PARSE-CHECK." - (with-mark ((start mark) - (end mark)) - (pre-command-parse-check start) - (cond ((not (mark-top-level-form start end)) - (editor-error "No current or next top level form.")) - (t (region start end))))) - -(defun editor-compile-region (region &optional quiet) - (unless quiet (message "Compiling region ...")) - (in-lisp - (with-input-from-region (stream region) - (with-pop-up-display (*error-output* :height 19) - (compile-from-stream stream - :defined-from-pathname - (buffer-pathname (current-buffer))))))) - - -(defcommand "Editor Evaluate Defun" (p) - "Evaluates the current or next top-level form in the editor Lisp. - If the current region is active, this evaluates the region." - "Evaluates the current or next top-level form in the editor Lisp." - (declare (ignore p)) - (if (region-active-p) - (editor-evaluate-region-command nil) - (with-input-from-region (stream (defun-region (current-point))) - (clear-echo-area) - (in-lisp - (message "Editor Evaluation returned ~S" - (eval (read stream))))))) - -(defcommand "Editor Evaluate Region" (p) - "Evaluates lisp forms between the point and the mark in the editor Lisp." - "Evaluates lisp forms between the point and the mark in the editor Lisp." - (declare (ignore p)) - (with-input-from-region (stream (current-region)) - (clear-echo-area) - (write-string "Evaluating region in the editor ..." *echo-area-stream*) - (finish-output *echo-area-stream*) - (in-lisp - (do ((object (read stream nil lispbuf-eof) - (read stream nil lispbuf-eof))) - ((eq object lispbuf-eof)) - (eval object))) - (message "Evaluation complete."))) - -(defcommand "Editor Re-evaluate Defvar" (p) - "Evaluate the current or next top-level form if it is a DEFVAR. Treat the - form as if the variable is not bound. This occurs in the editor Lisp." - "Evaluate the current or next top-level form if it is a DEFVAR. Treat the - form as if the variable is not bound. This occurs in the editor Lisp." - (declare (ignore p)) - (with-input-from-region (stream (defun-region (current-point))) - (clear-echo-area) - (in-lisp - (let ((form (read stream))) - (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR.")) - (makunbound (cadr form)) - (message "Evaluation returned ~S" (eval form)))))) - -(defcommand "Editor Macroexpand Expression" (p) - "Show the macroexpansion of the current expression in the null environment. - With an argument, use MACROEXPAND instead of MACROEXPAND-1." - "Show the macroexpansion of the current expression in the null environment. - With an argument, use MACROEXPAND instead of MACROEXPAND-1." - (let ((point (buffer-point (current-buffer)))) - (with-mark ((start point)) - (pre-command-parse-check start) - (with-mark ((end start)) - (unless (form-offset end 1) (editor-error)) - (in-lisp - (with-pop-up-display (rts) - (write-string (with-input-from-region (s (region start end)) - (prin1-to-string (funcall (if p - 'macroexpand - 'macroexpand-1) - (read s)))) - rts))))))) - -(defcommand "Editor Evaluate Expression" (p) - "Prompt for an expression to evaluate in the editor Lisp." - "Prompt for an expression to evaluate in the editor Lisp." - (declare (ignore p)) - (in-lisp - (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}" - (eval (prompt-for-expression - :prompt "Editor Eval: " - :help "Expression to evaluate"))))) - -(defcommand "Editor Evaluate Buffer" (p) - "Evaluates the text in the current buffer in the editor Lisp." - "Evaluates the text in the current buffer redirecting *Standard-Output* to - the echo area. This occurs in the editor Lisp. The prefix argument is - ignored." - (declare (ignore p)) - (clear-echo-area) - (write-string "Evaluating buffer in the editor ..." *echo-area-stream*) - (finish-output *echo-area-stream*) - (with-input-from-region (stream (buffer-region (current-buffer))) - (let ((*standard-output* *echo-area-stream*)) - (in-lisp - (do ((object (read stream nil lispbuf-eof) - (read stream nil lispbuf-eof))) - ((eq object lispbuf-eof)) - (eval object)))) - (message "Evaluation complete."))) - - - -;;; With-Output-To-Window -- Internal -;;; -;;; -(defmacro with-output-to-window ((stream name) &body forms) - "With-Output-To-Window (Stream Name) {Form}* - Bind Stream to a stream that writes into the buffer named Name a la - With-Output-To-Mark. The buffer is created if it does not exist already - and a window is created to display the buffer if it is not displayed. - For the duration of the evaluation this window is made the current window." - (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) - (window (gensym)) (old-window (gensym))) - `(let* ((,nam ,name) - (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam))) - (,point (buffer-end (buffer-point ,buffer))) - (,window (or (car (buffer-windows ,buffer)) (make-window ,point))) - (,old-window (current-window))) - (unwind-protect - (progn (setf (current-window) ,window) - (buffer-end ,point) - (with-output-to-mark (,stream ,point) ,@forms)) - (setf (current-window) ,old-window))))) - -(defcommand "Editor Compile File" (p) - "Prompts for file to compile in the editor Lisp. Does not compare source - and binary write dates. Does not check any buffer for that file for - whether the buffer needs to be saved." - "Prompts for file to compile." - (declare (ignore p)) - (let ((pn (prompt-for-file :default - (buffer-default-pathname (current-buffer)) - :prompt "File to compile: "))) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring pn) :error-file nil))))) - -(defcommand "Editor Compile Buffer File" (p) - "Compile the file in the current buffer in the editor Lisp if its associated - binary file (of type .fasl) is older than the source or doesn't exist. When - the binary file is up to date, the user is asked if the source should be - compiled anyway. When the prefix argument is supplied, compile the file - without checking the binary file. When \"Compile Buffer File Confirm\" is - set, this command will ask for confirmation when it otherwise would not." - "Compile the file in the current buffer in the editor Lisp if the fasl file - isn't up to date. When p, always do it." - (let* ((buf (current-buffer)) - (pn (buffer-pathname buf))) - (unless pn (editor-error "Buffer has no associated pathname.")) - (cond ((buffer-modified buf) - (when (or (not (value compile-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "Save and compile file ~A? " - (namestring pn)))) - (write-buffer-file buf pn) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring pn) :error-file nil))))) - ((older-or-non-existent-fasl-p pn p) - (when (or (not (value compile-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "Compile file ~A? " (namestring pn)))) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring pn) :error-file nil))))) - (t (when (or p - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt - "Fasl file up to date, compile source anyway? ")) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring pn) :error-file nil)))))))) - -(defcommand "Editor Compile Group" (p) - "Compile each file in the current group which needs it in the editor Lisp. - If a file has type LISP and there is a curresponding file with type - FASL which has been written less recently (or it doesn't exit), then - the file is compiled, with error output directed to the \"Compiler Warnings\" - buffer. If a prefix argument is provided, then all the files are compiled. - All modified files are saved beforehand." - "Do a Compile-File in each file in the current group that seems to need it - in the editor Lisp." - (save-all-files-command ()) - (unless *active-file-group* (editor-error "No active file group.")) - (dolist (file *active-file-group*) - (when (string-equal (pathname-type file) "lisp") - (let ((tn (probe-file file))) - (cond ((not tn) - (message "File ~A not found." (namestring file))) - ((older-or-non-existent-fasl-p tn p) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring tn) :error-file nil))))))))) - -(defcommand "List Compile Group" (p) - "List any files that would be compiled by \"Compile Group\". All Modified - files are saved before checking to generate a consistent list." - "Do a Compile-File in each file in the current group that seems to need it." - (declare (ignore p)) - (save-all-files-command ()) - (unless *active-file-group* (editor-error "No active file group.")) - (with-pop-up-display (s) - (write-line "\"Compile Group\" would compile the following files:" s) - (force-output s) - (dolist (file *active-file-group*) - (when (string-equal (pathname-type file) "lisp") - (let ((tn (probe-file file))) - (cond ((not tn) - (format s "File ~A not found.~%" (namestring file))) - ((older-or-non-existent-fasl-p tn) - (write-line (namestring tn) s))) - (force-output s)))))) - -(defhvar "Load Pathname Defaults" - "The default pathname used by the load command.") - -(defcommand "Editor Load File" (p) - "Prompt for a file to load into Editor Lisp." - "Prompt for a file to load into the Editor Lisp." - (declare (ignore p)) - (let ((name (truename (prompt-for-file - :default - (or (value load-pathname-defaults) - (buffer-default-pathname (current-buffer))) - :prompt "Editor file to load: " - :help "The name of the file to load")))) - (setv load-pathname-defaults name) - (in-lisp (load name)))) - - - -;;;; Lisp documentation stuff. - -;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and -;;; "Describe Function Call". -;;; -(defmacro function-to-describe (var error-name) - `(cond ((not (symbolp ,var)) - (,error-name "~S is not a symbol." ,var)) - ((macro-function ,var)) - ((fboundp ,var) - (if (listp (symbol-function ,var)) - ,var - (symbol-function ,var))) - (t - (,error-name "~S is not a function." ,var)))) - -(defcommand "Editor Describe Function Call" (p) - "Describe the most recently typed function name in the editor Lisp." - "Describe the most recently typed function name in the editor Lisp." - (declare (ignore p)) - (with-mark ((mark1 (current-point)) - (mark2 (current-point))) - (pre-command-parse-check mark1) - (unless (backward-up-list mark1) (editor-error)) - (form-offset (move-mark mark2 (mark-after mark1)) 1) - (with-input-from-region (s (region mark1 mark2)) - (in-lisp - (let* ((sym (read s)) - (fun (function-to-describe sym editor-error))) - (with-pop-up-display (*standard-output*) - (editor-describe-function fun sym))))))) - - -(defcommand "Editor Describe Symbol" (p) - "Describe the previous s-expression if it is a symbol in the editor Lisp." - "Describe the previous s-expression if it is a symbol in the editor Lisp." - (declare (ignore p)) - (with-mark ((mark1 (current-point)) - (mark2 (current-point))) - (mark-symbol mark1 mark2) - (with-input-from-region (s (region mark1 mark2)) - (in-lisp - (let ((thing (read s))) - (if (symbolp thing) - (with-pop-up-display (*standard-output*) - (describe thing)) - (if (and (consp thing) - (or (eq (car thing) 'quote) - (eq (car thing) 'function)) - (symbolp (cadr thing))) - (with-pop-up-display (*standard-output*) - (describe (cadr thing))) - (editor-error "~S is not a symbol, or 'symbol, or #'symbol." - thing)))))))) - -;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol. -;;; However, if the marks are immediately before the first constituent char -;;; of the symbol name, we use the next symbol since the marks probably -;;; correspond to the point, and Hemlock's cursor display makes it look like -;;; the point is within the symbol name. This also tries to ignore :prefix -;;; characters such as quotes, commas, etc. -;;; -(defun mark-symbol (mark1 mark2) - (pre-command-parse-check mark1) - (with-mark ((tmark1 mark1) - (tmark2 mark1)) - (cond ((and (form-offset tmark1 1) - (form-offset (move-mark tmark2 tmark1) -1) - (or (mark= mark1 tmark2) - (and (find-attribute tmark2 :lisp-syntax - #'(lambda (x) (not (eq x :prefix)))) - (mark= mark1 tmark2)))) - (form-offset mark2 1)) - (t - (form-offset mark1 -1) - (find-attribute mark1 :lisp-syntax - #'(lambda (x) (not (eq x :prefix)))) - (form-offset (move-mark mark2 mark1) 1))))) - - -(defcommand "Editor Describe" (p) - "Call Describe on a Lisp object. - Prompt for an expression which is evaluated to yield the object." - "Prompt for an object to describe." - (declare (ignore p)) - (in-lisp - (let* ((exp (prompt-for-expression - :prompt "Object: " - :help "Expression to evaluate to get object to describe.")) - (obj (eval exp))) - (with-pop-up-display (*standard-output*) - (describe obj))))) - -(defcommand "Filter Region" (p) - "Apply a Lisp function to each line of the region. - An expression is prompted for which should evaluate to a Lisp function - from a string to a string. The function must neither modify its argument - nor modify the return value after it is returned." - "Call prompt for a function, then call Filter-Region with it and the region." - (declare (ignore p)) - (let* ((exp (prompt-for-expression - :prompt "Function: " - :help "Expression to evaluate to get function to use as filter.")) - (fun (in-lisp (eval exp))) - (region (current-region))) - (check-region-query-size region) - (let* ((start (copy-mark (region-start region) :left-inserting)) - (end (copy-mark (region-end region) :left-inserting)) - (region (region start end)) - (undo-region (copy-region region))) - (filter-region fun region) - (make-region-undo :twiddle "Filter Region" region undo-region)))) diff --git a/hemlock/lispeval.lisp b/hemlock/lispeval.lisp deleted file mode 100644 index 3d27b6652a4ae4b5d92fc835c9f6ad8463ca8970..0000000000000000000000000000000000000000 --- a/hemlock/lispeval.lisp +++ /dev/null @@ -1,974 +0,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.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). -;;; ********************************************************************** -;;; -;;; This file contains code for sending requests to eval servers and the -;;; commands based on that code. -;;; -;;; Written by William Lott and Rob MacLachlan. -;;; - -(in-package "HEMLOCK") - - -;;; The note structure holds everything we need to know about an -;;; operation. Not all operations use all the available fields. -;;; -(defstruct (note (:print-function %print-note)) - (state :unsent) ; :unsent, :pending, :running, :aborted or :dead. - server ; Server-Info for the server this op is on. - context ; Short string describing what this op is doing. - kind ; Either :eval, :compile, or :compile-file - buffer ; Buffer source came from. - region ; Region of request - package ; Package or NIL if none - text ; string containing request - input-file ; File to compile or where stuff was found - net-input-file ; Net version of above. - output-file ; Temporary output file for compiler fasl code. - net-output-file ; Net version of above - output-date ; Temp-file is created before calling compiler, - ; and this is its write date. - lap-file ; The lap file for compiles - error-file ; The file to dump errors into - load ; Load compiled file or not? - (errors 0) ; Count of compiler errors. - (warnings 0)) ; Count of compiler warnings. -;;; -(defun %print-note (note stream d) - (declare (ignore d)) - (format stream "#<Eval-Server-Note for ~A [~A]>" - (note-context note) - (note-state note))) - - - -;;;; Note support routines. - -;;; QUEUE-NOTE -- Internal. -;;; -;;; This queues note for server. SERVER-INFO-NOTES keeps notes in stack order, -;;; not queue order. We also link the note to the server and try to send it -;;; to the server. If we didn't send this note, we tell the user the server -;;; is busy and that we're queuing his note to be sent later. -;;; -(defun queue-note (note server) - (push note (server-info-notes server)) - (setf (note-server note) server) - (maybe-send-next-note server) - (when (eq (note-state note) :unsent) - (message "Server ~A busy, ~A queued." - (server-info-name server) - (note-context note)))) - -;;; MAYBE-SEND-NEXT-NOTE -- Internal. -;;; -;;; Loop over all notes in server. If we see any :pending or :running, then -;;; punt since we can't send one. Otherwise, by the end of the list, we may -;;; have found an :unsent one, and if we did, next will be the last :unsent -;;; note. Remember, SERVER-INFO-NOTES is kept in stack order not queue order. -;;; -(defun maybe-send-next-note (server) - (let ((busy nil) - (next nil)) - (dolist (note (server-info-notes server)) - (ecase (note-state note) - ((:pending :running) - (setf busy t) - (return)) - (:unsent - (setf next note)) - (:aborted :dead))) - (when (and (not busy) next) - (send-note next)))) - -(defun send-note (note) - (let* ((remote (wire:make-remote-object note)) - (server (note-server note)) - (ts (server-info-slave-info server)) - (bg (server-info-background-info server)) - (wire (server-info-wire server))) - (setf (note-state note) :pending) - (message "Sending ~A." (note-context note)) - (case (note-kind note) - (:eval - (wire:remote wire - (server-eval-text remote - (note-package note) - (note-text note) - (and ts (ts-data-stream ts))))) - (:compile - (wire:remote wire - (server-compile-text remote - (note-package note) - (note-text note) - (note-input-file note) - (and ts (ts-data-stream ts)) - (and bg (ts-data-stream bg))))) - (:compile-file - (macrolet ((frob (x) - `(if (pathnamep ,x) - (namestring ,x) - ,x))) - (wire:remote wire - (server-compile-file remote - (note-package note) - (frob (or (note-net-input-file note) - (note-input-file note))) - (frob (or (note-net-output-file note) - (note-output-file note))) - (frob (note-error-file note)) - (frob (note-lap-file note)) - (note-load note) - (and ts (ts-data-stream ts)) - (and bg (ts-data-stream bg)))))) - (t - (error "Unknown note kind ~S" (note-kind note)))) - (wire:wire-force-output wire))) - - -;;;; Server Callbacks. - -(defun operation-started (note) - (let ((note (wire:remote-object-value note))) - (setf (note-state note) :running) - (message "The ~A started." (note-context note))) - (values)) - -(defun eval-form-error (message) - (editor-error message)) - -(defun lisp-error (note start end msg) - (declare (ignore start end)) - (let ((note (wire:remote-object-value note))) - (loud-message "During ~A: ~A" - (note-context note) - msg)) - (values)) - -(defun compiler-error (note start end function severity) - (let* ((note (wire:remote-object-value note)) - (server (note-server note)) - (line (mark-line - (buffer-end-mark - (server-info-background-buffer server)))) - (message (format nil "~:(~A~) in ~A during ~A." - severity - function - (note-context note))) - (error (make-error-info :buffer (note-buffer note) - :message message - :line line))) - (message "~A" message) - (let ((region (case (note-kind note) - (:compile - (note-region note)) - (:compile-file - (buffer-region (note-buffer note))) - (t - (error "Compiler error in ~S?" note))))) - (when region - (let* ((region-end (region-end region)) - (m1 (copy-mark (region-start region) :left-inserting)) - (m2 (copy-mark m1 :left-inserting))) - (when start - (character-offset m1 start) - (when (mark> m1 region-end) - (move-mark m1 region-end))) - (unless (and end (character-offset m2 end)) - (move-mark m2 region-end)) - - (setf (error-info-region error) - (region m1 m2))))) - - (vector-push-extend error (server-info-errors server))) - - (values)) - -(defun eval-text-result (note start end values) - (declare (ignore note start end)) - (message "=> ~{~#[~;~A~:;~A, ~]~}" values) - (values)) - -(defun operation-completed (note abortp) - (let* ((note (wire:remote-object-value note)) - (server (note-server note)) - (file (note-output-file note))) - (wire:forget-remote-translation note) - (setf (note-state note) :dead) - (setf (server-info-notes server) - (delete note (server-info-notes server) - :test #'eq)) - (setf (note-server note) nil) - - (if abortp - (loud-message "The ~A aborted." (note-context note)) - (let ((errors (note-errors note)) - (warnings (note-warnings note))) - (message "The ~A complete.~@[ ~D error~:P~]~@[ ~D warning~:P~]" - (note-context note) - (and (plusp errors) errors) - (and (plusp warnings) warnings)))) - - (let ((region (note-region note))) - (when (regionp region) - (delete-mark (region-start region)) - (delete-mark (region-end region)) - (setf (note-region note) nil))) - - (when (and (eq (note-kind note) - :compile-file) - (not (eq file t)) - file) - (if (> (file-write-date file) - (note-output-date note)) - (let ((new-name (make-pathname :type "fasl" - :defaults (note-input-file note)))) - (rename-file file new-name) - (mach:unix-chmod (namestring new-name) #o644)) - (delete-file file))) - (maybe-send-next-note server)) - (values)) - - -;;;; Stuff to send noise to the server. - -;;; EVAL-FORM-IN-SERVER -- Public. -;;; -(defun eval-form-in-server (server-info form - &optional (package (value current-package))) - "This evals form, a simple-string, in the server for server-info. Package - is the name of the package in which the server reads form, and it defaults - to the value of \"Current Package\". If package is nil, then the slave uses - the value of *package*. If server is busy with other requests, this signals - an editor-error to prevent commands using this from hanging. If the server - dies while evaluating form, then this signals an editor-error. This returns - a list of strings which are the printed representation of all the values - returned by form in the server." - (declare (simple-string form)) - (when (server-info-notes server-info) - (editor-error "Server ~S is currently busy. See \"List Operations\"." - (server-info-name server-info))) - (multiple-value-bind (values error) - (wire:remote-value (server-info-wire server-info) - (server-eval-form package form)) - (when error - (editor-error "The server died before finishing")) - values)) - -;;; EVAL-FORM-IN-SERVER-1 -- Public. -;;; -;;; We use VALUES to squelch the second value of READ-FROM-STRING. -;;; -(defun eval-form-in-server-1 (server-info form - &optional (package (value current-package))) - "This calls EVAL-FORM-IN-SERVER and returns the result of READ'ing from - the first string EVAL-FORM-IN-SERVER returns." - (values (read-from-string - (car (eval-form-in-server server-info form package))))) - -(defun string-eval (string - &key - (server (get-current-eval-server)) - (package (value current-package)) - (context (format nil - "evaluation of ~S" - string))) - "Queues the evaluation of string on an eval server. String is a simple - string. If package is not supplied, the string is eval'ed in the slave's - current package." - (declare (simple-string string)) - (queue-note (make-note :kind :eval - :context context - :package package - :text string) - server) - (values)) - -(defun region-eval (region - &key - (server (get-current-eval-server)) - (package (value current-package)) - (context (region-context region "evaluation"))) - "Queues the evaluation of a region of text on an eval server. If package - is not supplied, the string is eval'ed in the slave's current package." - (let ((region (region (copy-mark (region-start region) :left-inserting) - (copy-mark (region-end region) :left-inserting)))) - (queue-note (make-note :kind :eval - :context context - :region region - :package package - :text (region-to-string region)) - server)) - (values)) - -(defun region-compile (region - &key - (server (get-current-eval-server)) - (package (value current-package))) - "Queues a compilation on an eval server. If package is not supplied, the - string is eval'ed in the slave's current package." - (let* ((region (region (copy-mark (region-start region) :left-inserting) - (copy-mark (region-end region) :left-inserting))) - (buf (line-buffer (mark-line (region-start region)))) - (defined-from (and buf - (namestring (buffer-pathname buf))))) - (queue-note (make-note :kind :compile - :context (region-context region "compilation") - :buffer (and region - (region-start region) - (mark-line (region-start region)) - (line-buffer (mark-line - (region-start region)))) - :region region - :package package - :text (region-to-string region) - :input-file defined-from) - server)) - (values)) - - - -;;;; File compiling noise. - -(defhvar "Remote Compile File" - "When set (the default), this causes slave file compilations to assume the - compilation is occurring on a remote machine. This means the source file - must be world readable. Unsetting this, causes no file accesses to go - through the super root." - :value nil) - -;;; FILE-COMPILE compiles files in a client Lisp. Because of Unix file -;;; protection, one cannot write files over the net unless they are publicly -;;; writeable. To get around this, we create a temporary file that is -;;; publicly writeable for compiler output. This file is renamed to an -;;; ordinary output name if the compiler wrote anything to it, or deleted -;;; otherwise. No temporary file is created when output-file is not t. -;;; - -(defun file-compile (file - &key - buffer - (output-file t) - error-file - lap-file - load - (server (get-current-compile-server)) - (package (value current-package))) - "Compiles file in a client Lisp. When output-file is t, a temporary - output file is used that is publicly writeable in case the client is on - another machine. This file is renamed or deleted after compilation. - Setting \"Remote Compile File\" to nil, inhibits this. If package is not - supplied, the string is eval'ed in the slave's current package." - - (let* ((file (truename file)) ; in case of search-list in pathname. - (namestring (namestring file)) - (note (make-note - :kind :compile-file - :context (format nil "compilation of ~A" namestring) - :buffer buffer - :region nil - :package package - :input-file file - :output-file output-file - :error-file error-file - :lap-file lap-file - :load load))) - - (when (and (value remote-compile-file) - (eq output-file t)) - (multiple-value-bind (net-infile ofile net-ofile date) - (file-compile-temp-file file) - (setf (note-net-input-file note) net-infile) - (setf (note-output-file note) ofile) - (setf (note-net-output-file note) net-ofile) - (setf (note-output-date note) date))) - - (clear-server-errors server - #'(lambda (error) - (eq (error-info-buffer error) - buffer))) - (queue-note note server))) - -;;; FILE-COMPILE-TEMP-FILE creates a a temporary file that is publicly -;;; writable in the directory file is in and with a .fasl type. Four values -;;; are returned -- a pathname suitable for referencing file remotely, the -;;; pathname of the temporary file created, a pathname suitable for referencing -;;; the temporary file remotely, and the write date of the temporary file. -;;; - -(defun file-compile-temp-file (file) - (let ((ofile (loop (let* ((sym (gensym)) - (f (merge-pathnames - (format nil "compile-file-~A.fasl" sym) - file))) - (unless (probe-file f) (return f)))))) - (multiple-value-bind (fd err) - (mach:unix-open (namestring ofile) - mach:o_creat #o666) - (unless fd - (editor-error "Couldn't create compiler temporary output file:~%~ - ~A" (mach:get-unix-error-msg err))) - (mach:unix-fchmod fd #o666) - (mach:unix-close fd)) - (let ((net-ofile (pathname-for-remote-access ofile))) - (values (make-pathname :directory (pathname-directory net-ofile) - :defaults file) - ofile - net-ofile - (file-write-date ofile))))) - -(defun pathname-for-remote-access (file) - (let* ((machine (machine-instance)) - (usable-name (nstring-downcase - (the simple-string - (subseq machine 0 (position #\. machine)))))) - (declare (simple-string machine usable-name)) - (make-pathname :directory (concatenate 'simple-string - "/../" - usable-name - (directory-namestring file)) - :defaults file))) - -;;; REGION-CONTEXT -- internal -;;; -;;; Return a string which describes the code in a region. Thing is the -;;; thing being done to the region. "compilation" or "evaluation"... - -(defun region-context (region thing) - (declare (simple-string thing)) - (pre-command-parse-check (region-start region)) - (let ((start (region-start region))) - (with-mark ((m1 start)) - (unless (start-defun-p m1) - (top-level-offset m1 1)) - (with-mark ((m2 m1)) - (mark-after m2) - (form-offset m2 2) - (format nil - "~A of ~S" - thing - (if (eq (mark-line m1) (mark-line m2)) - (region-to-string (region m1 m2)) - (concatenate 'simple-string - (line-string (mark-line m1)) - "..."))))))) - - -;;;; Commands (Gosh, wow gee!) - -(defcommand "Editor Server Name" (p) - "Echos the editor server's name which can be supplied with the -slave switch - to connect to a designated editor." - "Echos the editor server's name which can be supplied with the -slave switch - to connect to a designated editor." - (declare (ignore p)) - (if *editor-name* - (message "This editor is named ~S." *editor-name*) - (message "This editor is not currently named."))) - -(defcommand "Set Buffer Package" (p) - "Set the package to be used by Lisp evaluation and compilation commands - while in this buffer. When in a slave's interactive buffers, do NOT - set the editor's package variable, but changed the slave's *package*." - "Prompt for a package to make into a buffer-local variable current-package." - (declare (ignore p)) - (let* ((name (string (prompt-for-expression - :prompt "Package name: " - :help "Name of package to associate with this buffer."))) - (buffer (current-buffer)) - (info (value current-eval-server))) - (cond ((and info - (or (eq (server-info-slave-buffer info) buffer) - (eq (server-info-background-buffer info) buffer))) - (wire:remote (server-info-wire info) - (server-set-package name)) - (wire:wire-force-output (server-info-wire info))) - ((eq buffer *selected-eval-buffer*) - (setf *package* (maybe-make-package name))) - (t - (defhvar "Current Package" - "The package used for evaluation of Lisp in this buffer." - :buffer buffer :value name))) - (when (buffer-modeline-field-p buffer :package) - (dolist (w (buffer-windows buffer)) - (update-modeline-field buffer w :package))))) - -(defcommand "Current Compile Server" (p) - "Echos the current compile server's name. With prefix argument, - shows global one. Does not signal an error or ask about creating a slave." - "Echos the current compile server's name. With prefix argument, - shows global one." - (let ((info (if p - (variable-value 'current-compile-server :global) - (value current-compile-server)))) - (if info - (message "~A" (server-info-name info)) - (message "No ~:[current~;global~] compile server." p)))) - -(defcommand "Set Compile Server" (p) - "Specifies the name of the server used globally for file compilation requests." - "Call select-current-compile-server." - (declare (ignore p)) - (hlet ((ask-about-old-servers t)) - (setf (variable-value 'current-compile-server :global) - (maybe-create-server)))) - -(defcommand "Set Buffer Compile Server" (p) - "Specifies the name of the server used for file compilation requests in - the current buffer." - "Call select-current-compile-server after making a buffer local variable." - (declare (ignore p)) - (hlet ((ask-about-old-servers t)) - (defhvar "Current Compile Server" - "The Server-Info object for the server currently used for compilation requests." - :buffer (current-buffer) - :value (maybe-create-server)))) - -(defcommand "Current Eval Server" (p) - "Echos the current eval server's name. With prefix argument, shows - global one. Does not signal an error or ask about creating a slave." - "Echos the current eval server's name. With prefix argument, shows - global one. Does not signal an error or ask about creating a slave." - (let ((info (if p - (variable-value 'current-eval-server :global) - (value current-eval-server)))) - (if info - (message "~A" (server-info-name info)) - (message "No ~:[current~;global~] eval server." p)))) - -(defcommand "Set Eval Server" (p) - "Specifies the name of the server used globally for evaluation and - compilation requests." - "Call select-current-server." - (declare (ignore p)) - (hlet ((ask-about-old-servers t)) - (setf (variable-value 'current-eval-server :global) - (maybe-create-server)))) - -(defcommand "Set Buffer Eval Server" (p) - "Specifies the name of the server used for evaluation and compilation - requests in the current buffer." - "Call select-current-server after making a buffer local variable." - (declare (ignore p)) - (hlet ((ask-about-old-servers t)) - (defhvar "Current Eval Server" - "The Server-Info for the eval server used in this buffer." - :buffer (current-buffer) - :value (maybe-create-server)))) - -#+ :IGNORETHIS -(defcommand "Connect Registered Eval Server" (p) - "Tries to connect to a registered eval server. Prompts for name." - "Tries to connect to a registered eval server. Prompts for name." - (declare (ignore p)) - (connect-registered-eval-server - (prompt-for-string :prompt "Name to lookup: " - :help "Registered eval server to connect to.") - (prompt-for-string - :prompt "Local server name: " - :help "Editor's name for server and \"Background <name>\" buffer."))) - -(defcommand "Evaluate Defun" (p) - "Evaluates the current or next top-level form. - If the current region is active, then evaluate it." - "Evaluates the current or next top-level form." - (declare (ignore p)) - (if (region-active-p) - (evaluate-region-command nil) - (region-eval (defun-region (current-point))))) - -(defcommand "Re-evaluate Defvar" (p) - "Evaluate the current or next top-level form if it is a DEFVAR. Treat the - form as if the variable is not bound." - "Evaluate the current or next top-level form if it is a DEFVAR. Treat the - form as if the variable is not bound." - (declare (ignore p)) - (let* ((form (defun-region (current-point))) - (start (region-start form))) - (with-mark ((var-start start) - (var-end start)) - (mark-after var-start) - (form-offset var-start 1) - (form-offset (move-mark var-end var-start) 1) - (let ((exp (concatenate 'simple-string - "(makunbound '" - (region-to-string (region var-start var-end)) - ")"))) - (eval-form-in-server (get-current-eval-server) exp))) - (region-eval form))) - -;;; We use Prin1-To-String in the client so that the expansion gets pretty -;;; printed. Since the expansion can contain unreadable stuff, we can't expect -;;; to be able to read that string back in the editor. We shove the region -;;; at the client Lisp as a string, so it can read from the string with the -;;; right package environment. -;;; - -(defcommand "Macroexpand Expression" (p) - "Show the macroexpansion of the current expression in the null environment. - With an argument, use MACROEXPAND instead of MACROEXPAND-1." - "Show the macroexpansion of the current expression in the null environment. - With an argument, use MACROEXPAND instead of MACROEXPAND-1." - (let ((point (current-point))) - (with-mark ((start point)) - (pre-command-parse-check start) - (with-mark ((end start)) - (unless (form-offset end 1) (editor-error)) - (with-pop-up-display (s) - (write-string - (eval-form-in-server-1 - (get-current-eval-server) - (format nil "(prin1-to-string (~S (read-from-string ~S)))" - (if p 'macroexpand 'macroexpand-1) - (region-to-string (region start end)))) - s)))))) - -(defcommand "Evaluate Expression" (p) - "Prompt for an expression to evaluate." - "Prompt for an expression to evaluate." - (declare (ignore p)) - (let ((exp (prompt-for-string - :prompt "Eval: " - :help "Expression to evaluate."))) - (message "=> ~{~#[~;~A~:;~A, ~]~}" - (eval-form-in-server (get-current-eval-server) exp)))) - -(defcommand "Compile Defun" (p) - "Compiles the current or next top-level form. - First the form is evaluated, then the result of this evaluation - is passed to compile. If the current region is active, compile - the region." - "Evaluates the current or next top-level form." - (declare (ignore p)) - (if (region-active-p) - (compile-region-command nil) - (region-compile (defun-region (current-point))))) - -(defcommand "Compile Region" (p) - "Compiles lisp forms between the point and the mark." - "Compiles lisp forms between the point and the mark." - (declare (ignore p)) - (region-compile (current-region))) - -(defcommand "Evaluate Region" (p) - "Evaluates lisp forms between the point and the mark." - "Evaluates lisp forms between the point and the mark." - (declare (ignore p)) - (region-eval (current-region))) - -(defcommand "Evaluate Buffer" (p) - "Evaluates the text in the current buffer." - "Evaluates the text in the current buffer redirecting *Standard-Output* to - the echo area. The prefix argument is ignored." - (declare (ignore p)) - (let ((b (current-buffer))) - (region-eval (buffer-region b) - :context (format nil - "evaluation of buffer ``~A''" - (buffer-name b))))) - -(defcommand "Load File" (p) - "Prompt for a file to load into the current eval server." - "Prompt for a file to load into the current eval server." - (declare (ignore p)) - (let ((name (truename (prompt-for-file - :default - (or (value load-pathname-defaults) - (buffer-default-pathname (current-buffer))) - :prompt "File to load: " - :help "The name of the file to load")))) - (setv load-pathname-defaults name) - (string-eval (format nil "(load ~S)" - (namestring (pathname-for-remote-access name)))))) - -(defcommand "Compile File" (p) - "Prompts for file to compile. Does not compare source and binary write - dates. Does not check any buffer for that file for whether the buffer - needs to be saved." - "Prompts for file to compile." - (declare (ignore p)) - (let ((pn (prompt-for-file :default - (buffer-default-pathname (current-buffer)) - :prompt "File to compile: "))) - (file-compile pn))) - -(defhvar "Compile Buffer File Confirm" - "When set, \"Compile Buffer File\" prompts before doing anything." - :value t) - -(defcommand "Compile Buffer File" (p) - "Compile the file in the current buffer if its associated binary file - (of type .fasl) is older than the source or doesn't exist. When the - binary file is up to date, the user is asked if the source should be - compiled anyway. When the prefix argument is supplied, compile the - file without checking the binary file. When \"Compile Buffer File - Confirm\" is set, this command will ask for confirmation when it - otherwise would not." - "Compile the file in the current buffer if the fasl file isn't up to date. - When p, always do it." - (let* ((buf (current-buffer)) - (pn (buffer-pathname buf))) - (unless pn (editor-error "Buffer has no associated pathname.")) - (cond ((buffer-modified buf) - (when (or (not (value compile-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "Save and compile file ~A? " - (namestring pn)))) - (write-buffer-file buf pn) - (file-compile pn :buffer buf))) - ((older-or-non-existent-fasl-p pn p) - (when (or (not (value compile-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "Compile file ~A? " (namestring pn)))) - (file-compile pn :buffer buf))) - ((or p - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt - "Fasl file up to date, compile source anyway? ")) - (file-compile pn :buffer buf))))) - -(defcommand "Compile Group" (p) - "Compile each file in the current group which needs it. - If a file has type LISP and there is a curresponding file with type - FASL which has been written less recently (or it doesn't exit), then - the file is compiled, with error output directed to the \"Compiler Warnings\" - buffer. If a prefix argument is provided, then all the files are compiled. - All modified files are saved beforehand." - "Do a Compile-File in each file in the current group that seems to need it." - (save-all-files-command ()) - (unless *active-file-group* (editor-error "No active file group.")) - (dolist (file *active-file-group*) - (when (string-equal (pathname-type file) "lisp") - (let ((tn (probe-file file))) - (cond ((not tn) - (message "File ~A not found." (namestring file))) - ((older-or-non-existent-fasl-p tn p) - (file-compile tn))))))) - -(defun older-or-non-existent-fasl-p (pathname &optional definitely) - (let ((obj-pn (probe-file (make-pathname :type "fasl" :defaults pathname)))) - (or definitely - (not obj-pn) - (< (file-write-date obj-pn) (file-write-date pathname))))) - - - -;;;; Error hacking stuff. - -(defcommand "Flush Compiler Error Information" (p) - "Flushes all infomation about errors encountered while compiling using the - current server" - "Flushes all infomation about errors encountered while compiling using the - current server" - (declare (ignore p)) - (clear-server-errors (get-current-compile-server t))) - -(defcommand "Next Compiler Error" (p) - "Move to the next compiler error for the current server. If an argument is - given, advance that many errors." - "Move to the next compiler error for the current server. If an argument is - given, advance that many errors." - (let* ((server (get-current-compile-server t)) - (errors (server-info-errors server)) - (fp (fill-pointer errors))) - (when (zerop fp) - (editor-error "There are no compiler errors.")) - (let* ((old-index (server-info-error-index server)) - (new-index (+ (or old-index -1) (or p 1)))) - (when (< new-index 0) - (if old-index - (editor-error "Can't back up ~R, only at the ~:R compiler error." - (- p) (1+ old-index)) - (editor-error "Not even at the first compiler error."))) - (when (>= new-index fp) - (if (= (1+ (or old-index -1)) fp) - (editor-error "No more compiler errors.") - (editor-error "Only ~R remaining compiler error~:P." - (- fp old-index 1)))) - (setf (server-info-error-index server) new-index) - ;; Display the silly error. - (let ((error (aref errors new-index))) - (let ((region (error-info-region error))) - (if region - (let* ((start (region-start region)) - (buffer (line-buffer (mark-line start)))) - (change-to-buffer buffer) - (move-mark (buffer-point buffer) start)) - (message "Hmm, no region for this error."))) - (let* ((line (error-info-line error)) - (buffer (line-buffer line))) - (if (and line (bufferp buffer)) - (let ((mark (mark line 0))) - (unless (buffer-windows buffer) - (let ((window (find-if-not - #'(lambda (window) - (or (eq window (current-window)) - (eq window *echo-area-window*))) - *window-list*))) - (if window - (setf (window-buffer window) buffer) - (make-window mark)))) - (move-mark (buffer-point buffer) mark) - (dolist (window (buffer-windows buffer)) - (move-mark (window-display-start window) mark) - (move-mark (window-point window) mark)) - (delete-mark mark)) - (message "Hmm, no line for this error."))))))) - -(defcommand "Previous Compiler Error" (p) - "Move to the previous compiler error. If an argument is given, move back - that many errors." - "Move to the previous compiler error. If an argument is given, move back - that many errors." - (next-compiler-error-command (- (or p 1)))) - - - -;;;; Operation management commands: - -(defcommand "Abort Operations" (p) - "Abort all operations on current eval server connection." - "Abort all operations on current eval server connection." - (declare (ignore p)) - (let* ((server (get-current-eval-server)) - (wire (server-info-wire server))) - ;; Tell the slave to abort the current operation and to ignore any further - ;; operations. - (dolist (note (server-info-notes server)) - (setf (note-state note) :aborted)) - (ext:send-character-out-of-band (wire:wire-fd wire) #\N) - (wire:remote-value wire (server-accept-operations)) - ;; Synch'ing with server here, causes any operations queued at the socket or - ;; in the server to be ignored, and the last thing evaluated is an - ;; instruction to go on accepting operations. - (wire:wire-force-output wire) - (dolist (note (server-info-notes server)) - (when (eq (note-state note) :pending) - ;; The WIRE:REMOTE-VALUE call should have allowed a handshake to - ;; tell the editor anything :pending was aborted. - (error "Operation ~S is still around after we aborted it?" note))) - ;; Forget anything queued in the editor. - (setf (server-info-notes server) nil))) - -(defcommand "List Operations" (p) - "List all eval server operations which have not yet completed." - "List all eval server operations which have not yet completed." - (declare (ignore p)) - (let ((notes nil)) - ;; Collect all notes, reversing them since they act like a queue but - ;; are not in queue order. - (do-strings (str val *server-names*) - (declare (ignore str)) - (setq notes (nconc notes (reverse (server-info-notes val))))) - (if notes - (with-pop-up-display (s) - (dolist (note notes) - (format s "~@(~8A~) ~A on ~A.~%" - (note-state note) - (note-context note) - (server-info-name (note-server note))))) - (message "No uncompleted operations."))) - (values)) - - -;;;; Describing in the client lisp. - -;;; "Describe Function Call" gets the function name from the current form -;;; as a string. This string is used as the argument to a call to -;;; DESCRIBE-FUNCTION-CALL-AUX which is eval'ed in the client lisp. The -;;; auxiliary function's name is qualified since it is read in the client -;;; Lisp with *package* bound to the buffer's package. The result comes -;;; back as a list of strings, so we read the first string to get out the -;;; string value returned by DESCRIBE-FUNCTION-CALL-AUX in the client Lisp. -;;; -(defcommand "Describe Function Call" (p) - "Describe the current function call." - "Describe the current function call." - (let ((info (value current-eval-server))) - (cond - ((not info) - (message "Describing from the editor Lisp ...") - (editor-describe-function-call-command p)) - (t - (with-mark ((mark1 (current-point)) - (mark2 (current-point))) - (pre-command-parse-check mark1) - (unless (backward-up-list mark1) (editor-error)) - (form-offset (move-mark mark2 (mark-after mark1)) 1) - (let* ((package (value current-package)) - (package-exists - (eval-form-in-server-1 - info - (format nil - "(if (find-package ~S) t (package-name *package*))" - package) - nil))) - (unless (eq package-exists t) - (message "Using package ~S in ~A since ~ - ~:[there is no current package~;~:*~S does not exist~]." - package-exists (server-info-name info) package)) - (with-pop-up-display (s) - (write-string (eval-form-in-server-1 - info - (format nil "(ed::describe-function-call-aux ~S)" - (region-to-string (region mark1 mark2))) - (if (eq package-exists t) package nil)) - s)))))))) - -;;; DESCRIBE-FUNCTION-CALL-AUX is always evaluated in a client Lisp to some -;;; editor, relying on the fact that the cores have the same functions. String -;;; is the name of a function that is read (in the client Lisp). The result is -;;; a string of all the output from EDITOR-DESCRIBE-FUNCTION. -;;; -(defun describe-function-call-aux (string) - (let* ((sym (read-from-string string)) - (fun (function-to-describe sym error))) - (with-output-to-string (*standard-output*) - (editor-describe-function fun sym)))) - -;;; "Describe Symbol" gets the symbol name and quotes it as the argument to a -;;; call to DESCRIBE-SYMBOL-AUX which is eval'ed in the client lisp. The -;;; auxiliary function's name is qualified since it is read in the client Lisp -;;; with *package* bound to the buffer's package. The result comes back as a -;;; list of strings, so we read the first string to get out the string value -;;; returned by DESCRIBE-SYMBOL-AUX in the client Lisp. -;;; - -(defcommand "Describe Symbol" (p) - "Describe the previous s-expression if it is a symbol." - "Describe the previous s-expression if it is a symbol." - (declare (ignore p)) - (let ((info (value current-eval-server))) - (cond - ((not info) - (message "Describing from the editor Lisp ...") - (editor-describe-symbol-command nil)) - (t - (with-mark ((mark1 (current-point)) - (mark2 (current-point))) - (mark-symbol mark1 mark2) - (with-pop-up-display (s) - (write-string (eval-form-in-server-1 - info - (format nil "(ed::describe-symbol-aux '~A)" - (region-to-string (region mark1 mark2)))) - s))))))) - -(defun describe-symbol-aux (thing) - (with-output-to-string (*standard-output*) - (describe (if (and (consp thing) - (or (eq (car thing) 'quote) - (eq (car thing) 'function)) - (symbolp (cadr thing))) - (cadr thing) - thing)))) diff --git a/hemlock/lispmode.lisp b/hemlock/lispmode.lisp deleted file mode 100644 index 99978ec810765a142808503b5f4ca803fee304be..0000000000000000000000000000000000000000 --- a/hemlock/lispmode.lisp +++ /dev/null @@ -1,1453 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock LISP Mode commands -;;; -;;; Written by Ivan Vazquez and Bill Maddox. -;;; - -(in-package "HEMLOCK") - - - -;;;; #### VARIABLES #### -;;; -;;; These routines are used to define, for standard LISP mode, the start and end -;;; of a block to parse. If these need to be changed for a minor mode that sits -;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the -;;; name of the function to use instead of START-OF-PARSE-BLOCK and -;;; END-OF-PARSE-BLOCK. -;;; - -(defhvar "Parse Start Function" - "Take a mark and move it to the top of a block for paren parsing." - :value 'start-of-parse-block) - -(defhvar "Parse End Function" - "Take a mark and move it to the bottom of a block for paren parsing." - :value 'end-of-parse-block) - - -;;;; #### STRUCTURES #### -;;; -;;; LISP-INFO is the structure used to store the data about the line in its Plist. -;;; -;;; -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether -;;; or not a line's begining and/or ending are quoted. -;;; -;;; -> RANGES-TO-IGNORE is a list of cons cells, each having the form -;;; ( [begining-charpos] [end-charpos] ) each of these cells indicating -;;; a range to ignore. End is exclusive. -;;; -;;; -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of -;;; unmatched opening and closing parens that there are on a line. -;;; -;;; -> SIGNATURE-SLOT ... -;;; - -(defstruct (lisp-info (:constructor make-lisp-info ())) - (begins-quoted nil) ; (or t nil) - (ending-quoted nil) ; (or t nil) - (ranges-to-ignore nil) ; (or t nil) - (net-open-parens 0 :type fixnum) - (net-close-parens 0 :type fixnum) - (signature-slot)) - - - -;;;; #### MACROS #### -;;; -;;; The following Macros exist to make it easy to acces the Syntax primitives -;;; without uglifying the code. They were originally written by Maddox. -;;; - -(defmacro scan-char (mark attribute values) - `(find-attribute ,mark ',attribute ,(attr-predicate values))) - -(defmacro rev-scan-char (mark attribute values) - `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values))) - -(defmacro test-char (char attribute values) - `(let ((x (character-attribute ',attribute ,char))) - ,(attr-predicate-aux values))) - -(eval-when (compile load eval) -(defun attr-predicate (values) - (cond ((eq values 't) - '#'plusp) - ((eq values 'nil) - '#'zerop) - (t `#'(lambda (x) ,(attr-predicate-aux values))))) - -(defun attr-predicate-aux (values) - (cond ((eq values t) - '(plusp x)) - ((eq values nil) - '(zerop x)) - ((symbolp values) - `(eq x ',values)) - ((and (listp values) (member (car values) '(and or not))) - (cons (car values) (mapcar #'attr-predicate-aux (cdr values)))) - (t (error "Illegal form in attribute pattern - ~S" values)))) - -); Eval-When (Compile Load Eval) - -;;; -;;; FIND-LISP-CHAR - -(defmacro find-lisp-char (mark) - "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL." - `(find-attribute ,mark :lisp-syntax - #'(lambda (x) - (member x '(:open-paren :close-paren :newline :comment - :char-quote :string-quote))))) -;;; -;;; PUSH-RANGE - -(defmacro push-range (new-range info-struct) - "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT." - `(when ,new-range - (setf (lisp-info-ranges-to-ignore ,info-struct) - (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct))))) -;;; -;;; SCAN-DIRECTION - -(defmacro scan-direction (mark forwardp &rest forms) - "Expand to a form that scans either backward or forward according to Forwardp." - (if forwardp - `(scan-char ,mark ,@forms) - `(rev-scan-char ,mark ,@forms))) -;;; -;;; DIRECTION-CHAR - -(defmacro direction-char (mark forwardp) - "Expand to a form that returns either the previous or next character according - to Forwardp." - (if forwardp - `(next-character ,mark) - `(previous-character ,mark))) - -;;; -;;; NEIGHBOR-MARK - -(defmacro neighbor-mark (mark forwardp) - "Expand to a form that moves MARK either backward or forward one character, - depending on FORWARDP." - (if forwardp - `(mark-after ,mark) - `(mark-before ,mark))) - -;;; -;;; NEIGHBOR-LINE - -(defmacro neighbor-line (line forwardp) - "Expand to return the next or previous line, according to Forwardp." - (if forwardp - `(line-next ,line) - `(line-previous ,line))) - - -;;;; #### PARSING FUNCTIONS ### -;;; -;;; PRE-COMMAND-PARSE-CHECK - -(defun pre-command-parse-check (mark &optional (fer-sure-parse nil)) - "Parse the area before the command is actually executed." - (with-mark ((top mark) - (bottom mark)) - (funcall (value parse-start-function) top) - (funcall (value parse-end-function) bottom) - (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse))) - -;;; -;;; PARSE-OVER-BLOCK - -(defun parse-over-block (start-line end-line &optional (fer-sure-parse nil)) - "Parse over an area indicated from END-LINE to START-LINE." - (let ((test-line start-line) - prev-line-info) - - (with-mark ((mark (mark test-line 0))) - - ; Set the pre-begining and post-ending lines to delimit the range - ; of action any command will take. This means set the lisp-info of the - ; lines immediately before and after the block to Nil. - - (when (line-previous start-line) - (setf (getf (line-plist (line-previous start-line)) 'lisp-info) nil)) - (when (line-next end-line) - (setf (getf (line-plist (line-next end-line)) 'lisp-info) nil)) - - (loop - (let ((line-info (getf (line-plist test-line) 'lisp-info))) - - ;; Reparse the line when any of the following are true: - ;; - ;; FER-SURE-PARSE is T - ;; - ;; LINE-INFO or PREV-LINE-INFO are Nil. - ;; - ;; If the line begins quoted and the previous one wasn't - ;; ended quoted. - ;; - ;; The Line's signature slot is invalid (the line has changed). - ;; - - (when (or fer-sure-parse - (not line-info) - (not prev-line-info) - - (not (eq (lisp-info-begins-quoted line-info) - (lisp-info-ending-quoted prev-line-info))) - - (not (eql (line-signature test-line) - (lisp-info-signature-slot line-info)))) - - (move-to-position mark 0 test-line) - - (unless line-info - (setf line-info (make-lisp-info)) - (setf (getf (line-plist test-line) 'lisp-info) line-info)) - - (parse-lisp-line-info mark line-info prev-line-info)) - - (when (eq end-line test-line) - (return nil)) - - (setq prev-line-info line-info) - - (setq test-line (line-next test-line))))))) - - -;;;; #### PARSE BLOCK FINDERS #### -;;; - -(defhvar "Minimum Lines Parsed" - "The minimum number of lines before and after the point parsed by Lisp mode." - :value 50) -(defhvar "Maximum Lines Parsed" - "The maximum number of lines before and after the point parsed by Lisp mode." - :value 500) -(defhvar "Defun Parse Goal" - "Lisp mode parses the region obtained by skipping this many defuns forward - and backward from the point unless this falls outside of the range specified - by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"." - :value 2) - - -(macrolet ((frob (step end) - `(let ((min (value minimum-lines-parsed)) - (max (value maximum-lines-parsed)) - (goal (value defun-parse-goal)) - (last-defun nil)) - (declare (fixnum min max goal)) - (do ((line (mark-line mark) (,step line)) - (count 0 (1+ count))) - ((null line) - (,end mark)) - (declare (fixnum count)) - (when (char= (line-character line 0) #\() - (setq last-defun line) - (decf goal) - (when (and (<= goal 0) (>= count min)) - (line-start mark line) - (return))) - (when (> count max) - (line-start mark (or last-defun line)) - (return)))))) - - (defun start-of-parse-block (mark) - (frob line-previous buffer-start)) - - (defun end-of-parse-block (mark) - (frob line-next buffer-end))) - -;;; -;;; START-OF-SEARCH-LINE - -(defun start-of-search-line (line) - "Set LINE to the begining line of the block of text to parse." - (with-mark ((mark (mark line 0))) - (funcall (value 'Parse-Start-Function) mark) - (setq line (mark-line mark)))) - -;;; -;;; END-OF-SEACH-LINE - -(defun end-of-search-line (line) - "Set LINE to the ending line of the block of text to parse." - (with-mark ((mark (mark line 0))) - (funcall (value 'Parse-End-Function) mark) - (setq line (mark-line mark)))) - - -;;; PARSE-LISP-LINE-INFO parses through the line doing the following things: -;;; -;;; Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS. -;;; -;;; Making all areas of the line that should be invalid (comments, -;;; char-quotes, and the inside of strings) and such be in -;;; RANGES-TO-IGNORE. -;;; -;;; Set BEGINS-QUOTED and ENDING-QUOTED -;;; - -(defun parse-lisp-line-info (mark line-info prev-line-info) - "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS, -RANGES-TO-INGORE, and ENDING-QUOTED." - (let ((net-open-parens 0) - (net-close-parens 0)) - (declare (fixnum net-open-parens net-close-parens)) - - ;; Re-set the slots necessary - - (setf (lisp-info-ranges-to-ignore line-info) nil) - - ;; The only way the current line begins quoted is when there - ;; is a previous line and it's ending was quoted. - - (setf (lisp-info-begins-quoted line-info) - (and prev-line-info - (lisp-info-ending-quoted prev-line-info))) - - (if (lisp-info-begins-quoted line-info) - (deal-with-string-quote mark line-info) - (setf (lisp-info-ending-quoted line-info) nil)) - - (unless (lisp-info-ending-quoted line-info) - (loop - (find-lisp-char mark) - (ecase (character-attribute :lisp-syntax (next-character mark)) - - (:open-paren - (setq net-open-parens (1+ net-open-parens)) - (mark-after mark)) - - (:close-paren - (if (zerop net-open-parens) - (setq net-close-parens (1+ net-close-parens)) - (setq net-open-parens (1- net-open-parens))) - (mark-after mark)) - - (:newline - (setf (lisp-info-ending-quoted line-info) nil) - (return t)) - - (:comment - (push-range (cons (mark-charpos mark) (line-length (mark-line mark))) - line-info) - (setf (lisp-info-ending-quoted line-info) nil) - (return t)) - - (:char-quote - (mark-after mark) - (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark))) - line-info) - (mark-after mark)) - - (:string-quote - (mark-after mark) - (unless (deal-with-string-quote mark line-info) - (setf (lisp-info-ending-quoted line-info) t) - (return t)))))) - - (setf (lisp-info-net-open-parens line-info) net-open-parens) - (setf (lisp-info-net-close-parens line-info) net-close-parens) - (setf (lisp-info-signature-slot line-info) - (line-signature (mark-line mark))))) - -;;;; #### STRING QUOTE UTILITIES #### -;;; -;;; - -;;; -;;; VALID-STRING-QUOTE-P - -(defmacro valid-string-quote-p (mark forwardp) - "Return T if the string-quote indicated by MARK is valid." - (let ((test-mark (gensym))) - `(with-mark ((,test-mark ,mark)) - - ,(unless forwardp ; TEST-MARK should always be right before the - `(mark-before ,test-mark)) ; String-quote to be checked. - - (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote) - - (let ((slash-count 0)) - - (loop - (mark-before ,test-mark) - (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote) - (incf slash-count) - (return t))) - (not (oddp slash-count))))))) - -;;; -;;; FIND-VALID-STRING-QUOTE - -(defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil)) - "Expand to a form that will leave MARK before a valid string-quote character, - in either a forward or backward direction, according to FORWARDP. If - CEASE-AT-EOL is T then it will return nil if encountering the EOL before a - valid string-quote." - (let ((e-mark (gensym))) - `(with-mark ((,e-mark ,mark)) - - (loop - (unless (scan-direction ,e-mark ,forwardp :lisp-syntax - ,(if cease-at-eol - `(or :newline :string-quote) - `:string-quote)) - (return nil)) - - ,@(if cease-at-eol - `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax - :newline) - (return nil)))) - - (when (valid-string-quote-p ,e-mark ,forwardp) - (move-mark ,mark ,e-mark) - (return t)) - - (neighbor-mark ,e-mark ,forwardp))))) - -;;; DEAL-WITH-STRING-QUOTE -;;; -;;; Called when a string is begun (i.e. parse hits a #\"). It checks for a -;;; matching quote on the line that MARK points to, and puts the -;;; appropriate area in the RANGES-TO-IGNORE slot and leaves MARK pointing -;;; after this area. The "appropriate area" is from MARK to the end of the -;;; line or the matching string-quote, whichever comes first. - -(defun deal-with-string-quote (mark info-struct) - "Alter the current line's info struct as necessary as due to encountering a -string quote character." - (with-mark ((e-mark mark)) - - (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t) - - ;; If matching quote is on this line then mark the area between - ;; the first quote (MARK) and the matching quote as invalid by - ;; pushing its begining and ending into the IGNORE-RANGE. - - (push-range (cons (mark-charpos mark) (mark-charpos e-mark)) - info-struct) - - (setf (lisp-info-ending-quoted info-struct) nil) - (mark-after e-mark) - (move-mark mark e-mark)) - - ;; If the EOL has been hit before the matching quote then mark - ;; the area from MARK to the EOL as invalid. - - (t - (push-range (cons (mark-charpos mark) (1+ (line-length (mark-line mark)))) - info-struct) - - ;; The Ending is marked as still being quoted. - - (setf (lisp-info-ending-quoted info-struct) t) - (line-end mark) - nil)))) - - -;;;; Character validity checking: - -;;; Find-Ignore-Region -- Internal -;;; -;;; If the character in the specified direction from Mark is in an ignore -;;; region, then return the region and the line that the region is in as -;;; values. If there is no ignore region, then return NIL and the Mark-Line. -;;; If the line is not parsed, or there is no character (because of being at -;;; the buffer beginning or end), then return both values NIL. -;;; -(defun find-ignore-region (mark forwardp) - (declare (fixnum pos)) - (flet ((scan (line pos) - (declare (fixnum pos)) - (let ((info (getf (line-plist line) 'lisp-info))) - (if info - (dolist (range (lisp-info-ranges-to-ignore info) - (values nil line)) - (let ((start (car range)) - (end (cdr range))) - (declare (fixnum start end)) - (when (and (>= pos start) (< pos end)) - (return (values range line))))) - (values nil nil))))) - (let ((pos (mark-charpos mark)) - (line (mark-line mark))) - (declare (fixnum pos)) - (cond (forwardp (scan line pos)) - ((> pos 0) (scan line (1- pos))) - (t - (let ((prev (line-previous line))) - (if prev - (scan prev (line-length prev)) - (values nil nil)))))))) - - -;;; Valid-Spot -- Public -;;; -(defun valid-spot (mark forwardp) - "Return true if the character pointed to by Mark is not in a quoted context, - false otherwise. If Forwardp is true, we use the next character, otherwise - we use the previous." - (multiple-value-bind (region line) - (find-ignore-region mark forwardp) - (and line (not region)))) - - -;;; Scan-Direction-Valid -- Internal -;;; -;;; Like scan-direction, but only stop on valid characters. -;;; -(defmacro scan-direction-valid (mark forwardp &rest forms) - (let ((n-mark (gensym)) - (n-line (gensym)) - (n-region (gensym)) - (n-won (gensym))) - `(let ((,n-mark ,mark) (,n-won nil)) - (loop - (multiple-value-bind (,n-region ,n-line) - (find-ignore-region ,n-mark ,forwardp) - (unless ,n-line (return nil)) - (if ,n-region - (move-to-position ,n-mark - ,(if forwardp - `(cdr ,n-region) - `(car ,n-region)) - ,n-line) - (when ,n-won (return t))) - ;; - ;; Peculiar condition when a quoting character terminates a line. - ;; The ignore region is off the end of the line causing %FORM-OFFSET - ;; to infinitely loop. - (when (> (mark-charpos ,n-mark) (line-length ,n-line)) - (line-offset ,n-mark 1 0)) - (unless (scan-direction ,n-mark ,forwardp ,@forms) - (return nil)) - (setq ,n-won t)))))) - - -;;;; #### LIST-OFFSETING #### -;;; -;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built -;;; with the same existing structure, with the altering of one variable. -;;; This one variable being FORWARDP. -;;; -(defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) ) - "Expand to code that will go forward one list either backward or forward, -according to the FORWARDP flag." - (let ((mark (gensym))) - `(let ((paren-count ,extra-parens)) - (declare (fixnum paren-count)) - (with-mark ((,mark ,actual-mark)) - (loop - (scan-direction ,mark ,forwardp :lisp-syntax - (or :close-paren :open-paren :newline)) - (let ((ch (direction-char ,mark ,forwardp))) - (unless ch (return nil)) - (when (valid-spot ,mark ,forwardp) - (case (character-attribute :lisp-syntax ch) - (:close-paren - (decf paren-count) - ,(when forwardp ; When going forward, an unmatching - `(when (<= paren-count 0) ; close-paren means the end of list. - (neighbor-mark ,mark ,forwardp) - (move-mark ,actual-mark ,mark) - (return t)))) - (:open-paren - (incf paren-count) - ,(unless forwardp ; Same as above only end of list - `(when (>= paren-count 0) ; is opening parens. - (neighbor-mark ,mark ,forwardp) - (move-mark ,actual-mark ,mark) - (return t)))) - - (:newline - ;; When a #\Newline is hit, then the matching paren must lie on - ;; some other line so drop down into the multiple line balancing - ;; function: QUEST-FOR-BALANCING-PAREN - ;; If no paren seen yet, keep going. - (cond ((zerop paren-count)) - ((quest-for-balancing-paren ,mark paren-count ,forwardp) - (move-mark ,actual-mark ,mark) - (return t)) - (t - (return nil))))))) - - (neighbor-mark ,mark ,forwardp)))))) - -;;; -;;; QUEST-FOR-BALANCING-PAREN - -(defmacro quest-for-balancing-paren (mark paren-count forwardp) - "Expand to a form that finds the the balancing paren for however many opens or - closes are registered by Paren-Count." - `(let* ((line (mark-line ,mark))) - (loop - (setq line (neighbor-line line ,forwardp)) - (unless line (return nil)) - (let ((line-info (getf (line-plist line) 'lisp-info)) - (unbal-paren ,paren-count)) - (unless line-info (return nil)) - - ,(if forwardp - `(decf ,paren-count (lisp-info-net-close-parens line-info)) - `(incf ,paren-count (lisp-info-net-open-parens line-info))) - - (when ,(if forwardp - `(<= ,paren-count 0) - `(>= ,paren-count 0)) - ,(if forwardp - `(line-start ,mark line) - `(line-end ,mark line)) - (return (goto-correct-paren-char ,mark unbal-paren ,forwardp))) - - ,(if forwardp - `(incf ,paren-count (lisp-info-net-open-parens line-info)) - `(decf ,paren-count (lisp-info-net-close-parens line-info))))))) - - -;;; -;;; GOTO-CORRECT-PAREN-CHAR - -(defmacro goto-correct-paren-char (mark paren-count forwardp) - "Expand to a form that will leave MARK on the correct balancing paren matching - however many are indicated by COUNT." - `(with-mark ((m ,mark)) - (let ((count ,paren-count)) - (loop - (scan-direction m ,forwardp :lisp-syntax - (or :close-paren :open-paren :newline)) - (when (valid-spot m ,forwardp) - (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp)) - (:close-paren - (decf count) - ,(when forwardp - `(when (zerop count) - (neighbor-mark m ,forwardp) - (move-mark ,mark m) - (return t)))) - - (:open-paren - (incf count) - ,(unless forwardp - `(when (zerop count) - (neighbor-mark m ,forwardp) - (move-mark ,mark m) - (return t)))))) - (neighbor-mark m ,forwardp))))) - - -(defun list-offset (mark offset) - (if (plusp offset) - (dotimes (i offset t) - (unless (%list-offset mark t) (return nil))) - (dotimes (i (- offset) t) - (unless (%list-offset mark nil) (return nil))))) - -(defun forward-up-list (mark) - "Moves mark just past the closing paren of the immediately containing list." - (%list-offset mark t :extra-parens 1)) - -(defun backward-up-list (mark) - "Moves mark just before the opening paren of the immediately containing list." - (%list-offset mark nil :extra-parens -1)) - - - -;;;; Top level form location hacks (open parens beginning lines). - -;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET. -;;; -(eval-when (compile eval) -(defmacro neighbor-top-level (line forwardp) - `(loop - (when (test-char (line-character ,line 0) :lisp-syntax :open-paren) - (return t)) - (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line))) - (unless ,line (return nil)))) -) ;eval-when - -(defun top-level-offset (mark offset) - "Go forward or backward offset number of top level forms. Mark is - returned if offset forms exists, otherwise nil." - (declare (fixnum offset)) - (let* ((line (mark-line mark)) - (at-start (test-char (line-character line 0) :lisp-syntax :open-paren))) - (cond ((zerop offset) mark) - ((plusp offset) - (do ((offset (if at-start offset (1- offset)) - (1- offset))) - (nil) - (declare (fixnum offset)) - (unless (neighbor-top-level line t) (return nil)) - (when (zerop offset) (return (line-start mark line))) - (unless (setf line (line-next line)) (return nil)))) - (t - (do ((offset (if (and at-start (start-line-p mark)) - offset - (1+ offset)) - (1+ offset))) - (nil) - (declare (fixnum offset)) - (unless (neighbor-top-level line nil) (return nil)) - (when (zerop offset) (return (line-start mark line))) - (unless (setf line (line-previous line)) (return nil))))))) - - -(defun mark-top-level-form (mark1 mark2) - "Moves mark1 and mark2 to the beginning and end of the current or next defun. - Mark1 one is used as a reference. The marks may be altered even if - unsuccessful. if successful, return mark2, else nil." - (let ((winp (cond ((inside-defun-p mark1) - (cond ((not (top-level-offset mark1 -1)) nil) - ((not (form-offset (move-mark mark2 mark1) 1)) nil) - (t mark2))) - ((start-defun-p mark1) - (form-offset (move-mark mark2 mark1) 1)) - ((and (top-level-offset (move-mark mark2 mark1) -1) - (start-defun-p mark2) - (form-offset mark2 1) - (same-line-p mark1 mark2)) - (form-offset (move-mark mark1 mark2) -1) - mark2) - ((top-level-offset mark1 1) - (form-offset (move-mark mark2 mark1) 1))))) - (when winp - (when (blank-after-p mark2) (line-offset mark2 1 0)) - mark2))) - -(defun inside-defun-p (mark) - "T if the current point is (supposedly) in a top level form." - (with-mark ((m mark)) - (when (top-level-offset m -1) - (form-offset m 1) - (mark> m mark)))) - -(defun start-defun-p (mark) - "Returns t if mark is sitting before an :open-paren at the beginning of a - line." - (and (start-line-p mark) - (test-char (next-character mark) :lisp-syntax :open-paren))) - - - -;;;; #### FORM OFFSETING #### - -(defmacro %form-offset (mark forwardp) - `(with-mark ((m ,mark)) - (when (scan-direction-valid m ,forwardp :lisp-syntax - (or :open-paren :close-paren - :char-quote :string-quote - :constituent)) - (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp)) - (:open-paren - (when ,(if forwardp `(list-offset m 1) `(mark-before m)) - ,(unless forwardp - '(scan-direction m nil :lisp-syntax (not :prefix))) - (move-mark ,mark m) - t)) - (:close-paren - (when ,(if forwardp `(mark-after m) `(list-offset m -1)) - ,(unless forwardp - '(scan-direction m nil :lisp-syntax (not :prefix))) - (move-mark ,mark m) - t)) - ((:constituent :char-quote) - (scan-direction-valid m ,forwardp :lisp-syntax - (not (or :constituent :char-quote))) - ,(if forwardp - `(scan-direction-valid m t :lisp-syntax - (not (or :constituent :char-quote))) - `(scan-direction-valid m nil :lisp-syntax - (not (or :constituent :char-quote - :prefix)))) - (move-mark ,mark m) - t) - (:string-quote - (cond ((valid-spot m ,(not forwardp)) - (neighbor-mark m ,forwardp) - (when (scan-direction-valid m ,forwardp :lisp-syntax - :string-quote) - (neighbor-mark m ,forwardp) - (move-mark ,mark m) - t)) - (t (neighbor-mark m ,forwardp) - (move-mark ,mark m) - t))))))) - - -(defun form-offset (mark offset) - "Move mark offset number of forms, after if positive, before if negative. - Mark is always moved. If there weren't enough forms, returns nil instead of - mark." - (if (plusp offset) - (dotimes (i offset t) - (unless (%form-offset mark t) (return nil))) - (dotimes (i (- offset) t) - (unless (%form-offset mark nil) (return nil))))) - - - -;;; Table of special forms with special indenting requirements. - - -(defhvar "Indent Defanything" - "This is the number of special arguments implicitly assumed to be supplied - in calls to functions whose names begin with \"DEF\". If set to NIL, this - feature is disabled." - :value 2) - -(defvar *special-forms* (make-hash-table :test #'equal)) - -(defun defindent (fname args) - "Define Fname to have Args special arguments. If args is null then remove - any special arguments information." - (check-type fname string) - (let ((fname (string-upcase fname))) - (cond ((null args) (remhash fname *special-forms*)) - (t - (check-type args integer) - (setf (gethash fname *special-forms*) args))))) - - -;;; Hemlock forms. -;;; -(defindent "with-mark" 1) -(defindent "with-random-typeout" 1) -(defindent "with-pop-up-display" 1) -(defindent "defhvar" 1) -(defindent "hlet" 1) -(defindent "defcommand" 2) -(defindent "defattribute" 1) -(defindent "command-case" 1) -(defindent "with-input-from-region" 1) -(defindent "with-output-to-mark" 1) -(defindent "with-output-to-window" 1) -(defindent "do-strings" 1) -(defindent "save-for-undo" 1) -(defindent "do-alpha-chars" 1) -(defindent "do-headers-buffers" 1) -(defindent "do-headers-lines" 1) -(defindent "with-headers-mark" 1) -(defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill. -(defindent "with-writable-buffer" 1) - -;;; Common Lisp forms. -;;; -(defindent "block" 1) -(defindent "case" 1) -(defindent "catch" 1) -(defindent "ccase" 1) -(defindent "compiler-let" 1) -(defindent "ctypecase" 1) -(defindent "defconstant" 1) -(defindent "define-setf-method" 2) -(defindent "defmacro" 2) -(defindent "defparameter" 1) -(defindent "defstruct" 1) -(defindent "deftype" 2) -(defindent "defun" 2) -(defindent "defvar" 1) -(defindent "do" 2) -(defindent "do*" 2) -(defindent "do-all-symbols" 1) -(defindent "do-external-symbols" 1) -(defindent "do-symbols" 1) -(defindent "dolist" 1) -(defindent "dotimes" 1) -(defindent "ecase" 1) -(defindent "etypecase" 1) -(defindent "eval-when" 1) -(defindent "flet" 1) -(defindent "labels" 1) -(defindent "lambda" 1) -(defindent "let" 1) -(defindent "let*" 1) -(defindent "loop" 0) -(defindent "macrolet" 1) -(defindent "multiple-value-bind" 2) -(defindent "multiple-value-call" 1) -(defindent "multiple-value-prog1" 1) -(defindent "multiple-value-setq" 1) -(defindent "prog1" 1) -(defindent "progv" 2) -(defindent "progn" 0) -(defindent "typecase" 1) -(defindent "unless" 1) -(defindent "unwind-protect" 1) -(defindent "when" 1) -(defindent "with-input-from-string" 1) -(defindent "with-open-file" 1) -(defindent "with-open-stream" 1) -(defindent "with-output-to-string" 1) - -;;; Error/condition system forms. -;;; -(defindent "define-condition" 2) -(defindent "handler-bind" 1) -(defindent "handler-case" 1) -(defindent "restart-bind" 1) -(defindent "restart-case" 1) -(defindent "with-simple-restart" 1) -;;; These are for RESTART-CASE branch formatting. -(defindent "store-value" 1) -(defindent "use-value" 1) -(defindent "muffle-warning" 1) -(defindent "abort" 1) -(defindent "continue" 1) - -;;; Xlib forms. -;;; -(defindent "with-gcontext" 1) -(defindent "xlib:with-gcontext" 1) -(defindent "with-state" 1) -(defindent "xlib:with-state" 1) -(defindent "with-display" 1) -(defindent "xlib:with-display" 1) -(defindent "with-event-queue" 1) -(defindent "xlib:with-event-queue" 1) -(defindent "with-server-grabbed" 1) -(defindent "xlib:with-server-grabbed" 1) -(defindent "event-case" 1) -(defindent "xlib:event-case" 1) - -;;; CLOS forms. -;;; -(defindent "with-slots" 1) -(defindent "with-slots*" 2) -(defindent "with-accessors*" 2) -(defindent "defclass" 2) - -;;; System forms. -;;; -(defindent "alien-bind" 1) -(defindent "def-c-record" 1) -(defindent "defrecord" 1) - - - -;;; Compute number of spaces which mark should be indented according to -;;; local context and lisp grinding conventions. - -(defun lisp-indentation (mark) - (with-mark ((m mark) - (temp mark)) - (unless (valid-spot m nil) - (return-from lisp-indentation - (lisp-generic-indentation m))) - (unless (backward-up-list m) - (return-from lisp-indentation 0)) - (mark-after m) - (with-mark ((start m)) - (unless (and (scan-char m :lisp-syntax (not (or :space :prefix :char-quote))) - (test-char (next-character m) :lisp-syntax :constituent)) - (return-from lisp-indentation (mark-column start))) - (with-mark ((fstart m)) - (scan-char m :lisp-syntax (not :constituent)) - (let* ((fname (nstring-upcase (region-to-string (region fstart m)))) - (special-args (or (gethash fname *special-forms*) - (and (> (length fname) 2) - (string= fname "DEF" :end1 3) - (value indent-defanything))))) - (declare (simple-string fname)) - (cond (special-args - (with-mark ((spec m)) - (cond ((and (form-offset spec special-args) - (mark<= spec mark)) - (1+ (mark-column start))) - ((skip-valid-space m) - (mark-column m)) - (t - (+ (mark-column start) 3))))) - ((and (form-offset temp -1) - (or (blank-before-p temp) - (not (same-line-p temp fstart))) - (not (same-line-p temp mark))) - (unless (blank-before-p temp) - (line-start temp) - (find-attribute temp :space #'zerop)) - (mark-column temp)) - ((skip-valid-space m) - (mark-column m)) - (t - (mark-column start)))))))) - -(defun lisp-generic-indentation (mark) - (let* ((line (mark-line mark)) - (prev (do ((line (line-previous line) (line-previous line))) - ((or (null line) (not (blank-line-p line))) line)))) - (cond (prev - (line-start mark prev) - (find-attribute mark :space #'zerop) - (mark-column mark)) - (t 0)))) - -;;; Skip-Valid-Space -- Internal -;;; -;;; Skip over any space on the line Mark is on, stopping at the first valid -;;; non-space character. If there is none on the line, return nil. -;;; -(defun skip-valid-space (mark) - (loop - (scan-char mark :lisp-syntax (not :space)) - (let ((val (character-attribute :lisp-syntax - (next-character mark)))) - (cond ((eq val :newline) (return nil)) - ((valid-spot mark t) (return mark)))) - (mark-after mark))) - - -;;;; LISP Mode commands - -(defcommand "Defindent" (p) - "Define the Lisp indentation for the current function. - The indentation is a non-negative integer which is the number - of special arguments for the form. Examples: 2 for Do, 1 for Dolist. - If a prefix argument is supplied, then delete the indentation information." - "Do a defindent, man!" - (declare (ignore p)) - (with-mark ((m (current-point))) - (pre-command-parse-check m) - (unless (backward-up-list m) (editor-error)) - (mark-after m) - (with-mark ((n m)) - (scan-char n :lisp-syntax (not :constituent)) - (let ((s (region-to-string (region m n)))) - (declare (simple-string s)) - (when (zerop (length s)) (editor-error)) - (if p - (defindent s nil) - (let ((i (prompt-for-integer - :prompt (format nil "Indentation for ~A: " s) - :help "Number of special arguments."))) - (when (minusp i) - (editor-error "Indentation must be non-negative.")) - (defindent s i)))))) - (indent-command ())) - -(defcommand "Beginning of Defun" (p) - "Move the point to the beginning of a top-level form. - with an argument, skips the previous p top-level forms." - "Move the point to the beginning of a top-level form." - (let ((point (current-point)) - (count (or p 1))) - (pre-command-parse-check point) - (if (minusp count) - (end-of-defun-command (- count)) - (unless (top-level-offset point (- count)) - (editor-error))))) - -;;; "End of Defun", with a positive p (the normal case), does something weird. -;;; Get a mark at the beginning of the defun, and then offset it forward one -;;; less top level form than we want. This sets us up to use FORM-OFFSET which -;;; allows us to leave the point immediately after the defun. If we used -;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current -;;; defun, point would be left at the beginning of the p+1'st form instead of -;;; at the end of the p'th form. -;;; -(defcommand "End of Defun" (p) - "Move the point to the end of a top-level form. - With an argument, skips the next p top-level forms." - "Move the point to the end of a top-level form." - (let ((point (current-point)) - (count (or p 1))) - (pre-command-parse-check point) - (if (minusp count) - (beginning-of-defun-command (- count)) - (with-mark ((m point) - (dummy point)) - (cond ((not (mark-top-level-form m dummy)) - (editor-error "No current or next top level form.")) - (t - (unless (top-level-offset m (1- count)) - (editor-error "Not enough top level forms.")) - ;; We might be one unparsed for away. - (pre-command-parse-check m) - (unless (form-offset m 1) - (editor-error "Not enough top level forms.")) - (when (blank-after-p m) (line-offset m 1 0)) - (move-mark point m))))))) - -(defcommand "Forward List" (p) - "Skip over the next Lisp list. - With argument, skips the next p lists." - "Skip over the next Lisp list." - (let ((point (current-point)) - (count (or p 1))) - (pre-command-parse-check point) - (unless (list-offset point count) (editor-error)))) - -(defcommand "Backward List" (p) - "Skip over the previous Lisp list. - With argument, skips the previous p lists." - "Skip over the previous Lisp list." - (let ((point (current-point)) - (count (- (or p 1)))) - (pre-command-parse-check point) - (unless (list-offset point count) (editor-error)))) - -(defcommand "Forward Form" (p) - "Skip over the next Form. - With argument, skips the next p Forms." - "Skip over the next Form." - (let ((point (current-point)) - (count (or p 1))) - (pre-command-parse-check point) - (unless (form-offset point count) (editor-error)))) - -(defcommand "Backward Form" (p) - "Skip over the previous Form. - With argument, skips the previous p Forms." - "Skip over the previous Form." - (let ((point (current-point)) - (count (- (or p 1)))) - (pre-command-parse-check point) - (unless (form-offset point count) (editor-error)))) - -(defcommand "Mark Form" (p) - "Set the mark at the end of the next Form. - With a positive argument, set the mark after the following p - Forms. With a negative argument, set the mark before - the preceding -p Forms." - "Set the mark at the end of the next Form." - (with-mark ((m (current-point))) - (pre-command-parse-check m) - (let ((count (or p 1)) - (mark (push-buffer-mark (copy-mark m) t))) - (if (form-offset m count) - (move-mark mark m) - (editor-error))))) - -(defcommand "Mark Defun" (p) - "Puts the region around the next or containing top-level form. - The point is left before the form and the mark is placed immediately - after it." - "Puts the region around the next or containing top-level form." - (declare (ignore p)) - (let ((point (current-point))) - (pre-command-parse-check point) - (with-mark ((start point) - (end point)) - (cond ((not (mark-top-level-form start end)) - (editor-error "No current or next top level form.")) - (t - (move-mark point start) - (move-mark (push-buffer-mark (copy-mark point) t) end)))))) - -(defcommand "Forward Kill Form" (p) - "Kill the next Form. - With a positive argument, kills the next p Forms. - Kills backward with a negative argument." - "Kill the next Form." - (with-mark ((m1 (current-point)) - (m2 (current-point))) - (pre-command-parse-check m1) - (let ((count (or p 1))) - (unless (form-offset m1 count) (editor-error)) - (if (minusp count) - (kill-region (region m1 m2) :kill-backward) - (kill-region (region m2 m1) :kill-forward))))) - -(defcommand "Backward Kill Form" (p) - "Kill the previous Form. - With a positive argument, kills the previous p Forms. - Kills forward with a negative argument." - "Kill the previous Form." - (forward-kill-form-command (- (or p 1)))) - -(defcommand "Extract List" (p) - "Extract the current list. - The current list replaces the surrounding list. The entire affected - area is pushed on the kill-ring. With prefix argument, remove that - many surrounding lists." - "Replace the P containing lists with the current one." - (let ((point (current-point))) - (pre-command-parse-check point) - (with-mark ((lstart point :right-inserting) - (lend point)) - (if (eq (character-attribute :lisp-syntax (next-character lstart)) - :open-paren) - (mark-after lend) - (unless (backward-up-list lstart) (editor-error))) - (unless (forward-up-list lend) (editor-error)) - (with-mark ((rstart lstart) - (rend lend)) - (dotimes (i (or p 1)) - (unless (and (forward-up-list rend) (backward-up-list rstart)) - (editor-error))) - (let ((r (copy-region (region lstart lend)))) - (ring-push (delete-and-save-region (region rstart rend)) - *kill-ring*) - (ninsert-region point r) - (move-mark point lstart)))))) - -(defcommand "Transpose Forms" (p) - "Transpose Forms immediately preceding and following the point. - With a zero argument, tranposes the Forms at the point and the mark. - With a positive argument, transposes the Form preceding the point - with the p-th one following it. With a negative argument, transposes the - Form following the point with the p-th one preceding it." - "Transpose Forms immediately preceding and following the point." - (let ((point (current-point)) - (count (or p 1))) - (pre-command-parse-check point) - (if (zerop count) - (let ((mark (current-mark))) - (with-mark ((s1 mark :left-inserting) - (s2 point :left-inserting)) - (scan-char s1 :whitespace nil) - (scan-char s2 :whitespace nil) - (with-mark ((e1 s1 :right-inserting) - (e2 s2 :right-inserting)) - (unless (form-offset e1 1) (editor-error)) - (unless (form-offset e2 1) (editor-error)) - (ninsert-region s1 (delete-and-save-region (region s2 e2))) - (ninsert-region s2 (delete-and-save-region (region s1 e1)))))) - (let ((fcount (if (plusp count) count 1)) - (bcount (if (plusp count) 1 count))) - (with-mark ((s1 point :left-inserting) - (e2 point :right-inserting)) - (dotimes (i bcount) - (unless (form-offset s1 -1) (editor-error))) - (dotimes (i fcount) - (unless (form-offset e2 1) (editor-error))) - (with-mark ((e1 s1 :right-inserting) - (s2 e2 :left-inserting)) - (unless (form-offset e1 1) (editor-error)) - (unless (form-offset s2 -1) (editor-error)) - (ninsert-region s1 (delete-and-save-region (region s2 e2))) - (ninsert-region s2 (delete-and-save-region (region s1 e1))) - (move-mark point s2))))))) - - -(defcommand "Indent Form" (p) - "Indent Lisp code in the next form." - "Indent Lisp code in the next form." - (declare (ignore p)) - (let ((point (current-point))) - (pre-command-parse-check point) - (with-mark ((m point)) - (unless (form-offset m 1) (editor-error)) - (lisp-indent-region (region point m) "Indent Form")))) - -;;; LISP-INDENT-REGION indents a region of Lisp code without doing excessive -;;; redundant computation. We parse the entire region once, then scan through -;;; doing indentation on each line. We forcibly reparse each line that we -;;; indent so that the list operations done to determine indentation of -;;; subsequent lines will work. This is done undoably with save1, save2, -;;; buf-region, and undo-region. -;;; -(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting")) - (check-region-query-size region) - (let ((start (region-start region)) - (end (region-end region))) - (with-mark ((m1 start) - (m2 end)) - (funcall (value parse-start-function) m1) - (funcall (value parse-end-function) m2) - (parse-over-block (mark-line m1) (mark-line m2))) - (let* ((first-line (mark-line start)) - (last-line (mark-line end)) - (prev (line-previous first-line)) - (prev-line-info - (and prev (getf (line-plist prev) 'lisp-info))) - (save1 (line-start (copy-mark start :right-inserting))) - (save2 (line-end (copy-mark end :left-inserting))) - (buf-region (region save1 save2)) - (undo-region (copy-region buf-region))) - (with-mark ((bol start :left-inserting)) - (do ((line first-line (line-next line))) - (nil) - (line-start bol line) - (insert-lisp-indentation bol) - (let ((line-info (getf (line-plist line) 'lisp-info))) - (parse-lisp-line-info bol line-info prev-line-info) - (setq prev-line-info line-info)) - (when (eq line last-line) (return nil)))) - (make-region-undo :twiddle undo-text buf-region undo-region)))) - -;;; INDENT-FOR-LISP is the value of "Indent Function" for "Lisp" mode. -;;; -(defun indent-for-lisp (mark) - (line-start mark) - (pre-command-parse-check mark) - (insert-lisp-indentation mark)) - -(defun insert-lisp-indentation (m) - (delete-horizontal-space m) - (funcall (value indent-with-tabs) m (lisp-indentation m))) - - -(defcommand "Insert ()" (p) - "Insert a pair of parentheses (). - With positive argument, puts parentheses around the next p - Forms. The point is positioned after the open parenthesis." - "Insert a pair of parentheses ()." - (let ((point (current-point)) - (count (or p 0))) - (pre-command-parse-check point) - (cond ((not (minusp count)) - (insert-character point #\() - (with-mark ((tmark point)) - (unless (form-offset tmark count) (editor-error)) - (cond ((mark= tmark point) - (insert-character point #\)) - (mark-before point)) - (t (insert-character tmark #\)))))) - (t (editor-error))))) - - -(defcommand "Move Over )" (p) - "Move past the next close parenthesis, and start a new line. - Any indentation preceding the preceding the parenthesis is deleted, - and the new line is indented." - "Move past the next close parenthesis, and start a new line." - (declare (ignore p)) - (let ((point (current-point))) - (pre-command-parse-check point) - (with-mark ((m point)) - (cond ((scan-char m :lisp-syntax :close-paren) - (delete-horizontal-space m) - (mark-after m) - (move-mark point m) - (indent-new-line-command 1)) - (t (editor-error)))))) - - -(defcommand "Forward Up List" (p) - "Move forward past a one containing )." - "Move forward past a one containing )." - (let ((point (current-point)) - (count (or p 1))) - (pre-command-parse-check point) - (if (minusp count) - (backward-up-list-command (- count)) - (with-mark ((m point)) - (dotimes (i count (move-mark point m)) - (unless (forward-up-list m) (editor-error))))))) - - -(defcommand "Backward Up List" (p) - "Move backward past a one containing (." - "Move backward past a one containing (." - (let ((point (current-point)) - (count (or p 1))) - (pre-command-parse-check point) - (if (minusp count) - (forward-up-list-command (- count)) - (with-mark ((m point)) - (dotimes (i count (move-mark point m)) - (unless (backward-up-list m) (editor-error))))))) - - -(defcommand "Down List" (p) - "Move down a level in list structure. - With argument, moves down p levels." - "Move down a level in list structure." - (let ((point (current-point)) - (count (or p 1))) - (pre-command-parse-check point) - (with-mark ((m point)) - (dotimes (i count (move-mark point m)) - (unless (and (scan-char m :lisp-syntax :open-paren) - (mark-after m)) - (editor-error)))))) - - - -;;;; "Lisp Mode". - -(defcommand "LISP Mode" (p) - "Put current buffer in LISP mode." - "Put current buffer in LISP mode." - (declare (ignore p)) - (setf (buffer-major-mode (current-buffer)) "LISP")) - - -(defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode) - -(defun setup-lisp-mode (buffer) - (unless (hemlock-bound-p 'current-package :buffer buffer) - (defhvar "Current Package" - "The package used for evaluation of Lisp in this buffer." - :buffer buffer - :value "USER"))) - - - -;;;; Matching parenthesis display. - -(defhvar "Paren Pause Period" - "This is how long commands that deal with \"brackets\" shows the cursor at - the matching \"bracket\" for this number of seconds." - :value 0.5) - -(defcommand "Lisp Insert )" (p) - "Inserts a \")\" and briefly positions the cursor at the matching \"(\"." - "Inserts a \")\" and briefly positions the cursor at the matching \"(\"." - (declare (ignore p)) - (let ((point (current-point))) - (insert-character point #\)) - (pre-command-parse-check point) - (when (valid-spot point nil) - (with-mark ((m point)) - (if (list-offset m -1) - (let ((pause (value paren-pause-period)) - (win (current-window))) - (if pause - (unless (show-mark m win pause) - (clear-echo-area) - (message "~A" (line-string (mark-line m)))) - (unless (displayed-p m (current-window)) - (clear-echo-area) - (message "~A" (line-string (mark-line m)))))) - (editor-error)))))) - -;;; Since we use paren highlighting in Lisp mode, we do not want paren -;;; flashing too. -;;; -(defhvar "Paren Pause Period" - "This is how long commands that deal with \"brackets\" shows the cursor at - the matching \"bracket\" for this number of seconds." - :value nil - :mode "Lisp") -;;; -(defhvar "Highlight Open Parens" - "When non-nil, causes open parens to be displayed in a different font when - the cursor is directly to the right of the corresponding close paren." - :value t - :mode "Lisp") - - - -;;;; Some mode variables to coordinate with other stuff. - -(defhvar "Auto Fill Space Indent" - "When non-nil, uses \"Indent New Comment Line\" to break lines instead of - \"New Line\"." - :mode "Lisp" :value t) - -(defhvar "Comment Start" - "String that indicates the start of a comment." - :mode "Lisp" :value ";") - -(defhvar "Comment Begin" - "String that is inserted to begin a comment." - :mode "Lisp" :value "; ") - -(defhvar "Indent Function" - "Indentation function which is invoked by \"Indent\" command. - It must take one argument that is the prefix argument." - :value 'indent-for-lisp - :mode "Lisp") diff --git a/hemlock/macros.lisp b/hemlock/macros.lisp deleted file mode 100644 index f29561c5522a04c41c0e0153ab655ae85d589a4e..0000000000000000000000000000000000000000 --- a/hemlock/macros.lisp +++ /dev/null @@ -1,665 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains most of the junk that needs to be in the compiler -;;; to compile Hemlock commands. -;;; -;;; Written by Rob MacLachlin and Bill Chiles. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(invoke-hook value setv hlet string-to-variable add-hook remove-hook - defcommand with-mark use-buffer editor-error - editor-error-format-string editor-error-format-arguments do-strings - command-case reprompt with-output-to-mark with-input-from-region - handle-lisp-errors with-pop-up-display *random-typeout-buffers*)) - - - -;;;; Macros used for manipulating Hemlock variables. - -(defmacro invoke-hook (place &rest args) - "Call the functions in place with args. If place is a symbol, then this - interprets it as a Hemlock variable rather than a Lisp variable, using its - current value as the list of functions." - (let ((f (gensym))) - `(dolist (,f ,(if (symbolp place) `(%value ',place) place)) - (funcall ,f ,@args)))) - -(defmacro value (name) - "Return the current value of the Hemlock variable name." - `(%value ',name)) - -(defmacro setv (name new-value) - "Set the current value of the Hemlock variable name, calling any hook - functions with new-value before setting the value." - `(%set-value ',name ,new-value)) - -;;; WITH-VARIABLE-OBJECT -- Internal -;;; -;;; Look up the variable object for name and bind it to obj, giving error -;;; if there is no such variable. -;;; -(defmacro with-variable-object (name &body forms) - `(let ((obj (get ,name 'hemlock-variable-value))) - (unless obj (undefined-variable-error ,name)) - ,@forms)) - -(defmacro hlet (binds &rest forms) - "Hlet ({Var Value}*) {Form}* - Similar to Let, only it creates temporary Hemlock variable bindings. Each - of the vars have the corresponding value during the evaluation of the - forms." - (let ((lets ()) - (sets ()) - (unsets ())) - (dolist (bind binds) - (let ((n-obj (gensym)) - (n-val (gensym)) - (n-old (gensym))) - (push `(,n-val ,(second bind)) lets) - (push `(,n-old (variable-object-value ,n-obj)) lets) - (push `(,n-obj (with-variable-object ',(first bind) obj)) lets) - (push `(setf (variable-object-value ,n-obj) ,n-val) sets) - (push `(setf (variable-object-value ,n-obj) ,n-old) unsets))) - `(let* ,lets - (unwind-protect - (progn ,@sets nil ,@forms) - ,@unsets)))) - - - -;;;; A couple funs to hack strings to symbols. - -(eval-when (compile load eval) - -(defun bash-string-to-symbol (name suffix) - (intern (nsubstitute #\- #\space - (nstring-upcase - (concatenate 'simple-string - name (symbol-name suffix)))))) - -;;; string-to-variable -- Exported -;;; -;;; Return the symbol which corresponds to the string name -;;; "string". -(defun string-to-variable (string) - (intern (nsubstitute #\- #\space - (the simple-string (string-upcase string))) - (find-package "HEMLOCK"))) - -); eval-when (compile load eval) - -;;; string-to-keyword -- Internal -;;; -;;; Mash a string into a Keyword. -;;; -(defun string-to-keyword (string) - (intern (nsubstitute #\- #\space - (the simple-string (string-upcase string))) - (find-package "KEYWORD"))) - - - -;;;; Macros to add and delete hook functions. - -;;; add-hook -- Exported -;;; -;;; Add a hook function to a hook, defining a variable if -;;; necessary. -;;; -(defmacro add-hook (place hook-fun) - "Add-Hook Place Hook-Fun - Add Hook-Fun to the list stored in Place. If place is a symbol then it - it is interpreted as a Hemlock variable rather than a Lisp variable." - (if (symbolp place) - `(pushnew ,hook-fun (value ,place)) - `(pushnew ,hook-fun ,place))) - -;;; remove-hook -- Public -;;; -;;; Delete a hook-function from somewhere. -;;; -(defmacro remove-hook (place hook-fun) - "Remove-Hook Place Hook-Fun - Remove Hook-Fun from the list in Place. If place is a symbol then it - it is interpreted as a Hemlock variable rather than a Lisp variable." - (if (symbolp place) - `(setf (value ,place) (delete ,hook-fun (value ,place))) - `(setf ,place (delete ,hook-fun ,place)))) - - - -;;;; DEFCOMMAND. - -;;; Defcommand -- Public -;;; -(defmacro defcommand (name lambda-list command-doc function-doc - &body forms) - "Defcommand Name Lambda-List Command-Doc Function-Doc {Declaration}* {Form}* - - Define a new Hemlock command named Name. Lambda-List becomes the - lambda-list, Function-Doc the documentation, and the Forms the - body of the function which implements the command. The first - argument, which must be present, is the prefix argument. The name - of this function is derived by replacing all spaces in the name with - hyphens and appending \"-COMMAND\". Command-Doc becomes the - documentation for the command. See the command implementor's manual - for further details. - - An example: - (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.\" - (unless (character-offset (buffer-point (current-buffer)) (or p 1)) - (editor-error)))" - - (unless (stringp function-doc) - (error "Command function documentation is not a string: ~S." - function-doc)) - (when (atom lambda-list) - (error "Command argument list is not a list: ~S." lambda-list)) - (let (command-name function-name) - (cond ((listp name) - (setq command-name (car name) function-name (cadr name)) - (unless (symbolp function-name) - (error "Function name is not a symbol: ~S" function-name))) - (t - (setq command-name name - function-name (bash-string-to-symbol name '-COMMAND)))) - (unless (stringp command-name) - (error "Command name is not a string: ~S." name)) - `(eval-when (load eval) - (defun ,function-name ,lambda-list ,function-doc ,@forms) - (make-command ',name ,command-doc ',function-name) - ',function-name))) - - - -;;;; PARSE-FORMS - -;;; Parse-Forms -- Internal -;;; -;;; Used for various macros to get the declarations out of a list of -;;; forms. -;;; -(eval-when (compile load eval) -(defmacro parse-forms ((decls-var forms-var forms) &body gorms) - "Parse-Forms (Decls-Var Forms-Var Forms) {Form}* - Binds Decls-Var to leading declarations off of Forms and Forms-Var - to what is left." - `(do ((,forms-var ,forms (cdr ,forms-var)) - (,decls-var ())) - ((or (atom ,forms-var) (atom (car ,forms-var)) - (not (eq (caar ,forms-var) 'declare))) - ,@gorms) - (push (car ,forms-var) ,decls-var))) -) - - - -;;;; WITH-MARK and USE-BUFFER. - -(defmacro with-mark (mark-bindings &rest forms) - "With-Mark ({(Mark Pos [Kind])}*) {declaration}* {form}* - With-Mark binds a variable named Mark to a mark specified by Pos. This - mark is :temporary, or of kind Kind. The forms are then evaluated." - (do ((bindings mark-bindings (cdr bindings)) - (let-slots ()) - (cleanup ())) - ((null bindings) - (if cleanup - (parse-forms (decls forms forms) - `(let ,(nreverse let-slots) - ,@decls - (unwind-protect - (progn ,@forms) - ,@cleanup))) - `(let ,(nreverse let-slots) ,@forms))) - (let ((name (caar bindings)) - (pos (cadar bindings)) - (type (or (caddar bindings) :temporary))) - (cond ((not (eq type :temporary)) - (push `(,name (copy-mark ,pos ,type)) let-slots) - (push `(delete-mark ,name) cleanup)) - (t - (push `(,name (copy-mark ,pos :temporary)) let-slots)))))) - -#|SAve this shit in case we want WITH-MARKto no longer cons marks. -(defconstant with-mark-total 50) -(defvar *with-mark-free-marks* (make-array with-mark-total)) -(defvar *with-mark-next* 0) - -(defmacro with-mark (mark-bindings &rest forms) - "WITH-MARK ({(Mark Pos [Kind])}*) {declaration}* {form}* - WITH-MARK evaluates each form with each Mark variable bound to a mark - specified by the respective Pos, a mark. The created marks are of kind - :temporary, or of kind Kind." - (do ((bindings mark-bindings (cdr bindings)) - (let-slots ()) - (cleanup ())) - ((null bindings) - (let ((old-next (gensym))) - (parse-forms (decls forms forms) - `(let ((*with-mark-next* *with-mark-next*) - (,old-next *with-mark-next*)) - (let ,(nreverse let-slots) - ,@decls - (unwind-protect - (progn ,@forms) - ,@cleanup)))))) - (let ((name (caar bindings)) - (pos (cadar bindings)) - (type (or (caddar bindings) :temporary))) - (push `(,name (mark-for-with-mark ,pos ,type)) let-slots) - (if (eq type :temporary) - (push `(delete-mark ,name) cleanup) - ;; Assume mark is on free list and drop its hold on data. - (push `(setf (mark-line ,name) nil) cleanup))))) - -;;; MARK-FOR-WITH-MARK -- Internal. -;;; -;;; At run time of a WITH-MARK form, this returns an appropriate mark at the -;;; position mark of type kind. First it uses one from the vector of free -;;; marks, possibly storing one in the vector if we need more marks than we -;;; have before, and that need is still less than the total free marks we are -;;; willing to hold onto. If we're over the free limit, just make one for -;;; throwing away. -;;; -(defun mark-for-with-mark (mark kind) - (let* ((line (mark-line mark)) - (charpos (mark-charpos mark)) - (mark (cond ((< *with-mark-next* with-mark-total) - (let ((m (svref *with-mark-free-marks* *with-mark-next*))) - (cond ((markp m) - (setf (mark-line m) line) - (setf (mark-charpos m) charpos) - (setf (mark-%kind m) kind)) - (t - (setf m (internal-make-mark line charpos kind)) - (setf (svref *with-mark-free-marks* - *with-mark-next*) - m))) - (incf *with-mark-next*) - m)) - (t (internal-make-mark line charpos kind))))) - (unless (eq kind :temporary) - (push mark (line-marks (mark-line mark)))) - mark)) -|# - -(defmacro use-buffer (buffer &body forms) - "Use-Buffer Buffer {Form}* - Has The effect of making Buffer the current buffer during the evaluation - of the Forms. For restrictions see the manual." - (let ((gensym (gensym))) - `(let ((,gensym *current-buffer*) - (*current-buffer* ,buffer)) - (unwind-protect - (progn - (use-buffer-set-up ,gensym) - ,@forms) - (use-buffer-clean-up ,gensym))))) - - - -;;;; EDITOR-ERROR. - -(defun print-editor-error (condx s) - (apply #'format s (editor-error-format-string condx) - (editor-error-format-arguments condx))) - -(define-condition editor-error (error) - ((format-string "") - (format-arguments '())) - (:report print-editor-error)) -;;; -(setf (documentation 'editor-error-format-string 'function) - "Returns the FORMAT control string of the given editor-error condition.") -(setf (documentation 'editor-error-format-arguments 'function) - "Returns the FORMAT arguments for the given editor-error condition.") - -(defun editor-error (&rest 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 SIGNAL's an editor-error condition formed from args. 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 - args were supplied, it also invokes MESSAGE on them. The command in - progress is always aborted, and this function never returns." - (let ((condx (make-condition 'editor-error - :format-string (car args) - :format-arguments (cdr args)))) - (signal condx) - (error "Unhandled editor-error was signaled -- ~A." condx))) - - - -;;;; Do-Strings - -(defmacro do-strings ((string-var value-var table &optional result) &body forms) - "Do-Strings (String-Var Value-Var Table [Result]) {declaration}* {form}* - Iterate over the strings in a String Table. String-Var and Value-Var - are bound to the string and value respectively of each successive entry - in the string-table Table in alphabetical order. If supplied, Result is - a form to evaluate to get the return value." - (let ((value-nodes (gensym)) - (num-nodes (gensym)) - (value-node (gensym)) - (i (gensym))) - `(let ((,value-nodes (string-table-value-nodes ,table)) - (,num-nodes (string-table-num-nodes ,table))) - (dotimes (,i ,num-nodes ,result) - (declare (fixnum ,i)) - (let* ((,value-node (svref ,value-nodes ,i)) - (,value-var (value-node-value ,value-node)) - (,string-var (value-node-proper ,value-node))) - (declare (simple-string ,string-var)) - ,@forms))))) - - - -;;;; COMMAND-CASE - -;;; Command-Case -- Public -;;; -;;; Grovel the awful thing and spit out the corresponding Cond. See Echo -;;; for the definition of command-case-help and logical char stuff. -;;; -(eval-when (compile load eval) -(defun command-case-tag (tag char) - (cond ((and (characterp tag) (standard-char-p tag)) - `(char= ,char ,(char-upcase tag))) - ((and (symbolp tag) (keywordp tag)) - `(logical-char= ,char ,tag)) - (t - (error "Tag in Command-Case is not a standard character or keyword:~S" - tag)))) -); eval-when (compile load eval) -;;; -(defmacro command-case ((&key (change-window t) character - (prompt "Command character: ") - (help "Choose one of the following characters:") - (bind (gensym))) - &body forms) - (do* ((forms forms (cdr forms)) - (form (car forms) (car forms)) - (cases ()) - (bname (gensym)) - (upper (gensym)) - (again (gensym)) - (n-prompt (gensym)) - (n-change (gensym)) - (docs ()) - (t-case `(t (beep) (reprompt)))) - ((atom forms) - `(macrolet ((reprompt () - `(progn - (setq ,',bind (prompt-for-character* - ,',n-prompt ,',n-change)) - (go ,',AGAIN)))) - (block ,bname - (let* ((,n-prompt ,prompt) - (,n-change ,change-window) - (,bind ,(or character - `(prompt-for-character* ,n-prompt ,n-change)))) - (tagbody - ,AGAIN - (let ((,upper (char-upcase ,bind))) - (return-from - ,bname - (cond - ,@(nreverse cases) - ((logical-char= ,upper :abort) (editor-error)) - ((logical-char= ,upper :help) - (command-case-help ,help ',(nreverse docs)) - (reprompt)) - ,t-case)))))))) - - (cond ((atom form) - (error "Malformed Command-Case clause: ~S" form)) - ((eq (car form) t) - (setq t-case form)) - ((or (< (length form) 2) - (not (stringp (second form)))) - (error "Malformed Command-Case clause: ~S" form)) - (t - (let ((tag (car form)) - (rest (cddr form))) - (cond ((atom tag) - (push (cons (command-case-tag tag upper) rest) cases) - (setq tag (list tag))) - (t - (do ((tag tag (cdr tag)) - (res () (cons (command-case-tag (car tag) upper) res))) - ((null tag) - (push `((or ,@res) . ,rest) cases))))) - (push (cons tag (second form)) docs)))))) - - - -;;;; Some random macros used everywhere. - -(defmacro strlen (str) `(length (the simple-string ,str))) -(defmacro neq (a b) `(not (eq ,a ,b)))) - - - -;;;; Stuff from here on is implementation dependant. - - - -;;;; WITH-INPUT & WITH-OUTPUT macros. - -(defvar *free-hemlock-output-streams* () - "This variable contains a list of free Hemlock output streams.") - -(defmacro with-output-to-mark ((var mark &optional (buffered ':line)) - &body gorms) - "With-Output-To-Mark (Var Mark [Buffered]) {Declaration}* {Form}* - During the evaluation of Forms, Var is bound to a stream which inserts - output at the permanent mark Mark. Buffered is the same as for - Make-Hemlock-Output-Stream." - (parse-forms (decls forms gorms) - `(let ((,var (pop *free-hemlock-output-streams*))) - ,@decls - (if ,var - (modify-hemlock-output-stream ,var ,mark ,buffered) - (setq ,var (make-hemlock-output-stream ,mark ,buffered))) - (unwind-protect - (progn ,@forms) - (setf (hemlock-output-stream-mark ,var) nil) - (push ,var *free-hemlock-output-streams*))))) - -(defvar *free-hemlock-region-streams* () - "This variable contains a list of free Hemlock input streams.") - -(defmacro with-input-from-region ((var region) &body gorms) - "With-Input-From-Region (Var Region) {Declaration}* {Form}* - During the evaluation of Forms, Var is bound to a stream which - returns input from Region." - (parse-forms (decls forms gorms) - `(let ((,var (pop *free-hemlock-region-streams*))) - ,@decls - (if ,var - (setq ,var (modify-hemlock-region-stream ,var ,region)) - (setq ,var (make-hemlock-region-stream ,region))) - (unwind-protect - (progn ,@forms) - (delete-mark (hemlock-region-stream-mark ,var)) - (push ,var *free-hemlock-region-streams*))))) - - -(defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout")) - &body (body decls)) - "Execute body in a context with var bound to a stream. Output to the stream - appears in the buffer named buffer-name. The pop-up display appears after - the body completes, but if you supply :height, the output is line buffered, - displaying any current output after each line." - (when (and (numberp height) (zerop height)) - (editor-error "I doubt that you really want a window with no height")) - (let ((cleanup-p (gensym)) - (stream (gensym))) - `(let ((,cleanup-p nil) - (,stream (get-random-typeout-info ,buffer-name ,height))) - (unwind-protect - (progn - (catch 'more-punt - ,(when height - ;; Test height since it may be supplied, but evaluate - ;; to nil. - `(when ,height - (prepare-for-random-typeout ,stream ,height) - (setf ,cleanup-p t))) - (let ((,var ,stream)) - ,@decls - (multiple-value-prog1 - (progn ,@body) - (unless ,height - (prepare-for-random-typeout ,stream nil) - (setf ,cleanup-p t) - (funcall (device-random-typeout-full-more - (device-hunk-device - (window-hunk - (random-typeout-stream-window ,stream)))) - ,stream)) - (end-random-typeout ,var)))) - (setf ,cleanup-p nil)) - (when ,cleanup-p (random-typeout-cleanup ,stream)))))) - -(proclaim '(special *random-typeout-ml-fields* *buffer-names*)) - -(defvar *random-typeout-buffers* () "A list of random-typeout buffers.") - -(defun get-random-typeout-info (buffer-name line-buffered-p) - (let* ((buffer (getstring buffer-name *buffer-names*)) - (stream - (cond - ((not buffer) - (let* ((buf (make-buffer - buffer-name - :modes '("Fundamental") - :modeline-fields *random-typeout-ml-fields* - :delete-hook - (list #'(lambda (buffer) - (setq *random-typeout-buffers* - (delete buffer *random-typeout-buffers* - :key #'car)))))) - (point (buffer-point buf)) - (stream (make-random-typeout-stream - (copy-mark point :left-inserting)))) - (setf (random-typeout-stream-more-mark stream) - (copy-mark point :right-inserting)) - (push (cons buf stream) *random-typeout-buffers*) - stream)) - ((member buffer *random-typeout-buffers* :key #'car) - (delete-region (buffer-region buffer)) - (let* ((pair (assoc buffer *random-typeout-buffers*)) - (stream (cdr pair))) - (setf *random-typeout-buffers* - (cons pair (delete pair *random-typeout-buffers*))) - (setf (random-typeout-stream-first-more-p stream) t) - (setf (random-typeout-stream-no-prompt stream) nil) - stream)) - (t - (error "~A is not a random typeout buffer." - (buffer-name buffer)))))) - (if line-buffered-p - (setf (random-typeout-stream-out stream) #'random-typeout-line-out - (random-typeout-stream-sout stream) #'random-typeout-line-sout - (random-typeout-stream-misc stream) #'random-typeout-line-misc) - (setf (random-typeout-stream-out stream) #'random-typeout-full-out - (random-typeout-stream-sout stream) #'random-typeout-full-sout - (random-typeout-stream-misc stream) #'random-typeout-full-misc)) - stream)) - - - -;;;; Error handling stuff. - -(proclaim '(special *echo-area-stream*)) - -;;; LISP-ERROR-ERROR-HANDLER is in Macros.Lisp instead of Rompsite.Lisp because -;;; it uses WITH-POP-UP-DISPLAY, and Macros is compiled after Rompsite. It -;;; binds an error condition handler to get us out of here on a recursive error -;;; (we are already handling one if we are here). Since COMMAND-CASE uses -;;; EDITOR-ERROR for logical :abort characters, and this is a subtype of ERROR, -;;; we bind an editor-error condition handler just inside of the error handler. -;;; This keeps us from being thrown out into the debugger with supposedly -;;; recursive errors occuring. What we really want in this case is to simply -;;; get back to the command loop and forget about the error we are currently -;;; handling. -;;; -(defun lisp-error-error-handler (condition &optional internalp) - (handler-bind ((editor-error #'(lambda (condx) - (declare (ignore condx)) - (beep) - (throw 'command-loop-catcher nil))) - (error #'(lambda (condition) - (declare (ignore condition)) - (let ((device (device-hunk-device - (window-hunk (current-window))))) - (funcall (device-exit device) device)) - (invoke-debugger - (make-condition - 'simple-condition - :format-string - "Error in error handler; Hemlock broken."))))) - (clear-echo-area) - (clear-input *editor-input*) - (beep) - (if internalp (write-string "Internal error: " *echo-area-stream*)) - (princ condition *echo-area-stream*) - (let* ((*editor-input* *real-editor-input*) - (ch (read-char *editor-input*))) - (if (char= ch #\?) - (loop - (command-case (:prompt "Debug: " - :help - "Type one of the Hemlock debug command characters:") - ((#\D #\d) "Enter a break loop." - (let ((device (device-hunk-device - (window-hunk (current-window))))) - (funcall (device-exit device) device) - (unwind-protect - (with-simple-restart - (continue "Return to Hemlock's debug loop.") - (invoke-debugger condition)) - (funcall (device-init device) device)))) - (#\B "Do a stack backtrace." - (with-pop-up-display (*debug-io* :height 100) - (debug:backtrace))) - (#\E "Show the error." - (with-pop-up-display (*standard-output*) - (princ condition))) - ((#\Q :exit) "Throw back to Hemlock top-level." - (throw 'editor-top-level-catcher nil)) - ((#\r #\R) "Try to restart from this error." - (let ((cases (compute-restarts))) - (declare (list cases)) - (with-pop-up-display (s :height (1+ (length cases))) - (debug::show-restarts cases s)) - (invoke-restart-interactively - (nth (prompt-for-integer :prompt "Restart number: ") - cases)))))) - (unread-char ch *editor-input*)) - (throw 'editor-top-level-catcher nil)))) - -(defmacro handle-lisp-errors (&body body) - "Handle-Lisp-Errors {Form}* - If a Lisp error happens during the evaluation of the body, then it is - handled in some fashion. This should be used by commands which may - get a Lisp error due to some action of the user." - `(handler-bind ((error #'lisp-error-error-handler)) - ,@body)) diff --git a/hemlock/main.lisp b/hemlock/main.lisp deleted file mode 100644 index 3a84d807637224c81f8e6fef80e469caed9330db..0000000000000000000000000000000000000000 --- a/hemlock/main.lisp +++ /dev/null @@ -1,357 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock initialization code and random debugging stuff. -;;; -;;; Written by Bill Chiles and Rob MacLachlan -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(*global-variable-names* *mode-names* *buffer-names* - *character-attribute-names* *command-names* *buffer-list* - *window-list* *editor-input* *last-character-typed* - *character-history* after-editor-initializations)) - - -(in-package "EXTENSIONS") -(export '(save-all-buffers *hemlock-version*)) -(in-package "HEMLOCK-INTERNALS") - - - -;;;; Definition of *hemlock-version*. - -(defvar *hemlock-version* "1.1(?)") - - - -;;;; %INIT-HEMLOCK. - -(defun %init-hemlock () - "Initialize hemlock's internal data structures." - ;; - ;; This function is defined in Buffer.Lisp. It creates fundamental mode - ;; and the buffer main. Until this is done it is not possible to define - ;; or use Hemlock variables. - (setup-initial-buffer) - ;; - ;; Define some of the system variables. - (define-some-variables) - ;; - ;; Site initializations such as window system variables. - (site-init) - ;; - ;; Set up syntax table data structures. - (%init-syntax-table) - ;; - ;; Define print representations for funny characters. - (%init-line-image)) - - - -;;;; Define some globals. - -;;; These globals cannot be defined in the appropriate file due to compilation -;;; or load time constraints. -;;; - -;;; The following belong in other files, but those files are loaded before -;;; table.lisp which defines MAKE-STRING-TABLE. -;;; -;;; vars.lisp -(defvar *global-variable-names* (make-string-table) - "A String Table of global variable names, the values are the symbol names.") -;;; -;;; buffer.lisp -(defvar *mode-names* (make-string-table) "A String Table of Mode names.") -(defvar *buffer-names* (make-string-table) - "A String Table of Buffer names and their corresponding objects.") -;;; -;;; interp.lisp -(defvar *command-names* (make-string-table) "String table of command names.") -;;; -;;; syntax.lisp -(defvar *character-attribute-names* (make-string-table) - "String Table of character attribute names and their corresponding keywords.") - - - -;;;; DEFINE-SOME-VARIABLES. - -;;; This is necessary to define "Default Status Line Fields" which belongs -;;; beside the other modeline variables. This DEFVAR would live in -;;; Morecoms.Lisp, but it is compiled and loaded after this file. -;;; -(proclaim '(special ed::*recursive-edit-count*)) -;;; -(make-modeline-field - :name :edit-level :width 15 - :function #'(lambda (buffer window) - (declare (ignore buffer window)) - (if (zerop ed::*recursive-edit-count*) - "" - (format nil "Edit Level: ~2,'0D " - ed::*recursive-edit-count*)))) - -;;; This is necessary to define "Default Status Line Fields" which belongs -;;; beside the other modeline variables. This DEFVAR would live in -;;; Completion.Lisp, but it is compiled and loaded after this file. -;;; -(proclaim '(special ed::*completion-mode-possibility*)) -;;; Hack for now until completion mode is added. -(defvar ed::*completion-mode-possibility* "") -;;; -(make-modeline-field - :name :completion :width 40 - :function #'(lambda (buffer window) - (declare (ignore buffer window)) - ed::*completion-mode-possibility*)) - - -(defun define-some-variables () - (defhvar "Default Modes" - "This variable contains the default list of modes for new buffers." - :value '("Fundamental" "Save")) - (defhvar "Echo Area Height" - "Number of lines in the echo area window." - :value 3) - (defhvar "Make Buffer Hook" - "This hook is called with the new buffer whenever a buffer is created.") - (defhvar "Delete Buffer Hook" - "This hook is called with the buffer whenever a buffer is deleted.") - (defhvar "Enter Recursive Edit Hook" - "This hook is called with the new buffer when a recursive edit is - entered.") - (defhvar "Exit Recursive Edit Hook" - "This hook is called with the value returned when a recursive edit - is exited.") - (defhvar "Abort Recursive Edit Hook" - "This hook is called with the editor-error args when a recursive - edit is aborted.") - (defhvar "Buffer Major Mode Hook" - "This hook is called with the buffer and the new mode when a buffer's - major mode is changed.") - (defhvar "Buffer Minor Mode Hook" - "This hook is called a minor mode is changed. The arguments are - the buffer, the mode affected and T or NIL depending on when the - mode is being turned on or off.") - (defhvar "Buffer Writable Hook" - "This hook is called whenever someone sets whether the buffer is - writable.") - (defhvar "Buffer Name Hook" - "This hook is called with the buffer and the new name when the name of a - buffer is changed.") - (defhvar "Buffer Pathname Hook" - "This hook is called with the buffer and the new Pathname when the Pathname - associated with the buffer is changed.") - (defhvar "Buffer Modified Hook" - "This hook is called whenever a buffer changes from unmodified to modified - and vice versa. It takes the buffer and the new value for modification - flag.") - (defhvar "Set Buffer Hook" - "This hook is called with the new buffer when the current buffer is set.") - (defhvar "After Set Buffer Hook" - "This hook is invoked with the old buffer after the current buffer has - been changed.") - (defhvar "Set Window Hook" - "This hook is called with the new window when the current window - is set.") - (defhvar "Make Window Hook" - "This hook is called with a new window when one is created.") - (defhvar "Delete Window Hook" - "This hook is called with a window before it is deleted.") - (defhvar "Window Buffer Hook" - "This hook is invoked with the window and new buffer when a window's - buffer is changed.") - (defhvar "Delete Variable Hook" - "This hook is called when a variable is deleted with the args to - delete-variable.") - (defhvar "Entry Hook" - "this hook is called when the editor is entered.") - (defhvar "Exit Hook" - "This hook is called when the editor is exited.") - (defhvar "Redisplay Hook" - "This is called on the current window from REDISPLAY after checking the - window display start, window image, and recentering. After calling the - functions in this hook, we do the above stuff and call the smart - redisplay method for the device." - :value nil) - (defhvar "Key Echo Delay" - "Wait this many seconds before echoing keys in the command loop. This - feature is inhibited when nil." - :value 1.0) - (defhvar "Input Hook" - "The functions in this variable are invoked each time a character enters - Hemlock." - :value nil) - (defhvar "Abort Hook" - "These functions are invoked when ^G is typed. No arguments are passed." - :value nil) - (defhvar "Command Abort Hook" - "These functions get called when commands are aborted, such as with - EDITOR-ERROR." - :value nil) - (defhvar "Character Attribute Hook" - "This hook is called with the attribute, character and new value - when the value of a character attribute is changed.") - (defhvar "Shadow Attribute Hook" - "This hook is called when a mode character attribute is made.") - (defhvar "Unshadow Attribute Hook" - "This hook is called when a mode character attribute is deleted.") - (defhvar "Default Modeline Fields" - "The default list of modeline-fields for MAKE-WINDOW." - :value *default-modeline-fields*) - (defhvar "Default Status Line Fields" - "This is the default list of modeline-fields for the echo area window's - modeline which is used for general information." - :value (list (make-modeline-field - :name :hemlock-banner :width 26 - :function #'(lambda (buffer window) - (declare (ignore buffer window)) - (format nil "Hemlock ~A " - *hemlock-version*))) - (modeline-field :edit-level) - (modeline-field :completion))) - (defhvar "Maximum Modeline Pathname Length" - "When set, this variable is the maximum length of the display of a pathname - in a modeline. When the pathname is too long, the :buffer-pathname - modeline-field function chops off leading directory specifications until - the pathname fits. \"...\" indicates a truncated pathname." - :value nil - :hooks (list 'maximum-modeline-pathname-length-hook))) - - - -;;;; ED. - -(defvar *editor-has-been-entered* () - "True if and only if the editor has been entered.") -(defvar *in-the-editor* () - "True if we are inside the editor. This is used to prevent ill-advised - \"recursive\" edits.") - -(defvar *after-editor-initializations-funs* nil - "A list of functions to be called after the editor has been initialized upon - entering the first time.") - -(defmacro after-editor-initializations (&rest forms) - "Causes forms to be executed after the editor has been initialized. - Forms supplied with successive uses of this macro will be executed after - forms supplied with previous uses." - `(push #'(lambda () ,@forms) - *after-editor-initializations-funs*)) - -(defun ed (&optional x - &key (init t) - (display (cdr (assoc :display ext:*environment-list*)))) - "Invokes the editor, Hemlock. If X is supplied and is a symbol, the - definition of X is put into a buffer, and that buffer is selected. If X - is a pathname, the file specified by X is visited in a new buffer. If X - is not supplied or Nil, the editor is entered in the same state as when - last exited. When :init is supplied as t (the default), the file - \"hemlock-init.fasl\" or \"hemlock-init.lisp\" is loaded from the home or - default directory, but the Lisp command line switch -hinit can be used to - specify a different name. If the argument is non-nil and not t, then it - should be a pathname that will be merged with the home or default directory. - The display argument is not currently supported." - (when *in-the-editor* (error "You are already in the editor, you bogon!")) - (let ((*in-the-editor* t) - (display (unless *editor-has-been-entered* - (maybe-load-hemlock-init init) - ;; Device dependent initializaiton. - (init-raw-io display)))) - (catch 'editor-top-level-catcher - (site-wrapper-macro - (unless *editor-has-been-entered* - ;; Make an initial window, and set up redisplay's internal - ;; data structures. - (%init-redisplay display) - (setq *editor-has-been-entered* t) - ;; Pick up user initializations to be done after initialization. - (invoke-hook (reverse *after-editor-initializations-funs*))) - (catch 'hemlock-exit - (catch 'editor-top-level-catcher - (cond ((and x (symbolp x)) - (let* ((name (nstring-capitalize - (concatenate 'simple-string "Edit " (string x)))) - (buffer (or (getstring name *buffer-names*) - (make-buffer name))) - (*print-case* :downcase)) - (delete-region (buffer-region buffer)) - (with-output-to-mark - (*standard-output* (buffer-point buffer)) - (eval `(grindef ,x)) ; hackish, I know... - (terpri) - (ed::change-to-buffer buffer) - (buffer-start (buffer-point buffer))))) - ((or (stringp x) (pathnamep x)) - (ed::find-file-command () x)) - (x - (error - "~S is not a symbol or pathname. I can't edit it!" x)))) - - (invoke-hook ed::entry-hook) - (unwind-protect - (loop - (catch 'editor-top-level-catcher - (handler-bind ((error #'(lambda (condition) - (lisp-error-error-handler condition - :internal)))) - (invoke-hook ed::abort-hook) - (%command-loop)))) - (invoke-hook ed::exit-hook))))))) - -(defun maybe-load-hemlock-init (init) - (when init - (let* ((name (case init - ((t) (let ((switch (find "hinit" *command-line-switches* - :test #'string-equal - :key #'cmd-switch-name))) - (if switch - (or (cmd-switch-value switch) - (car (cmd-switch-words switch)) - "hemlock-init") - "hemlock-init"))) - (t (pathname init))))) - (load (merge-pathnames name (user-homedir-pathname)) - :if-does-not-exist nil)))) - - - -;;;; SAVE-ALL-BUFFERS. - -(defun save-all-buffers (&optional (list-unmodified-buffers nil)) - (dolist (buffer *buffer-list*) - (when (or list-unmodified-buffers (buffer-modified buffer)) - (maybe-save-buffer buffer)))) - -(defun maybe-save-buffer (buffer) - (let* ((modified (buffer-modified buffer)) - (pathname (buffer-pathname buffer)) - (name (buffer-name buffer)) - (string (if pathname (namestring pathname)))) - (format t "Buffer ~S is ~:[UNmodified~;modified~], Save it? " - name modified) - (when (y-or-n-p) - (let ((name (read-line-default "File to write" string))) - (format t "Writing file ~A..." name) - (force-output) - (write-file (buffer-region buffer) name) - (write-line "write WON"))))) - -(defun read-line-default (prompt default) - (format t "~A:~@[ [~A]~] " prompt default) - (do ((result (read-line) (read-line))) - (()) - (declare (simple-string result)) - (when (plusp (length result)) (return result)) - (when default (return default)) - (format t "~A:~@[ [~A]~] " prompt default))) diff --git a/hemlock/mh.lisp b/hemlock/mh.lisp deleted file mode 100644 index 66e331747e789d1aab7fa89a2bb83182d3210eb1..0000000000000000000000000000000000000000 --- a/hemlock/mh.lisp +++ /dev/null @@ -1,3166 +0,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.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. -;;; you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CS.CMU.EDU). -;;; ********************************************************************** -;;; -;;; This is a mailer interface to MH. -;;; -;;; Written by Bill Chiles. -;;; - -(in-package "HEMLOCK") - - - -;;;; General stuff. - -(defvar *new-mail-buffer* nil) - -(defvar *mh-utility-bit-bucket* (make-broadcast-stream)) - - -(defattribute "Digit" - "This is just a (mod 2) attribute for base 10 digit characters.") -;;; -(dotimes (i 10) - (setf (character-attribute :digit (digit-char i)) 1)) - - -(defmacro number-string (number) - `(let ((*print-base* 10)) - (prin1-to-string ,number))) - - -(defmacro do-headers-buffers ((buffer-var folder &optional hinfo-var) - &rest forms) - "The Forms are evaluated with Buffer-Var bound to each buffer containing - headers lines for folder. Optionally Hinfo-Var is bound to the - headers-information structure." - (let ((folder-var (gensym)) - (hinfo (gensym))) - `(let ((,folder-var ,folder)) - (declare (simple-string ,folder-var)) - (dolist (,buffer-var *buffer-list*) - (when (hemlock-bound-p 'headers-information :buffer ,buffer-var) - (let ((,hinfo (variable-value 'headers-information - :buffer ,buffer-var))) - (when (string= (the simple-string (headers-info-folder ,hinfo)) - ,folder-var) - ,@(if hinfo-var - `((let ((,hinfo-var ,hinfo)) - ,@forms)) - forms)))))))) - -(defmacro do-headers-lines ((hbuffer &key line-var mark-var) &rest forms) - "Forms are evaluated for each non-blank line. When supplied Line-Var and - Mark-Var are to the line and a :left-inserting mark at the beginning of the - line. This works with DELETE-HEADERS-BUFFER-LINE, but one should be careful - using this to modify the hbuffer." - (let ((line-var (or line-var (gensym))) - (mark-var (or mark-var (gensym))) - (id (gensym))) - `(with-mark ((,mark-var (buffer-point ,hbuffer) :left-inserting)) - (buffer-start ,mark-var) - (loop - (let* ((,line-var (mark-line ,mark-var)) - (,id (line-message-id ,line-var))) - (unless (blank-line-p ,line-var) - ,@forms) - (if (or (not (eq ,line-var (mark-line ,mark-var))) - (string/= ,id (line-message-id ,line-var))) - (line-start ,mark-var) - (unless (line-offset ,mark-var 1 0) (return)))))))) - -(defmacro with-headers-mark ((mark-var hbuffer msg) &rest forms) - "Forms are executed with Mark-Var bound to a :left-inserting mark at the - beginning of the headers line representing msg. If no such line exists, - no execution occurs." - (let ((line (gensym))) - `(do-headers-lines (,hbuffer :line-var ,line :mark-var ,mark-var) - (when (string= (the simple-string (line-message-id ,line)) - (the simple-string ,msg)) - ,@forms - (return))))) - - - -;;;; Headers Mode. - -(defmode "Headers" :major-p t) - -(defhvar "Headers Information" - "This holds the information about the current headers buffer." - :value nil) - -(defstruct (headers-info (:print-function print-headers-info)) - buffer ;Buffer for these headers. - folder ;String name of folder with leading MH "+". - msg-seq ;MH sequence of messages in buffer. - msg-strings ;List of strings representing msg-seq. - other-msg-bufs ;List of message buffers referencing this headers buffer. - draft-bufs ;List of draft buffers referencing this headers buffer. - msg-buffer) - -(defun print-headers-info (obj str n) - (declare (ignore n)) - (format str "#<Headers Info ~S>" (headers-info-folder obj))) - -(defmacro line-message-deleted (line) - `(getf (line-plist ,line) 'mh-msg-deleted)) - -(defmacro line-message-id (line) - `(getf (line-plist ,line) 'mh-msg-id)) - -(defun headers-current-message (hinfo) - (let* ((point (buffer-point (headers-info-buffer hinfo))) - (line (mark-line point))) - (unless (blank-line-p line) - (values (line-message-id line) - (copy-mark point))))) - -(defcommand "Message Headers" (p) - "Prompts for a folder and messages, displaying headers in a buffer in the - current window. With an argument, prompt for a pick expression." - "Show some headers." - (let ((folder (prompt-for-folder))) - (new-message-headers - folder - (prompt-for-message :prompt (if p - "MH messages to pick from: " - "MH messages: ") - :folder folder - :messages "all") - p))) - -(defcommand "Pick Headers" (p) - "Further narrow the selection of this folders headers. - Prompts for a pick expression to pick over the headers in the current - buffer. Entering an empty expression displays all the headers for that - folder." - "Prompts for a pick expression to pick over the headers in the current - buffer." - (declare (ignore p)) - (let ((hinfo (value headers-information))) - (unless hinfo - (editor-error "Pick Headers only works in a headers buffer.")) - (pick-message-headers hinfo))) - -;;; PICK-MESSAGE-HEADERS picks messages from info's messages based on an -;;; expression provided by the user. If the expression is empty, we do -;;; headers on all the messages in folder. The buffer's name is changed to -;;; reflect the messages picked over and the expression used. -;;; -(defun pick-message-headers (hinfo) - (let ((folder (headers-info-folder hinfo)) - (msgs (headers-info-msg-strings hinfo))) - (multiple-value-bind (pick user-pick) - (prompt-for-pick-expression) - (let* ((hbuffer (headers-info-buffer hinfo)) - (new-mail-buf-p (eq hbuffer *new-mail-buffer*)) - (region (cond (pick - (message-headers-to-region - folder (pick-messages folder msgs pick))) - (new-mail-buf-p - (maybe-get-new-mail-msg-hdrs folder)) - (t (message-headers-to-region folder - (list "all")))))) - (with-writable-buffer (hbuffer) - (revamp-headers-buffer hbuffer hinfo) - (when region (insert-message-headers hbuffer hinfo region))) - (setf (buffer-modified hbuffer) nil) - (buffer-start (buffer-point hbuffer)) - (setf (buffer-name hbuffer) - (cond (pick (format nil "Headers ~A ~A ~A" folder msgs user-pick)) - (new-mail-buf-p (format nil "Unseen Headers ~A" folder)) - (t (format nil "Headers ~A (all)" folder)))))))) - -;;; NEW-MESSAGE-HEADERS picks over msgs if pickp is non-nil, or it just scans -;;; msgs. It is important to pick and get the message headers region before -;;; making the buffer and info structures since PICK-MESSAGES and -;;; MESSAGE-HEADERS-TO-REGION will call EDITOR-ERROR if they fail. The buffer -;;; name is chosen based on folder, msgs, and an optional pick expression. -;;; -(defun new-message-headers (folder msgs &optional pickp) - (multiple-value-bind (pick-exp user-pick) - (if pickp (prompt-for-pick-expression)) - (let* ((pick (if pick-exp (pick-messages folder msgs pick-exp))) - (region (message-headers-to-region folder (or pick msgs))) - (hbuffer (maybe-make-mh-buffer (format nil "Headers ~A ~A~:[~; ~S~]" - folder msgs pick user-pick) - :headers)) - (hinfo (make-headers-info :buffer hbuffer :folder folder))) - (insert-message-headers hbuffer hinfo region) - (defhvar "Headers Information" - "This holds the information about the current headers buffer." - :value hinfo :buffer hbuffer) - (setf (buffer-modified hbuffer) nil) - (setf (buffer-writable hbuffer) nil) - (buffer-start (buffer-point hbuffer)) - (change-to-buffer hbuffer)))) - -(defhvar "MH Scan Line Form" - "This is a pathname of a file containing an MH format expression for headers - lines." - :value (pathname "/usr/misc/.lisp/lib/mh-scan")) - -;;; MESSAGE-HEADERS-TO-REGION uses the MH "scan" utility output headers into -;;; buffer for folder and msgs. -;;; -;;; (value fill-column) should really be done as if the buffer were current, -;;; but Hemlock doesn't let you do this without the buffer being current. -;;; -(defun message-headers-to-region (folder msgs &optional width) - (let ((region (make-empty-region))) - (with-output-to-mark (*standard-output* (region-end region) :full) - (mh "scan" - `(,folder ,@msgs - "-form" ,(namestring (value mh-scan-line-form)) - "-width" ,(number-string (or width (value fill-column))) - "-noheader"))) - region)) - -(defun insert-message-headers (hbuffer hinfo region) - (ninsert-region (buffer-point hbuffer) region) - (let ((seq (set-message-headers-ids hbuffer :return-seq))) - (setf (headers-info-msg-seq hinfo) seq) - (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq))) - (when (value virtual-message-deletion) - (note-deleted-headers hbuffer - (mh-sequence-list (headers-info-folder hinfo) - "hemlockdeleted")))) - -(defun set-message-headers-ids (hbuffer &optional return-seq) - (let ((msgs nil)) - (do-headers-lines (hbuffer :line-var line) - (let* ((line-str (line-string line)) - (num (parse-integer line-str :junk-allowed t))) - (declare (simple-string line-str)) - (unless num - (editor-error "MH scan lines must contain the message id as the ~ - first thing on the line for the Hemlock interface.")) - (setf (line-message-id line) (number-string num)) - (when return-seq (setf msgs (mh-sequence-insert num msgs))))) - msgs)) - -(defun note-deleted-headers (hbuffer deleted-seq) - (when deleted-seq - (do-headers-lines (hbuffer :line-var line :mark-var hmark) - (if (mh-sequence-member-p (line-message-id line) deleted-seq) - (note-deleted-message-at-mark hmark) - (setf (line-message-deleted line) nil))))) - -;;; PICK-MESSAGES -- Internal Interface. -;;; -;;; This takes a folder (with a + in front of the name), messages to pick -;;; over, and an MH pick expression (in the form returned by -;;; PROMPT-FOR-PICK-EXPRESSION). Sequence is an MH sequence to set to exactly -;;; those messages chosen by the pick when zerop is non-nil; when zerop is nil, -;;; pick adds the messages to the sequence along with whatever messages were -;;; already in the sequence. This returns a list of message specifications. -;;; -(defun pick-messages (folder msgs expression &optional sequence (zerop t)) - (let* ((temp (with-output-to-string (*standard-output*) - (unless - ;; If someone bound *signal-mh-errors* to nil around this - ;; function, MH pick outputs bogus messages (for example, - ;; "0"), and MH would return without calling EDITOR-ERROR. - (mh "pick" `(,folder - ,@msgs - ,@(if sequence `("-sequence" ,sequence)) - ,@(if zerop '("-zero")) - "-list" ; -list must follow -sequence. - ,@expression)) - (return-from pick-messages nil)))) - (len (length temp)) - (start 0) - (result nil)) - (declare (simple-string temp)) - (loop - (let ((end (position #\newline temp :start start :test #'char=))) - (cond ((not end) - (return (nreverse (cons (subseq temp start) result)))) - ((= start end) - (return (nreverse result))) - (t - (push (subseq temp start end) result) - (when (>= (setf start (1+ end)) len) - (return (nreverse result))))))))) - - -(defcommand "Delete Headers Buffer and Message Buffers" (p &optional buffer) - "Prompts for a headers buffer to delete along with its associated message - buffers. Any associated draft buffers are left alone, but their associated - message buffers will be deleted." - "Deletes the current headers buffer and its associated message buffers." - (declare (ignore p)) - (let* ((default (cond ((value headers-information) (current-buffer)) - ((value message-information) (value headers-buffer)))) - (buffer (or buffer - (prompt-for-buffer :default default - :default-string - (if default (buffer-name default)))))) - (unless (hemlock-bound-p 'headers-information :buffer buffer) - (editor-error "Not a headers buffer -- ~A" (buffer-name buffer))) - (let* ((hinfo (variable-value 'headers-information :buffer buffer)) - ;; Copy list since buffer cleanup hook is destructive. - (other-bufs (copy-list (headers-info-other-msg-bufs hinfo))) - (msg-buf (headers-info-msg-buffer hinfo))) - (when msg-buf (delete-buffer-if-possible msg-buf)) - (dolist (b other-bufs) (delete-buffer-if-possible b)) - (delete-buffer-if-possible (headers-info-buffer hinfo))))) - -(defhvar "Expunge Messages Confirm" - "When set (the default), \"Expunge Messages\" and \"Quit Headers\" will ask - for confirmation before expunging messages and packing the folder's message - id's." - :value t) - -(defhvar "Temporary Draft Folder" - "This is the folder name where MH fcc: messages are kept that are intended - to be deleted and expunged when messages are expunged for any other - folder -- \"Expunge Messages\" and \"Quit Headers\"." - :value nil) - -;;; "Quit Headers" doesn't expunge or compact unless there is a deleted -;;; sequence. This collapses other headers buffers into the same folder -;;; differently than "Expunge Messages" since the latter assumes there will -;;; always be one remaining headers buffer. This command folds all headers -;;; buffers into the folder that are not the current buffer or the new mail -;;; buffer into one buffer. When the current buffer is the new mail buffer -;;; we do not check for more unseen headers since we are about to delete -;;; the buffer anyway. The other headers buffers must be deleted before -;;; making the new one due to aliasing the buffer structure and -;;; MAYBE-MAKE-MH-BUFFER. -;;; -(defcommand "Quit Headers" (p) - "Quit headers buffer possibly expunging deleted messages. - This affects the current headers buffer. When there are deleted messages - the user is asked for confirmation on expunging the messages and packing the - folder's message id's. Then the buffer and all its associated message - buffers are deleted. Setting \"Quit Headers Confirm\" to nil inhibits - prompting. When \"Temporary Draft Folder\" is bound, this folder's messages - are deleted and expunged." - "This affects the current headers buffer. When there are deleted messages - the user is asked for confirmation on expunging the messages and packing - the folder. Then the buffer and all its associated message buffers are - deleted." - (declare (ignore p)) - (let* ((hinfo (value headers-information)) - (minfo (value message-information)) - (hdrs-buf (cond (hinfo (current-buffer)) - (minfo (value headers-buffer))))) - (unless hdrs-buf - (editor-error "Not in or associated with any headers buffer.")) - (let* ((folder (cond (hinfo (headers-info-folder hinfo)) - (minfo (message-info-folder minfo)))) - (deleted-seq (mh-sequence-list folder "hemlockdeleted"))) - (when (and deleted-seq - (or (not (value expunge-messages-confirm)) - (prompt-for-y-or-n - :prompt (list "Expunge messages and pack folder ~A? " - folder) - :default t - :default-string "Y"))) - (message "Deleting messages ...") - (mh "rmm" (list folder "hemlockdeleted")) - (let ((*standard-output* *mh-utility-bit-bucket*)) - (message "Compacting folder ...") - (mh "folder" (list folder "-fast" "-pack"))) - (message "Maintaining consistency ...") - (let (hbufs) - (declare (list hbufs)) - (do-headers-buffers (b folder) - (unless (or (eq b hdrs-buf) (eq b *new-mail-buffer*)) - (push b hbufs))) - (dolist (b hbufs) - (delete-headers-buffer-and-message-buffers-command nil b)) - (when hbufs - (new-message-headers folder (list "all")))) - (expunge-messages-fix-draft-buffers folder) - (unless (eq hdrs-buf *new-mail-buffer*) - (expunge-messages-fix-unseen-headers folder)) - (delete-and-expunge-temp-drafts))) - (delete-headers-buffer-and-message-buffers-command nil hdrs-buf))) - -;;; DELETE-AND-EXPUNGE-TEMP-DRAFTS deletes all the messages in the -;;; temporary draft folder if there is one defined. Any headers buffers -;;; into this folder are deleted with their message buffers. We have to -;;; create a list of buffers to delete since buffer deletion destructively -;;; modifies the same list DO-HEADERS-BUFFERS uses. "rmm" is run without -;;; error reporting since it signals an error if there are no messages to -;;; delete. This function must return; for example, "Quit Headers" would -;;; not complete successfully if this ended up calling EDITOR-ERROR. -;;; -(defun delete-and-expunge-temp-drafts () - (let ((temp-draft-folder (value temporary-draft-folder))) - (when temp-draft-folder - (setf temp-draft-folder (coerce-folder-name temp-draft-folder)) - (message "Deleting and expunging temporary drafts ...") - (when (mh "rmm" (list temp-draft-folder "all") :errorp nil) - (let (hdrs) - (declare (list hdrs)) - (do-headers-buffers (b temp-draft-folder) - (push b hdrs)) - (dolist (b hdrs) - (delete-headers-buffer-and-message-buffers-command nil b))))))) - - - -;;;; Message Mode. - -(defmode "Message" :major-p t) - -(defhvar "Message Information" - "This holds the information about the current message buffer." - :value nil) - -(defstruct message/draft-info - headers-mark) ;Mark pointing to a headers line in a headers buffer. - -(defstruct (message-info (:include message/draft-info) - (:print-function print-message-info)) - folder ;String name of folder with leading MH "+". - msgs ;List of strings representing messages to be shown. - draft-buf ;Possible draft buffer reference. - keep) ;Whether message buffer may be re-used. - -(defun print-message-info (obj str n) - (declare (ignore n)) - (format str "#<Message Info ~S ~S>" - (message-info-folder obj) (message-info-msgs obj))) - - -(defcommand "Next Message" (p) - "Show the next message. - When in a message buffer, shows the next message in the associated headers - buffer. When in a headers buffer, moves point down a line and shows that - message." - "When in a message buffer, shows the next message in the associated headers - buffer. When in a headers buffer, moves point down a line and shows that - message." - (declare (ignore p)) - (show-message-offset 1)) - -(defcommand "Previous Message" (p) - "Show the previous message. - When in a message buffer, shows the previous message in the associated - headers buffer. When in a headers buffer, moves point up a line and shows - that message." - "When in a message buffer, shows the previous message in the associated - headers buffer. When in a headers buffer, moves point up a line and - shows that message." - (declare (ignore p)) - (show-message-offset -1)) - -(defcommand "Next Undeleted Message" (p) - "Show the next undeleted message. - When in a message buffer, shows the next undeleted message in the associated - headers buffer. When in a headers buffer, moves point down to a line - without a deleted message and shows that message." - "When in a message buffer, shows the next undeleted message in the associated - headers buffer. When in a headers buffer, moves point down to a line without - a deleted message and shows that message." - (declare (ignore p)) - (show-message-offset 1 :undeleted)) - -(defcommand "Previous Undeleted Message" (p) - "Show the previous undeleted message. - When in a message buffer, shows the previous undeleted message in the - associated headers buffer. When in a headers buffer, moves point up a line - without a deleted message and shows that message." - "When in a message buffer, shows the previous undeleted message in the - associated headers buffer. When in a headers buffer, moves point up a line - without a deleted message and shows that message." - (declare (ignore p)) - (show-message-offset -1 :undeleted)) - -(defun show-message-offset (offset &optional undeleted) - (let ((minfo (value message-information))) - (cond - ((not minfo) - (let ((hinfo (value headers-information))) - (unless hinfo (editor-error "Not in a message or headers buffer.")) - (show-message-offset-hdrs-buf hinfo offset undeleted))) - ((message-info-keep minfo) - (let ((hbuf (value headers-buffer))) - (unless hbuf (editor-error "Not associated with a headers buffer.")) - (let ((hinfo (variable-value 'headers-information :buffer hbuf)) - (point (buffer-point hbuf))) - (move-mark point (message-info-headers-mark minfo)) - (show-message-offset-hdrs-buf hinfo offset undeleted)))) - (t - (show-message-offset-msg-buf minfo offset undeleted))))) - -(defun show-message-offset-hdrs-buf (hinfo offset undeleted) - (unless hinfo (editor-error "Not in a message or headers buffer.")) - (unless (show-message-offset-mark (buffer-point (headers-info-buffer hinfo)) - offset undeleted) - (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message." - (plusp offset) undeleted)) - (show-headers-message hinfo)) - -(defun show-message-offset-msg-buf (minfo offset undeleted) - (let ((msg-mark (message-info-headers-mark minfo))) - (unless msg-mark (editor-error "Not associated with a headers buffer.")) - (unless (show-message-offset-mark msg-mark offset undeleted) - (let ((hbuf (value headers-buffer)) - (mbuf (current-buffer))) - (setf (current-buffer) hbuf) - (setf (window-buffer (current-window)) hbuf) - (delete-buffer-if-possible mbuf)) - (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message." - (plusp offset) undeleted)) - (move-mark (buffer-point (line-buffer (mark-line msg-mark))) msg-mark) - (let* ((next-msg (line-message-id (mark-line msg-mark))) - (folder (message-info-folder minfo)) - (mbuffer (current-buffer))) - (with-writable-buffer (mbuffer) - (delete-region (buffer-region mbuffer)) - (setf (buffer-name mbuffer) (get-storable-msg-buf-name folder next-msg)) - (setf (message-info-msgs minfo) next-msg) - (read-mh-file (merge-pathnames next-msg - (merge-relative-pathnames - (strip-folder-name folder) - (mh-directory-pathname))) - mbuffer) - (let ((unseen-seq (mh-profile-component "unseen-sequence"))) - (when unseen-seq - (mark-one-message folder next-msg unseen-seq :delete)))))) - (let ((dbuffer (message-info-draft-buf minfo))) - (when dbuffer - (delete-variable 'message-buffer :buffer dbuffer) - (setf (message-info-draft-buf minfo) nil)))) - -(defun get-storable-msg-buf-name (folder msg) - (let ((name (format nil "Message ~A ~A" folder msg))) - (if (not (getstring name *buffer-names*)) - name - (let ((n 2)) - (loop - (setf name (format nil "Message ~A ~A copy ~D" folder msg n)) - (unless (getstring name *buffer-names*) - (return name)) - (incf n)))))) - -(defun show-message-offset-mark (msg-mark offset undeleted) - (with-mark ((temp msg-mark)) - (let ((winp - (cond (undeleted - (loop - (unless (and (line-offset temp offset 0) - (not (blank-line-p (mark-line temp)))) - (return nil)) - (unless (line-message-deleted (mark-line temp)) - (return t)))) - ((and (line-offset temp offset 0) - (not (blank-line-p (mark-line temp))))) - (t nil)))) - (if winp (move-mark msg-mark temp))))) - - -(defcommand "Show Message" (p) - "Shows the current message. - Prompts for a folder and message(s), displaying this in the current window. - When invoked in a headers buffer, shows the message on the current line." - "Show a message." - (declare (ignore p)) - (let ((hinfo (value headers-information))) - (if hinfo - (show-headers-message hinfo) - (let ((folder (prompt-for-folder))) - (show-prompted-message folder (prompt-for-message :folder folder)))))) - -;;; SHOW-HEADERS-MESSAGE shows the current message for hinfo. If there is a -;;; main message buffer, clobber it, and we don't have to deal with kept -;;; messages or draft associations since those operations should have moved -;;; the message buffer into the others list. Remove the message from the -;;; unseen sequence, and make sure the message buffer is displayed in some -;;; window. -;;; -(defun show-headers-message (hinfo) - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (let* ((mbuffer (headers-info-msg-buffer hinfo)) - (folder (headers-info-folder hinfo)) - (buf-name (get-storable-msg-buf-name folder cur-msg)) - (writable nil)) - (cond (mbuffer - (setf (buffer-name mbuffer) buf-name) - (setf writable (buffer-writable mbuffer)) - (setf (buffer-writable mbuffer) t) - (delete-region (buffer-region mbuffer)) - (let ((minfo (variable-value 'message-information :buffer mbuffer))) - (move-mark (message-info-headers-mark minfo) cur-mark) - (delete-mark cur-mark) - (setf (message-info-msgs minfo) cur-msg))) - (t (setf mbuffer (maybe-make-mh-buffer buf-name :message)) - (setf (headers-info-msg-buffer hinfo) mbuffer) - (defhvar "Message Information" - "This holds the information about the current headers buffer." - :value (make-message-info :folder folder - :msgs cur-msg - :headers-mark cur-mark) - :buffer mbuffer) - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their - associated headers buffer." - :value (headers-info-buffer hinfo) :buffer mbuffer))) - (read-mh-file (merge-pathnames - cur-msg - (merge-relative-pathnames (strip-folder-name folder) - (mh-directory-pathname))) - mbuffer) - (setf (buffer-writable mbuffer) writable) - (let ((unseen-seq (mh-profile-component "unseen-sequence"))) - (when unseen-seq (mark-one-message folder cur-msg unseen-seq :delete))) - (get-message-buffer-window mbuffer)))) - -;;; SHOW-PROMPTED-MESSAGE takes an arbitrary message spec and blasts those -;;; messages into a message buffer. First we pick the message to get them -;;; individually specified as normalized message ID's -- all integers and -;;; no funny names such as "last". -;;; -(defun show-prompted-message (folder msgs) - (let* ((msgs (pick-messages folder msgs nil)) - (mbuffer (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msgs) - :message))) - (defhvar "Message Information" - "This holds the information about the current headers buffer." - :value (make-message-info :folder folder :msgs msgs) - :buffer mbuffer) - (let ((*standard-output* (make-hemlock-output-stream (buffer-point mbuffer) - :full))) - (mh "show" `(,folder ,@msgs "-noshowproc" "-noheader")) - (setf (buffer-modified mbuffer) nil)) - (buffer-start (buffer-point mbuffer)) - (setf (buffer-writable mbuffer) nil) - (get-message-buffer-window mbuffer))) - -;;; GET-MESSAGE-BUFFER-WINDOW currently just changes to buffer, unless buffer -;;; has any windows, in which case it uses the first one. It could prompt for -;;; a window, split the current window, split the current window or use the -;;; next one if there is one, funcall an Hvar. It could take a couple -;;; arguments to control its behaviour. Whatever. -;;; -(defun get-message-buffer-window (mbuffer) - (let ((wins (buffer-windows mbuffer))) - (cond (wins - (setf (current-buffer) mbuffer) - (setf (current-window) (car wins))) - (t (change-to-buffer mbuffer))))) - - -(defhvar "Scroll Message Showing Next" - "When this is set, \"Scroll Message\" shows the next message when the end - of the current message is visible." - :value t) - -(defcommand "Scroll Message" (p) - "Scroll the current window down through the current message. - If the end of the message is visible, then show the next undeleted message - if \"Scroll Message Showing Next\" is non-nil." - "Scroll the current window down through the current message." - (if (and (not p) - (displayed-p (buffer-end-mark (current-buffer)) (current-window)) - (value scroll-message-showing-next)) - (show-message-offset 1 :undeleted) - (scroll-window-down-command p))) - - -(defcommand "Keep Message" (p) - "Keeps the current message buffer from being re-used. Also, if the buffer - would be deleted due to a draft completion, it will not be." - "Keeps the current message buffer from being re-used. Also, if the buffer - would be deleted due to a draft completion, it will not be." - (declare (ignore p)) - (let ((minfo (value message-information))) - (unless minfo (editor-error "Not in a message buffer.")) - (let ((hbuf (value headers-buffer))) - (when hbuf - (let ((mbuf (current-buffer)) - (hinfo (variable-value 'headers-information :buffer hbuf))) - (when (eq (headers-info-msg-buffer hinfo) mbuf) - (setf (headers-info-msg-buffer hinfo) nil) - (push mbuf (headers-info-other-msg-bufs hinfo)))))) - (setf (message-info-keep minfo) t))) - -(defcommand "Edit Message Buffer" (p) - "Recursively edit message buffer. - Puts the current message buffer into \"Text\" mode allowing modifications in - a recursive edit. While in this state, the buffer is associated with the - pathname of the message, so saving the file is possible." - "Puts the current message buffer into \"Text\" mode allowing modifications in - a recursive edit. While in this state, the buffer is associated with the - pathname of the message, so saving the file is possible." - (declare (ignore p)) - (let* ((minfo (value message-information))) - (unless minfo (editor-error "Not in a message buffer.")) - (let* ((msgs (message-info-msgs minfo)) - (mbuf (current-buffer)) - (mbuf-name (buffer-name mbuf)) - (writable (buffer-writable mbuf)) - (abortp t)) - (when (consp msgs) - (editor-error - "There appears to be more than one message in this buffer.")) - (unwind-protect - (progn - (setf (buffer-writable mbuf) t) - (setf (buffer-pathname mbuf) - (merge-pathnames - msgs - (merge-relative-pathnames - (strip-folder-name (message-info-folder minfo)) - (mh-directory-pathname)))) - (setf (buffer-major-mode mbuf) "Text") - (do-recursive-edit) - (setf abortp nil)) - (when (and (not abortp) - (buffer-modified mbuf) - (prompt-for-y-or-n - :prompt "Message buffer modified, save it? " - :default t)) - (save-file-command nil mbuf)) - (setf (buffer-modified mbuf) nil) - ;; "Save File", which the user may have used, changes the buffer's name. - (unless (getstring mbuf-name *buffer-names*) - (setf (buffer-name mbuf) mbuf-name)) - (setf (buffer-writable mbuf) writable) - (setf (buffer-pathname mbuf) nil) - (setf (buffer-major-mode mbuf) "Message"))))) - - - -;;;; Draft Mode. - -(defmode "Draft") - -(defhvar "Draft Information" - "This holds the information about the current draft buffer." - :value nil) - -(defstruct (draft-info (:include message/draft-info) - (:print-function print-draft-info)) - folder ;String name of draft folder with leading MH "+". - message ;String id of draft folder message. - pathname ;Pathname of draft in the draft folder directory. - delivered ;This is set when the draft was really sent. - replied-to-folder ;Folder of message draft is in reply to. - replied-to-msg) ;Message draft is in reply to. - -(defun print-draft-info (obj str n) - (declare (ignore n)) - (format str "#<Draft Info ~A>" (draft-info-message obj))) - - -(defhvar "Reply to Message Prefix Action" - "This is one of :cc-all, :no-cc-all, or nil. When an argument is supplied to - \"Reply to Message\", this value determines how arguments passed to the - MH utility." - :value nil) - -(defcommand "Reply to Message" (p) - "Sets up a draft in reply to the current message. - Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message. With an argument, regard \"Reply to Message Prefix - Action\" for carbon copy arguments to the MH utility." - "Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message." - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (setup-reply-draft (headers-info-folder hinfo) - cur-msg hinfo cur-mark p))) - (minfo - (setup-message-buffer-draft (current-buffer) minfo :reply p)) - (t - (let ((folder (prompt-for-folder))) - (setup-reply-draft folder - (car (prompt-for-message :folder folder)) - nil nil p)))))) - -;;; SETUP-REPLY-DRAFT takes a folder and msg to draft a reply to. Optionally, -;;; a headers buffer and mark are associated with the draft. First, the draft -;;; buffer is associated with the headers buffer if there is one. Then the -;;; message buffer is created and associated with the drafter buffer and -;;; headers buffer. Argument may be used to pass in the argument from the -;;; command. -;;; -(defun setup-reply-draft (folder msg &optional hinfo hmark argument) - (let* ((dbuffer (sub-setup-message-draft - "repl" :end-of-buffer - `(,folder ,msg - ,@(if argument - (case (value reply-to-message-prefix-action) - (:no-cc-all '("-nocc" "all")) - (:cc-all '("-cc" "all"))))))) - (dinfo (variable-value 'draft-information :buffer dbuffer)) - (h-buf (if hinfo (headers-info-buffer hinfo)))) - (setf (draft-info-replied-to-folder dinfo) folder) - (setf (draft-info-replied-to-msg dinfo) msg) - (when h-buf - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value h-buf :buffer dbuffer) - (setf (draft-info-headers-mark dinfo) hmark) - (push dbuffer (headers-info-draft-bufs hinfo))) - (let ((msg-buf (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msg) - :message))) - (defhvar "Message Information" - "This holds the information about the current headers buffer." - :value (make-message-info :folder folder :msgs msg - :headers-mark - (if h-buf (copy-mark hmark) hmark) - :draft-buf dbuffer) - :buffer msg-buf) - (when h-buf - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value h-buf :buffer msg-buf) - (push msg-buf (headers-info-other-msg-bufs hinfo))) - (read-mh-file (merge-pathnames - msg - (merge-relative-pathnames (strip-folder-name folder) - (mh-directory-pathname))) - msg-buf) - (setf (buffer-writable msg-buf) nil) - (defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value msg-buf :buffer dbuffer)) - (get-draft-buffer-window dbuffer))) - - -(defcommand "Forward Message" (p) - "Forward current message. - Prompts for a folder and message to forward. When in a headers buffer, - forwards the message on the current line. When in a message buffer, - forwards that message." - "Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (setup-forward-draft (headers-info-folder hinfo) - cur-msg hinfo cur-mark))) - (minfo - (setup-message-buffer-draft (current-buffer) minfo :forward)) - (t - (let ((folder (prompt-for-folder))) - (setup-forward-draft folder - (car (prompt-for-message :folder folder)))))))) - -;;; SETUP-FORWARD-DRAFT sets up a draft forwarding folder's msg. When there -;;; is a headers buffer involved (hinfo and hmark), the draft is associated -;;; with it. -;;; -;;; This function is like SETUP-REPLY-DRAFT (in addition to "forw" and -;;; :to-field), but it does not setup a message buffer. If this is added as -;;; something forward drafts want, then SETUP-REPLY-DRAFT should be -;;; parameterized and renamed. -;;; -(defun setup-forward-draft (folder msg &optional hinfo hmark) - (let* ((dbuffer (sub-setup-message-draft "forw" :to-field - (list folder msg))) - (dinfo (variable-value 'draft-information :buffer dbuffer)) - (h-buf (if hinfo (headers-info-buffer hinfo)))) - (when h-buf - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value h-buf :buffer dbuffer) - (setf (draft-info-headers-mark dinfo) hmark) - (push dbuffer (headers-info-draft-bufs hinfo))) - (get-draft-buffer-window dbuffer))) - - -(defcommand "Send Message" (p) - "Setup a draft buffer. - Setup a draft buffer, reserving a draft folder message. When invoked in a - headers buffer, the current message is available in an associated message - buffer." - "Setup a draft buffer, reserving a draft folder message. When invoked in - a headers buffer, the current message is available in an associated - message buffer." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo (setup-headers-message-draft hinfo)) - (minfo (setup-message-buffer-draft (current-buffer) minfo :compose)) - (t (setup-message-draft))))) - -(defun setup-message-draft () - (get-draft-buffer-window (sub-setup-message-draft "comp" :to-field))) - -;;; SETUP-HEADERS-MESSAGE-DRAFT sets up a draft buffer associated with a -;;; headers buffer and a message buffer. The headers current message is -;;; inserted in the message buffer which is also associated with the headers -;;; buffer. The draft buffer is associated with the message buffer. -;;; -(defun setup-headers-message-draft (hinfo) - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (message "Draft not associated with any message.")) - (let* ((dbuffer (sub-setup-message-draft "comp" :to-field)) - (dinfo (variable-value 'draft-information :buffer dbuffer)) - (h-buf (headers-info-buffer hinfo))) - (when cur-msg - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated headers - buffer." - :value h-buf :buffer dbuffer) - (push dbuffer (headers-info-draft-bufs hinfo))) - (when cur-msg - (setf (draft-info-headers-mark dinfo) cur-mark) - (let* ((folder (headers-info-folder hinfo)) - (msg-buf (maybe-make-mh-buffer - (format nil "Message ~A ~A" folder cur-msg) - :message))) - (defhvar "Message Information" - "This holds the information about the current headers buffer." - :value (make-message-info :folder folder :msgs cur-msg - :headers-mark (copy-mark cur-mark) - :draft-buf dbuffer) - :buffer msg-buf) - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value h-buf :buffer msg-buf) - (push msg-buf (headers-info-other-msg-bufs hinfo)) - (read-mh-file (merge-pathnames - cur-msg - (merge-relative-pathnames (strip-folder-name folder) - (mh-directory-pathname))) - msg-buf) - (setf (buffer-writable msg-buf) nil) - (defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value msg-buf :buffer dbuffer))) - (get-draft-buffer-window dbuffer)))) - -;;; SETUP-MESSAGE-BUFFER-DRAFT takes a message buffer and its message -;;; information. A draft buffer is created according to type, and the two -;;; buffers are associated. Any previous association of the message buffer and -;;; a draft buffer is dropped. Any association between the message buffer and -;;; a headers buffer is propagated to the draft buffer, and if the message -;;; buffer is the headers buffer's main message buffer, it is moved to "other" -;;; status. Argument may be used to pass in the argument from the command. -;;; -(defun setup-message-buffer-draft (msg-buf minfo type &optional argument) - (let* ((msgs (message-info-msgs minfo)) - (cur-msg (if (consp msgs) (car msgs) msgs)) - (folder (message-info-folder minfo)) - (dbuffer - (ecase type - (:reply - (sub-setup-message-draft - "repl" :end-of-buffer - `(,folder ,cur-msg - ,@(if argument - (case (value reply-to-message-prefix-action) - (:no-cc-all '("-nocc" "all")) - (:cc-all '("-cc" "all"))))))) - (:compose - (sub-setup-message-draft "comp" :to-field)) - (:forward - (sub-setup-message-draft "forw" :to-field - (list folder cur-msg))))) - (dinfo (variable-value 'draft-information :buffer dbuffer))) - (when (message-info-draft-buf minfo) - (delete-variable 'message-buffer :buffer (message-info-draft-buf minfo))) - (setf (message-info-draft-buf minfo) dbuffer) - (when (eq type :reply) - (setf (draft-info-replied-to-folder dinfo) folder) - (setf (draft-info-replied-to-msg dinfo) cur-msg)) - (when (hemlock-bound-p 'headers-buffer :buffer msg-buf) - (let* ((hbuf (variable-value 'headers-buffer :buffer msg-buf)) - (hinfo (variable-value 'headers-information :buffer hbuf))) - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value hbuf :buffer dbuffer) - (setf (draft-info-headers-mark dinfo) - (copy-mark (message-info-headers-mark minfo))) - (push dbuffer (headers-info-draft-bufs hinfo)) - (when (eq (headers-info-msg-buffer hinfo) msg-buf) - (setf (headers-info-msg-buffer hinfo) nil) - (push msg-buf (headers-info-other-msg-bufs hinfo))))) - (defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value msg-buf :buffer dbuffer) - (get-draft-buffer-window dbuffer))) - -(defvar *draft-to-pattern* - (new-search-pattern :string-insensitive :forward "To:")) - -(defun sub-setup-message-draft (utility point-action &optional args) - (mh utility `(,@args "-nowhatnowproc")) - (let* ((folder (mh-draft-folder)) - (draft-msg (mh-current-message folder)) - (msg-pn (merge-pathnames draft-msg (mh-draft-folder-pathname))) - (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" draft-msg) - :draft))) - (read-mh-file msg-pn dbuffer) - (setf (buffer-pathname dbuffer) msg-pn) - (defhvar "Draft Information" - "This holds the information about the current draft buffer." - :value (make-draft-info :folder (coerce-folder-name folder) - :message draft-msg - :pathname msg-pn) - :buffer dbuffer) - (let ((point (buffer-point dbuffer))) - (ecase point-action - (:to-field - (when (find-pattern point *draft-to-pattern*) - (line-end point))) - (:end-of-buffer (buffer-end point)))) - dbuffer)) - -(defun read-mh-file (pathname buffer) - (unless (probe-file pathname) - (editor-error "No such message -- ~A" (namestring pathname))) - (read-file pathname (buffer-point buffer)) - (setf (buffer-write-date buffer) (file-write-date pathname)) - (buffer-start (buffer-point buffer)) - (setf (buffer-modified buffer) nil)) - - -(defvar *draft-buffer-window-fun* 'change-to-buffer - "This is called by GET-DRAFT-BUFFER-WINDOW to display a new draft buffer. - The default is CHANGE-TO-BUFFER which uses the current window.") - -;;; GET-DRAFT-BUFFER-WINDOW is called to display a new draft buffer. -;;; -(defun get-draft-buffer-window (dbuffer) - (funcall *draft-buffer-window-fun* dbuffer)) - - -(defcommand "Reply to Message in Other Window" (p) - "Reply to message, creating another window for draft buffer. - Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message. The current window is split displaying the draft - buffer in the new window and the message buffer in the current." - "Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message." - (let ((*draft-buffer-window-fun* #'draft-buffer-in-other-window)) - (reply-to-message-command p))) - -(defun draft-buffer-in-other-window (dbuffer) - (when (hemlock-bound-p 'message-buffer :buffer dbuffer) - (let ((mbuf (variable-value 'message-buffer :buffer dbuffer))) - (when (not (eq (current-buffer) mbuf)) - (change-to-buffer mbuf)))) - (setf (current-buffer) dbuffer) - (setf (current-window) (make-window (buffer-start-mark dbuffer))) - (defhvar "Split Window Draft" - "Indicates window needs to be cleaned up for draft." - :value t :buffer dbuffer)) - -(defhvar "Deliver Message Confirm" - "When set, \"Deliver Message\" will ask for confirmation before sending the - draft. This is off by default since \"Deliver Message\" is not bound to - any key by default." - :value t) - -(defcommand "Deliver Message" (p) - "Save and deliver the current draft buffer. - When in a draft buffer, this saves the file and uses SEND to deliver the - draft. Otherwise, this prompts for a draft message id, invoking SEND." - "When in a draft buffer, this saves the file and uses SEND to deliver the - draft. Otherwise, this prompts for a draft message id, invoking SEND." - (declare (ignore p)) - (let ((dinfo (value draft-information))) - (cond (dinfo - (deliver-draft-buffer-message dinfo)) - (t - (let* ((folder (coerce-folder-name (mh-draft-folder))) - (msg (prompt-for-message :folder folder))) - (mh "send" `("-draftfolder" ,folder "-draftmessage" ,@msg))))))) - -(defun deliver-draft-buffer-message (dinfo) - (when (draft-info-delivered dinfo) - (editor-error "This draft has already been delivered.")) - (when (or (not (value deliver-message-confirm)) - (prompt-for-y-or-n :prompt "Deliver message? " :default t)) - (let ((dbuffer (current-buffer))) - (when (buffer-modified dbuffer) - (write-buffer-file dbuffer (buffer-pathname dbuffer))) - (message "Delivering draft ...") - (mh "send" `("-draftfolder" ,(draft-info-folder dinfo) - "-draftmessage" ,(draft-info-message dinfo))) - (setf (draft-info-delivered dinfo) t) - (let ((replied-folder (draft-info-replied-to-folder dinfo)) - (replied-msg (draft-info-replied-to-msg dinfo))) - (when replied-folder - (message "Annotating message being replied to ...") - (mh "anno" `(,replied-folder ,replied-msg "-component" "replied")) - (do-headers-buffers (hbuf replied-folder) - (with-headers-mark (hmark hbuf replied-msg) - (mark-to-note-replied-msg hmark) - (with-writable-buffer (hbuf) - (setf (next-character hmark) #\A)))) - (dolist (b *buffer-list*) - (when (and (hemlock-bound-p 'message-information :buffer b) - (buffer-modeline-field-p b :replied-to-message)) - (dolist (w (buffer-windows b)) - (update-modeline-field b w :replied-to-message)))))) - (maybe-delete-extra-draft-window dbuffer (current-window)) - (let* ((mbuf (value message-buffer)) - (minfo (if mbuf - (variable-value 'message-information :buffer mbuf)))) - (when (and minfo (not (message-info-keep minfo))) - (delete-buffer-if-possible mbuf))) - (delete-buffer-if-possible dbuffer)))) - -(defcommand "Delete Draft and Buffer" (p) - "Delete the current draft message and buffer." - "Delete the current draft message and buffer." - (declare (ignore p)) - (let ((dinfo (value draft-information)) - (dbuffer (current-buffer))) - (unless dinfo (editor-error "No draft associated with buffer.")) - (maybe-delete-extra-draft-window dbuffer (current-window)) - (delete-file (draft-info-pathname dinfo)) - (let* ((mbuf (value message-buffer)) - (minfo (if mbuf - (variable-value 'message-information :buffer mbuf)))) - (when (and minfo (not (message-info-keep minfo))) - (delete-buffer-if-possible mbuf))) - (delete-buffer-if-possible dbuffer))) - -;;; MAYBE-DELETE-EXTRA-DRAFT-WINDOW takes a draft buffer and a window into it -;;; that should not be deleted. If "Split Window Draft" is bound in the buffer, -;;; and there are more than two windows (two windows plus the echo area at -;;; least), then we delete some window if it is not the dbuffer-window or the -;;; echo area window. Blow away the variable, so we don't think this is still -;;; a split window draft buffer. -;;; -(defun maybe-delete-extra-draft-window (dbuffer dbuffer-window) - (when (and (hemlock-bound-p 'split-window-draft :buffer dbuffer) - (> (length (the list *window-list*)) 2)) - (delete-window - (find-if #'(lambda (w) - (not (or (eq w dbuffer-window) - (eq w *echo-area-window*)))) - *window-list*)) - (delete-variable 'split-window-draft :buffer dbuffer))) - - -(defcommand "Remail Message" (p) - "Prompts for a folder and message to remail. Prompts for a resend-to - address string and resend-cc address string. When in a headers buffer, - remails the message on the current line. When in a message buffer, - remails that message." - "Prompts for a folder and message to remail. Prompts for a resend-to - address string and resend-cc address string. When in a headers buffer, - remails the message on the current line. When in a message buffer, - remails that message." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (remail-message (headers-info-folder hinfo) cur-msg - (prompt-for-string :prompt "Resend To: ") - (prompt-for-string :prompt "Resend Cc: ")))) - (minfo - (remail-message (message-info-folder minfo) - (message-info-msgs minfo) - (prompt-for-string :prompt "Resend To: ") - (prompt-for-string :prompt "Resend Cc: "))) - (t - (let ((folder (prompt-for-folder))) - (remail-message folder - (car (prompt-for-message :folder folder)) - (prompt-for-string :prompt "Resend To: ") - (prompt-for-string :prompt "Resend Cc: ")))))) - (message "Message remailed.")) - - -;;; REMAIL-MESSAGE claims a draft folder message with "dist". This is then -;;; sucked into a buffer and modified by inserting the supplied addresses. -;;; "send" is used to deliver the draft, but it requires certain evironment -;;; variables to make it do the right thing. "mhdist" says the draft is only -;;; remailing information, and "mhaltmsg" is the message to send. "mhannotate" -;;; must be set due to a bug in MH's "send"; it will not notice the "mhdist" -;;; flag unless there is some message to be annotated. This command does not -;;; provide for annotation of the remailed message. -;;; -(defun remail-message (folder msg resend-to resend-cc) - (mh "dist" `(,folder ,msg "-nowhatnowproc")) - (let* ((draft-folder (mh-draft-folder)) - (draft-msg (mh-current-message draft-folder))) - (setup-remail-draft-message draft-msg resend-to resend-cc) - (mh "send" `("-draftfolder" ,draft-folder "-draftmessage" ,draft-msg) - :environment - `((:|mhdist| . "1") - (:|mhannotate| . "1") - (:|mhaltmsg| . ,(namestring - (merge-pathnames msg (merge-relative-pathnames - (strip-folder-name folder) - (mh-directory-pathname))))))))) - -;;; SETUP-REMAIL-DRAFT-MESSAGE takes a draft folder and message that have been -;;; created with the MH "dist" utility. A buffer is created with this -;;; message's pathname, searching for "resent-to:" and "resent-cc:", filling in -;;; the supplied argument values. After writing out the results, the buffer -;;; is deleted. -;;; -(defvar *draft-resent-to-pattern* - (new-search-pattern :string-insensitive :forward "resent-to:")) -(defvar *draft-resent-cc-pattern* - (new-search-pattern :string-insensitive :forward "resent-cc:")) - -(defun setup-remail-draft-message (msg resend-to resend-cc) - (let* ((msg-pn (merge-pathnames msg (mh-draft-folder-pathname))) - (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" msg) - :draft)) - (point (buffer-point dbuffer))) - (read-mh-file msg-pn dbuffer) - (when (find-pattern point *draft-resent-to-pattern*) - (line-end point) - (insert-string point resend-to)) - (buffer-start point) - (when (find-pattern point *draft-resent-cc-pattern*) - (line-end point) - (insert-string point resend-cc)) - (write-file (buffer-region dbuffer) msg-pn :keep-backup nil) - ;; The draft buffer delete hook expects this to be bound. - (defhvar "Draft Information" - "This holds the information about the current draft buffer." - :value :ignore - :buffer dbuffer) - (delete-buffer dbuffer))) - - - -;;;; Message and Draft Stuff. - -(defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated headers - buffer." - :value nil) - -(defcommand "Goto Headers Buffer" (p) - "Selects associated headers buffer if it exists. - The headers buffer's point is moved to the appropriate line, pushing a - buffer mark where point was." - "Selects associated headers buffer if it exists." - (declare (ignore p)) - (let ((h-buf (value headers-buffer))) - (unless h-buf (editor-error "No associated headers buffer.")) - (let ((info (or (value message-information) (value draft-information)))) - (change-to-buffer h-buf) - (push-buffer-mark (copy-mark (current-point))) - (move-mark (current-point) (message/draft-info-headers-mark info))))) - -(defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value nil) - -(defcommand "Goto Message Buffer" (p) - "Selects associated message buffer if it exists." - "Selects associated message buffer if it exists." - (declare (ignore p)) - (let ((msg-buf (value message-buffer))) - (unless msg-buf (editor-error "No associated message buffer.")) - (change-to-buffer msg-buf))) - - -(defhvar "Message Insertion Prefix" - "This is a fill prefix that is used when inserting text from a message buffer - into a draft buffer by \"Insert Message Region\". It defaults to three - spaces." - :value " ") - -(defhvar "Message Insertion Column" - "This is a fill column that is used when inserting text from a message buffer - into a draft buffer by \"Insert Message Region\"." - :value 75) - -(defcommand "Insert Message Region" (p) - "Copy the current region into the associated draft buffer. - When in a message buffer that has an associated draft buffer, the current - active region is copied into the draft buffer. It is filled using \"Message - Insertion Prefix\" and \"Message Insertion Column\". If an argument is - supplied, the filling is inhibited." - "When in a message buffer that has an associated draft buffer, the current - active region is copied into the draft buffer. It is filled using - \"Message Insertion Prefix\" and \"Message Insertion Column\". If an - argument is supplied, the filling is inhibited." - (let ((minfo (value message-information))) - (unless minfo (editor-error "Not in a message buffer.")) - (let ((dbuf (message-info-draft-buf minfo))) - (unless dbuf - (editor-error "Message buffer not associated with any draft buffer.")) - (let* ((region (copy-region (current-region))) - (dbuf-point (buffer-point dbuf)) - (dbuf-mark (copy-mark dbuf-point))) - (if (and (hemlock-bound-p 'split-window-draft :buffer dbuf) - (> (length (the list *window-list*)) 2) - (buffer-windows dbuf)) - (setf (current-buffer) dbuf - (current-window) (car (buffer-windows dbuf))) - (change-to-buffer dbuf)) - (push-buffer-mark dbuf-mark) - (ninsert-region dbuf-point region) - (unless p - (fill-region-by-paragraphs (region dbuf-mark dbuf-point) - (value message-insertion-prefix) - (value message-insertion-column)))))) - (setf (last-command-type) :ephemerally-active)) - - -(defhvar "Message Buffer Insertion Prefix" - "This is a line prefix that is inserted at the beginning of every line in - a message buffer when inserting those lines into a draft buffer with - \"Insert Message Buffer\". It defaults to four spaces." - :value " ") - -(defcommand "Insert Message Buffer" (p) - "Insert entire (associated) message buffer into (associated) draft buffer. - When in a draft buffer with an associated message buffer, or when in a - message buffer that has an associated draft buffer, the message buffer is - inserted into the draft buffer. Each inserted line is modified by prefixing - it with \"Message Buffer Insertion Prefix\". If an argument is supplied the - prefixing is inhibited." - "When in a draft buffer with an associated message buffer, or when in a - message buffer that has an associated draft buffer, the message buffer - is inserted into the draft buffer. Each inserted line is modified by - prefixing it with \"Message Buffer Insertion Prefix\". If an argument - is supplied the prefixing is inhibited." - (let ((minfo (value message-information)) - (dinfo (value draft-information)) - mbuf dbuf) - (cond (minfo - (setf dbuf (message-info-draft-buf minfo)) - (unless dbuf - (editor-error - "Message buffer not associated with any draft buffer.")) - (setf mbuf (current-buffer)) - (change-to-buffer dbuf)) - (dinfo - (setf mbuf (value message-buffer)) - (unless mbuf - (editor-error - "Draft buffer not associated with any message buffer.")) - (setf dbuf (current-buffer))) - (t (editor-error "Not in a draft or message buffer."))) - (let* ((dbuf-point (buffer-point dbuf)) - (dbuf-mark (copy-mark dbuf-point))) - (push-buffer-mark dbuf-mark) - (insert-region dbuf-point (buffer-region mbuf)) - (unless p - (let ((prefix (value message-buffer-insertion-prefix))) - (with-mark ((temp dbuf-mark :left-inserting)) - (loop - (when (mark>= temp dbuf-point) (return)) - (insert-string temp prefix) - (unless (line-offset temp 1 0) (return))))))) - (insert-message-buffer-cleanup-split-draft dbuf mbuf)) - (setf (last-command-type) :ephemerally-active)) - -;;; INSERT-MESSAGE-BUFFER-CLEANUP-SPLIT-DRAFT tries to delete an extra window -;;; due to "Reply to Message in Other Window". Since we just inserted the -;;; message buffer in the draft buffer, we don't need the other window into -;;; the message buffer. -;;; -(defun insert-message-buffer-cleanup-split-draft (dbuf mbuf) - (when (and (hemlock-bound-p 'split-window-draft :buffer dbuf) - (> (length (the list *window-list*)) 2)) - (let ((win (car (buffer-windows mbuf)))) - (cond - (win - (when (eq win (current-window)) - (let ((dwin (car (buffer-windows dbuf)))) - (unless dwin - (editor-error "Couldn't fix windows for split window draft.")) - (setf (current-buffer) dbuf) - (setf (current-window) dwin))) - (delete-window win)) - (t ;; This happens when invoked with the message buffer current. - (let ((dwins (buffer-windows dbuf))) - (when (> (length (the list dwins)) 1) - (delete-window (find-if #'(lambda (w) - (not (eq w (current-window)))) - dwins))))))) - (delete-variable 'split-window-draft :buffer dbuf))) - - -;;; CLEANUP-MESSAGE-BUFFER is called when a buffer gets deleted. It cleans -;;; up references to a message buffer. -;;; -(defun cleanup-message-buffer (buffer) - (let ((minfo (variable-value 'message-information :buffer buffer))) - (when (hemlock-bound-p 'headers-buffer :buffer buffer) - (let* ((hinfo (variable-value 'headers-information - :buffer (variable-value 'headers-buffer - :buffer buffer))) - (msg-buf (headers-info-msg-buffer hinfo))) - (if (eq msg-buf buffer) - (setf (headers-info-msg-buffer hinfo) nil) - (setf (headers-info-other-msg-bufs hinfo) - (delete buffer (headers-info-other-msg-bufs hinfo) - :test #'eq)))) - (delete-mark (message-info-headers-mark minfo)) - ;; - ;; Do this for MAYBE-MAKE-MH-BUFFER since it isn't necessary for GC. - (delete-variable 'headers-buffer :buffer buffer)) - (when (message-info-draft-buf minfo) - (delete-variable 'message-buffer - :buffer (message-info-draft-buf minfo))))) - -;;; CLEANUP-DRAFT-BUFFER is called when a buffer gets deleted. It cleans -;;; up references to a draft buffer. -;;; -(defun cleanup-draft-buffer (buffer) - (let ((dinfo (variable-value 'draft-information :buffer buffer))) - (when (hemlock-bound-p 'headers-buffer :buffer buffer) - (let* ((hinfo (variable-value 'headers-information - :buffer (variable-value 'headers-buffer - :buffer buffer)))) - (setf (headers-info-draft-bufs hinfo) - (delete buffer (headers-info-draft-bufs hinfo) :test #'eq)) - (delete-mark (draft-info-headers-mark dinfo)))) - (when (hemlock-bound-p 'message-buffer :buffer buffer) - (setf (message-info-draft-buf - (variable-value 'message-information - :buffer (variable-value 'message-buffer - :buffer buffer))) - nil)))) - -;;; CLEANUP-HEADERS-BUFFER is called when a buffer gets deleted. It cleans -;;; up references to a headers buffer. -;;; -(defun cleanup-headers-buffer (buffer) - (let* ((hinfo (variable-value 'headers-information :buffer buffer)) - (msg-buf (headers-info-msg-buffer hinfo))) - (when msg-buf - (cleanup-headers-reference - msg-buf (variable-value 'message-information :buffer msg-buf))) - (dolist (b (headers-info-other-msg-bufs hinfo)) - (cleanup-headers-reference - b (variable-value 'message-information :buffer b))) - (dolist (b (headers-info-draft-bufs hinfo)) - (cleanup-headers-reference - b (variable-value 'draft-information :buffer b))))) - -(defun cleanup-headers-reference (buffer info) - (delete-mark (message/draft-info-headers-mark info)) - (setf (message/draft-info-headers-mark info) nil) - (delete-variable 'headers-buffer :buffer buffer) - (when (typep info 'draft-info) - (setf (draft-info-replied-to-folder info) nil) - (setf (draft-info-replied-to-msg info) nil))) - -;;; REVAMP-HEADERS-BUFFER cleans up a headers buffer for immediate re-use. -;;; After deleting the buffer's region, there will be one line in the buffer -;;; because of how Hemlock regions work, so we have to delete that line's -;;; plist. Then we clean up any references to the buffer and delete the -;;; main message buffer. The other message buffers are left alone assuming -;;; they are on the "others" list because they are being used in some -;;; particular way (for example, a draft buffer refers to one or the user has -;;; kept it). Then some slots of the info structure are set to nil. -;;; -(defun revamp-headers-buffer (hbuffer hinfo) - (delete-region (buffer-region hbuffer)) - (setf (line-plist (mark-line (buffer-point hbuffer))) nil) - (let ((msg-buf (headers-info-msg-buffer hinfo))) - ;; Deleting the buffer sets the slot to nil. - (when msg-buf (delete-buffer-if-possible msg-buf)) - (cleanup-headers-buffer hbuffer)) - (setf (headers-info-other-msg-bufs hinfo) nil) - (setf (headers-info-draft-bufs hinfo) nil) - (setf (headers-info-msg-seq hinfo) nil) - (setf (headers-info-msg-strings hinfo) nil)) - - - -;;;; Incorporating new mail. - -(defhvar "New Mail Folder" - "This is the folder new mail is incorporated into." - :value "+inbox") - -(defcommand "Incorporate New Mail" (p) - "Incorporates new mail into \"New Mail Folder\", displaying INC output in - a pop-up window." - "Incorporates new mail into \"New Mail Folder\", displaying INC output in - a pop-up window." - (declare (ignore p)) - (with-pop-up-display (s) - (incorporate-new-mail s))) - -(defhvar "Unseen Headers Message Spec" - "This is an MH message spec suitable any message prompt. It is used to - supply headers for the unseen headers buffer, in addition to the - unseen-sequence name that is taken from the user's MH profile, when - incorporating new mail and after expunging. This value is a string." - :value nil) - -(defcommand "Incorporate and Read New Mail" (p) - "Incorporates new mail and generates a headers buffer. - Incorporates new mail into \"New Mail Folder\", and creates a headers buffer - with the new messages. To use this, you must define an unseen- sequence in - your profile. Each time this is invoked the unseen-sequence is SCAN'ed, and - the headers buffer's contents are replaced." - "Incorporates new mail into \"New Mail Folder\", and creates a headers - buffer with the new messages. This buffer will be appended to with - successive uses of this command." - (declare (ignore p)) - (let ((unseen-seq (mh-profile-component "unseen-sequence"))) - (unless unseen-seq - (editor-error "No unseen-sequence defined in MH profile.")) - (incorporate-new-mail) - (let* ((folder (value new-mail-folder)) - ;; Stash current message before fetching unseen headers. - (cur-msg (mh-current-message folder)) - (region (get-new-mail-msg-hdrs folder unseen-seq))) - ;; Fetch message headers before possibly making buffer in case we error. - (when (not (and *new-mail-buffer* - (member *new-mail-buffer* *buffer-list* :test #'eq))) - (let ((name (format nil "Unseen Headers ~A" folder))) - (when (getstring name *buffer-names*) - (editor-error "There already is a buffer named ~S!" name)) - (setf *new-mail-buffer* - (make-buffer name :modes (list "Headers") - :delete-hook '(new-mail-buf-delete-hook))) - (setf (buffer-writable *new-mail-buffer*) nil))) - (cond ((hemlock-bound-p 'headers-information - :buffer *new-mail-buffer*) - (let ((hinfo (variable-value 'headers-information - :buffer *new-mail-buffer*))) - (unless (string= (headers-info-folder hinfo) folder) - (editor-error - "An unseen headers buffer already exists but into another ~ - folder. Your mail has already been incorporated into the ~ - specified folder.")) - (with-writable-buffer (*new-mail-buffer*) - (revamp-headers-buffer *new-mail-buffer* hinfo)) - ;; Restore the name in case someone used "Pick Headers". - (setf (buffer-name *new-mail-buffer*) - (format nil "Unseen Headers ~A" folder)) - (insert-new-mail-message-headers hinfo region cur-msg))) - (t - (let ((hinfo (make-headers-info :buffer *new-mail-buffer* - :folder folder))) - (defhvar "Headers Information" - "This holds the information about the current headers buffer." - :value hinfo :buffer *new-mail-buffer*) - (insert-new-mail-message-headers hinfo region cur-msg))))))) - -;;; NEW-MAIL-BUF-DELETE-HOOK is invoked whenever the new mail buffer is -;;; deleted. -;;; -(defun new-mail-buf-delete-hook (buffer) - (declare (ignore buffer)) - (setf *new-mail-buffer* nil)) - -;;; GET-NEW-MAIL-MSG-HDRS takes a folder and the unseen-sequence name. It -;;; returns a region with the unseen message headers and any headers due to -;;; the "Unseen Headers Message Spec" variable. -;;; -(defun get-new-mail-msg-hdrs (folder unseen-seq) - (let* ((unseen-headers-message-spec (value unseen-headers-message-spec)) - (other-msgs (if unseen-headers-message-spec - (breakup-message-spec - (string-trim '(#\space #\tab) - unseen-headers-message-spec)))) - (msg-spec (cond ((null other-msgs) - (list unseen-seq)) - ((member unseen-seq other-msgs :test #'string=) - other-msgs) - (t (cons unseen-seq other-msgs))))) - (message-headers-to-region folder msg-spec))) - -;;; INSERT-NEW-MAIL-MESSAGE-HEADERS inserts region in the new mail buffer. -;;; Then we look for the header line with cur-msg id, moving point there. -;;; There may have been unseen messages before incorporating new mail, and -;;; cur-msg should be the first new message. Then we either switch to the -;;; new mail headers, or show the current message. -;;; -(defun insert-new-mail-message-headers (hinfo region cur-msg) - (declare (simple-string cur-msg)) - (with-writable-buffer (*new-mail-buffer*) - (insert-message-headers *new-mail-buffer* hinfo region)) - (let ((point (buffer-point *new-mail-buffer*))) - (buffer-start point) - (with-headers-mark (cur-mark *new-mail-buffer* cur-msg) - (move-mark point cur-mark))) - (change-to-buffer *new-mail-buffer*)) - - -(defhvar "Store Password" - "When this is set, the user is only prompted once for his password." - :value nil) - -(defvar *stored-password* nil) - -(defun get-password () - (if (value store-password) - (or *stored-password* - (setf *stored-password* (prompt-for-password))) - (prompt-for-password))) - - -(defhvar "Authenticate Incorporation" - "When this is set (the default), incorporating new mail prompts for a - password to access a remote mail drop." - :value t) -(defhvar "Authentication User Name" - "When incorporating new mail accesses a remote mail drop, this is the user - name supplied for authentication on the remote machine. If this is nil - it is looked up on the local machine." - :value nil) -#| -(defhvar "Authentication Group Name" - "When incorporating new mail accesses a remote mail drop, this is the group - name supplied for authentication on the remote machine. If this is nil - it is looked up on the local machine." - :value nil) -(defhvar "Authentication Account Name" - "When incorporating new mail accesses a remote mail drop, this is the account - name supplied for authentication on the remote machine. If this is nil - it is looked up on the local machine." - :value nil) -|# - -(defhvar "Incorporate New Mail Hook" - "Functions on this hook are invoked immediately after new mail is - incorporated." - :value nil) - -(defun incorporate-new-mail (&optional stream) - "Incorporates new mail, passing INC's output to stream. When stream is - nil, output is flushed." - (unless (new-mail-p) (editor-error "No new mail.")) - (let ((args `(,(coerce-folder-name (value new-mail-folder)) - ,@(if stream nil '("-silent")) - "-form" ,(namestring (value mh-scan-line-form)) - "-width" ,(number-string (value fill-column))))) - (cond ((value authenticate-incorporation) - (let ((password (get-password))) - ;; Since we know there is mail due to above check, look for a - ;; possible password failure since MH or the rfs stuff is stupid. - (multiple-value-bind - (winp error-string) - (let ((*standard-output* (or stream *standard-output*))) - (message "Incorporating new mail ...") - (mh "inc" args :errorp nil :password password - :username (value authentication-user-name))) - (declare (simple-string error-string)) - (unless winp - (when (string= error-string "inc: unable to read" :end1 19) - (setf *stored-password* nil) - (editor-error - "Couldn't read maildrop, possible mistyped password.")) - (editor-error "MH Error -- ~A" error-string))))) - (t (message "Incorporating new mail ...") - (mh "inc" args)))) - (when (value incorporate-new-mail-hook) - (message "Invoking new mail hooks ...")) - (invoke-hook incorporate-new-mail-hook)) - - - -;;;; Deletion. - -(defhvar "Virtual Message Deletion" - "When set, \"Delete Message\" merely MARK's a message into the - \"hemlockdeleted\" sequence; otherwise, RMM is invoked." - :value t) - -(defcommand "Delete Message and Show Next" (p) - "Delete message and show next undeleted message. - This command is only valid in a headers buffer or a message buffer - associated with some headers buffer. The current message is deleted, and - the next undeleted one is shown." - "Delete the current message and show the next undeleted one." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (delete-message (headers-info-folder hinfo) cur-msg))) - (minfo - (delete-message (message-info-folder minfo) - (message-info-msgs minfo))) - (t - (editor-error "Not in a headers or message buffer.")))) - (show-message-offset 1 :undeleted)) - -(defcommand "Delete Message and Down Line" (p) - "Deletes the current message, moving point to the next line. - When in a headers buffer, deletes the message on the current line. Then it - moves point to the next non-blank line." - "Deletes current message and moves point down a line." - (declare (ignore p)) - (let ((hinfo (value headers-information))) - (unless hinfo (editor-error "Not in a headers buffer.")) - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-message (headers-info-folder hinfo) cur-msg) - (when (line-offset cur-mark 1) - (unless (blank-line-p (mark-line cur-mark)) - (move-mark (current-point) cur-mark))) - (delete-mark cur-mark)))) - -;;; "Delete Message" unlike "Headers Delete Message" cannot know for sure -;;; which message id's have been deleted, so when virtual message deletion -;;; is not used, we cannot use DELETE-HEADERS-BUFFER-LINE to keep headers -;;; buffers consistent. However, the message id's in the buffer (if deleted) -;;; will generate MH errors if operations are attempted with them, and -;;; if the user ever packs the folder with "Expunge Messages", the headers -;;; buffer will be updated. -;;; -(defcommand "Delete Message" (p) - "Prompts for a folder, messages to delete, and pick expression. When in - a headers buffer into the same folder specified, the messages prompt - defaults to those messages in the buffer; \"all\" may be entered if this is - not what is desired. When \"Virtual Message Deletion\" is set, messages are - only MARK'ed for deletion. See \"Expunge Messages\". When this feature is - not used, headers and message buffers message id's my not be consistent - with MH." - "Prompts for a folder and message to delete. When \"Virtual Message - Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge - Messages\"." - (declare (ignore p)) - (let* ((folder (prompt-for-folder)) - (hinfo (value headers-information)) - (temp-msgs (prompt-for-message - :folder folder - :messages - (if (and hinfo - (string= folder - (the simple-string - (headers-info-folder hinfo)))) - (headers-info-msg-strings hinfo)) - :prompt "MH messages to pick from: ")) - (pick-exp (prompt-for-pick-expression)) - (msgs (pick-messages folder temp-msgs pick-exp)) - (virtually (value virtual-message-deletion))) - (declare (simple-string folder)) - (if virtually - (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-add")) - (mh "rmm" `(,folder ,@msgs))) - (if virtually - (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted"))) - (when deleted-seq - (do-headers-buffers (hbuf folder) - (with-writable-buffer (hbuf) - (note-deleted-headers hbuf deleted-seq))))) - (do-headers-buffers (hbuf folder hinfo) - (do-headers-lines (hbuf :line-var line :mark-var hmark) - (when (member (line-message-id line) msgs :test #'string=) - (delete-headers-buffer-line hinfo hmark))))))) - -(defcommand "Headers Delete Message" (p) - "Delete current message. - When in a headers buffer, deletes the message on the current line. When - in a message buffer, deletes that message. When \"Virtual Message - Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge - Messages\"." - "When in a headers buffer, deletes the message on the current line. When - in a message buffer, deletes that message. When \"Virtual Message - Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge - Messages\"." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (delete-message (headers-info-folder hinfo) cur-msg))) - (minfo - (let ((msgs (message-info-msgs minfo))) - (delete-message (message-info-folder minfo) - (if (consp msgs) (car msgs) msgs))) - (message "Message deleted.")) - (t (editor-error "Not in a headers or message buffer."))))) - -;;; DELETE-MESSAGE takes a folder and message id and either flags this message -;;; for deletion or deletes it. All headers buffers into folder are updated, -;;; either by flagging a headers line or deleting it. -;;; -(defun delete-message (folder msg) - (cond ((value virtual-message-deletion) - (mark-one-message folder msg "hemlockdeleted" :add) - (do-headers-buffers (hbuf folder) - (with-headers-mark (hmark hbuf msg) - (with-writable-buffer (hbuf) - (note-deleted-message-at-mark hmark))))) - (t (mh "rmm" (list folder msg)) - (do-headers-buffers (hbuf folder hinfo) - (with-headers-mark (hmark hbuf msg) - (delete-headers-buffer-line hinfo hmark))))) - (dolist (b *buffer-list*) - (when (and (hemlock-bound-p 'message-information :buffer b) - (buffer-modeline-field-p b :deleted-message)) - (dolist (w (buffer-windows b)) - (update-modeline-field b w :deleted-message))))) - -;;; NOTE-DELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid -;;; headers line, sticks a "D" on the line, and frobs the line's deleted -;;; property. This assumes the headers buffer is modifiable. -;;; -(defun note-deleted-message-at-mark (mark) - (find-attribute mark :digit) - (find-attribute mark :digit #'zerop) - (character-offset mark 2) - (setf (next-character mark) #\D) - (setf (line-message-deleted (mark-line mark)) t)) - -;;; DELETE-HEADERS-BUFFER-LINE takes a headers information and a mark on the -;;; line to be deleted. Before deleting the line, we check to see if any -;;; message or draft buffers refer to the buffer because of the line. Due -;;; to how regions are deleted, line plists get messed up, so they have to -;;; be regenerated. We regenerate them for the whole buffer, so we don't have -;;; to hack the code to know which lines got messed up. -;;; -(defun delete-headers-buffer-line (hinfo hmark) - (delete-headers-line-references hinfo hmark) - (let ((id (line-message-id (mark-line hmark))) - (hbuf (headers-info-buffer hinfo))) - (with-writable-buffer (hbuf) - (with-mark ((end (line-start hmark) :left-inserting)) - (unless (line-offset end 1 0) (buffer-end end)) - (delete-region (region hmark end)))) - (let ((seq (mh-sequence-delete id (headers-info-msg-seq hinfo)))) - (setf (headers-info-msg-seq hinfo) seq) - (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq))) - (set-message-headers-ids hbuf) - (when (value virtual-message-deletion) - (let ((deleted-seq (mh-sequence-list (headers-info-folder hinfo) - "hemlockdeleted"))) - (do-headers-lines (hbuf :line-var line) - (setf (line-message-deleted line) - (mh-sequence-member-p (line-message-id line) deleted-seq))))))) - - -;;; DELETE-HEADERS-LINE-REFERENCES removes any message buffer or draft buffer -;;; pointers to a headers buffer or marks into the headers buffer. Currently -;;; message buffers and draft buffers are identified differently for no good -;;; reason; probably message buffers should be located in the same way draft -;;; buffers are. Also, we currently assume only one of other-msg-bufs could -;;; refer to the line (similarly for draft-bufs), but this might be bug -;;; prone. The message buffer case couldn't happen since the buffer name -;;; would cause MAYBE-MAKE-MH-BUFFER to re-use the buffer, but you could reply -;;; to the same message twice simultaneously. -;;; -(defun delete-headers-line-references (hinfo hmark) - (let ((msg-id (line-message-id (mark-line hmark))) - (main-msg-buf (headers-info-msg-buffer hinfo))) - (declare (simple-string msg-id)) - (when main-msg-buf - (let ((minfo (variable-value 'message-information :buffer main-msg-buf))) - (when (string= (the simple-string (message-info-msgs minfo)) - msg-id) - (cond ((message-info-draft-buf minfo) - (cleanup-headers-reference main-msg-buf minfo) - (setf (headers-info-msg-buffer hinfo) nil)) - (t (delete-buffer-if-possible main-msg-buf)))))) - (dolist (mbuf (headers-info-other-msg-bufs hinfo)) - (let ((minfo (variable-value 'message-information :buffer mbuf))) - (when (string= (the simple-string (message-info-msgs minfo)) - msg-id) - (cond ((message-info-draft-buf minfo) - (cleanup-headers-reference mbuf minfo) - (setf (headers-info-other-msg-bufs hinfo) - (delete mbuf (headers-info-other-msg-bufs hinfo) - :test #'eq))) - (t (delete-buffer-if-possible mbuf))) - (return))))) - (dolist (dbuf (headers-info-draft-bufs hinfo)) - (let ((dinfo (variable-value 'draft-information :buffer dbuf))) - (when (same-line-p (draft-info-headers-mark dinfo) hmark) - (cleanup-headers-reference dbuf dinfo) - (setf (headers-info-draft-bufs hinfo) - (delete dbuf (headers-info-draft-bufs hinfo) :test #'eq)) - (return))))) - - -(defcommand "Undelete Message" (p) - "Prompts for a folder, messages to undelete, and pick expression. When in - a headers buffer into the same folder specified, the messages prompt - defaults to those messages in the buffer; \"all\" may be entered if this is - not what is desired. This command is only meaningful if you have - \"Virtual Message Deletion\" set." - "Prompts for a folder, messages to undelete, and pick expression. When in - a headers buffer into the same folder specified, the messages prompt - defaults to those messages in the buffer; \"all\" may be entered if this is - not what is desired. This command is only meaningful if you have - \"Virtual Message Deletion\" set." - (declare (ignore p)) - (unless (value virtual-message-deletion) - (editor-error "You don't use virtual message deletion.")) - (let* ((folder (prompt-for-folder)) - (hinfo (value headers-information)) - (temp-msgs (prompt-for-message - :folder folder - :messages - (if (and hinfo - (string= folder - (the simple-string - (headers-info-folder hinfo)))) - (headers-info-msg-strings hinfo)) - :prompt "MH messages to pick from: ")) - (pick-exp (prompt-for-pick-expression)) - (msgs (if pick-exp - (or (pick-messages folder temp-msgs pick-exp) temp-msgs) - temp-msgs))) - (declare (simple-string folder)) - (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-delete")) - (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted"))) - (do-headers-buffers (hbuf folder) - (with-writable-buffer (hbuf) - (do-headers-lines (hbuf :line-var line :mark-var hmark) - (when (and (line-message-deleted line) - (not (mh-sequence-member-p (line-message-id line) - deleted-seq))) - (note-undeleted-message-at-mark hmark)))))))) - -(defcommand "Headers Undelete Message" (p) - "Undelete the current message. - When in a headers buffer, undeletes the message on the current line. When - in a message buffer, undeletes that message. This command is only - meaningful if you have \"Virtual Message Deletion\" set." - "When in a headers buffer, undeletes the message on the current line. When - in a message buffer, undeletes that message. This command is only - meaningful if you have \"Virtual Message Deletion\" set." - (declare (ignore p)) - (unless (value virtual-message-deletion) - (editor-error "You don't use virtual message deletion.")) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (undelete-message (headers-info-folder hinfo) cur-msg))) - (minfo - (undelete-message (message-info-folder minfo) - (message-info-msgs minfo)) - (message "Message undeleted.")) - (t (editor-error "Not in a headers or message buffer."))))) - -;;; UNDELETE-MESSAGE takes a folder and a message id. All headers buffers into -;;; folder are updated. -;;; -(defun undelete-message (folder msg) - (mark-one-message folder msg "hemlockdeleted" :delete) - (do-headers-buffers (hbuf folder) - (with-headers-mark (hmark hbuf msg) - (with-writable-buffer (hbuf) - (note-undeleted-message-at-mark hmark)))) - (dolist (b *buffer-list*) - (when (and (hemlock-bound-p 'message-information :buffer b) - (buffer-modeline-field-p b :deleted-message)) - (dolist (w (buffer-windows b)) - (update-modeline-field b w :deleted-message))))) - -;;; NOTE-UNDELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid -;;; headers line, sticks a space on the line in place of a "D", and frobs the -;;; line's deleted property. This assumes the headers buffer is modifiable. -;;; -(defun note-undeleted-message-at-mark (hmark) - (find-attribute hmark :digit) - (find-attribute hmark :digit #'zerop) - (character-offset hmark 2) - (setf (next-character hmark) #\space) - (setf (line-message-deleted (mark-line hmark)) nil)) - - -(defcommand "Expunge Messages" (p) - "Expunges messages marked for deletion. - This command prompts for a folder, invoking RMM on the \"hemlockdeleted\" - sequence after asking the user for confirmation. Setting \"Quit Headers - Confirm\" to nil inhibits prompting. The folder's message id's are packed - with FOLDER -pack. When in a headers buffer, uses that folder. When in a - message buffer, uses its folder, updating any associated headers buffer. - When \"Temporary Draft Folder\" is bound, this folder's messages are deleted - and expunged." - "Prompts for a folder, invoking RMM on the \"hemlockdeleted\" sequence and - packing the message id's with FOLDER -pack. When in a headers buffer, - uses that folder." - (declare (ignore p)) - (let* ((hinfo (value headers-information)) - (minfo (value message-information)) - (folder (cond (hinfo (headers-info-folder hinfo)) - (minfo (message-info-folder minfo)) - (t (prompt-for-folder)))) - (deleted-seq (mh-sequence-list folder "hemlockdeleted"))) - ;; - ;; Delete the messages if there are any. - ;; This deletes "hemlockdeleted" from sequence file; we don't have to. - (when (and deleted-seq - (or (not (value expunge-messages-confirm)) - (prompt-for-y-or-n - :prompt (list "Expunge messages and pack folder ~A? " - folder) - :default t - :default-string "Y"))) - (message "Deleting messages ...") - (mh "rmm" (list folder "hemlockdeleted")) - ;; - ;; Compact the message id's after deletion. - (let ((*standard-output* *mh-utility-bit-bucket*)) - (message "Compacting folder ...") - (mh "folder" (list folder "-fast" "-pack"))) - ;; - ;; Do a bunch of consistency maintenance. - (let ((new-buf-p (eq (current-buffer) *new-mail-buffer*))) - (message "Maintaining consistency ...") - (expunge-messages-fold-headers-buffers folder) - (expunge-messages-fix-draft-buffers folder) - (expunge-messages-fix-unseen-headers folder) - (when new-buf-p (change-to-buffer *new-mail-buffer*))) - (delete-and-expunge-temp-drafts)))) - -;;; EXPUNGE-MESSAGES-FOLD-HEADERS-BUFFERS deletes all headers buffers into the -;;; compacted folder. We can only update the headers buffers by installing all -;;; headers, so there may as well be only one such buffer. First we get a list -;;; of the buffers since DO-HEADERS-BUFFERS is trying to iterate over a list -;;; being destructively modified by buffer deletions. -;;; -(defun expunge-messages-fold-headers-buffers (folder) - (let (hbufs) - (declare (list hbufs)) - (do-headers-buffers (b folder) - (unless (eq b *new-mail-buffer*) - (push b hbufs))) - (unless (zerop (length hbufs)) - (dolist (b hbufs) - (delete-headers-buffer-and-message-buffers-command nil b)) - (new-message-headers folder (list "all"))))) - -;;; EXPUNGE-MESSAGES-FIX-DRAFT-BUFFERS finds any draft buffer that was set up -;;; as a reply to some message in folder, removing this relationship in case -;;; that message id does not exist after expunge folder compaction. -;;; -(defun expunge-messages-fix-draft-buffers (folder) - (declare (simple-string folder)) - (dolist (b *buffer-list*) - (when (hemlock-bound-p 'draft-information :buffer b) - (let* ((dinfo (variable-value 'draft-information :buffer b)) - (reply-folder (draft-info-replied-to-folder dinfo))) - (when (and reply-folder - (string= (the simple-string reply-folder) folder)) - (setf (draft-info-replied-to-folder dinfo) nil) - (setf (draft-info-replied-to-msg dinfo) nil)))))) - -;;; EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS specially handles the unseen headers -;;; buffer apart from the other headers buffers into the same folder when -;;; messages have been expunged. We must delete the associated message buffers -;;; since REVAMP-HEADERS-BUFFER does not, and these potentially reference bad -;;; message id's. When doing this we must copy the other-msg-bufs list since -;;; the delete buffer cleanup hook for them is destructive. Then we check for -;;; more unseen messages. -;;; -(defun expunge-messages-fix-unseen-headers (folder) - (declare (simple-string folder)) - (when *new-mail-buffer* - (let ((hinfo (variable-value 'headers-information - :buffer *new-mail-buffer*))) - (when (string= (the simple-string (headers-info-folder hinfo)) - folder) - (let ((other-bufs (copy-list (headers-info-other-msg-bufs hinfo)))) - (dolist (b other-bufs) (delete-buffer-if-possible b))) - (with-writable-buffer (*new-mail-buffer*) - (revamp-headers-buffer *new-mail-buffer* hinfo) - ;; Restore the name in case someone used "Pick Headers". - (setf (buffer-name *new-mail-buffer*) - (format nil "Unseen Headers ~A" folder)) - (let ((region (maybe-get-new-mail-msg-hdrs folder))) - (when region - (insert-message-headers *new-mail-buffer* hinfo region)))))))) - -;;; MAYBE-GET-NEW-MAIL-MSG-HDRS returns a region suitable for a new mail buffer -;;; or nil. Folder is probed for unseen headers, and if there are some, then -;;; we call GET-NEW-MAIL-MSG-HDRS which also uses "Unseen Headers Message Spec". -;;; If there are no unseen headers, we only look for "Unseen Headers Message -;;; Spec" messages. We go through these contortions to keep MH from outputting -;;; errors. -;;; -(defun maybe-get-new-mail-msg-hdrs (folder) - (let ((unseen-seq-name (mh-profile-component "unseen-sequence"))) - (multiple-value-bind (unseen-seq foundp) - (mh-sequence-list folder unseen-seq-name) - (if (and foundp unseen-seq) - (get-new-mail-msg-hdrs folder unseen-seq-name) - (let ((spec (value unseen-headers-message-spec))) - (when spec - (message-headers-to-region - folder - (breakup-message-spec (string-trim '(#\space #\tab) spec))))))))) - - - -;;;; Folders. - -(defvar *folder-name-table* nil) - -(defun check-folder-name-table () - (unless *folder-name-table* - (message "Finding folder names ...") - (setf *folder-name-table* (make-string-table)) - (let* ((output (with-output-to-string (*standard-output*) - (mh "folders" '("-fast")))) - (length (length output)) - (start 0)) - (declare (simple-string output)) - (loop - (when (> start length) (return)) - (let ((nl (position #\newline output :start start))) - (unless nl (return)) - (unless (= start nl) - (setf (getstring (subseq output start nl) *folder-name-table*) t)) - (setf start (1+ nl))))))) - -(defcommand "List Folders" (p) - "Pop up a list of folders at top-level." - "Pop up a list of folders at top-level." - (declare (ignore p)) - (check-folder-name-table) - (with-pop-up-display (s) - (do-strings (f ignore *folder-name-table*) - (declare (ignore ignore)) - (write-line f s)))) - -(defcommand "Create Folder" (p) - "Creates a folder. If the folder already exists, an error is signaled." - "Creates a folder. If the folder already exists, an error is signaled." - (declare (ignore p)) - (let ((folder (prompt-for-folder :must-exist nil))) - (when (folder-existsp folder) - (editor-error "Folder already exists -- ~S!" folder)) - (create-folder folder))) - -(defcommand "Delete Folder" (p) - "Prompts for a folder and uses RMF to delete it." - "Prompts for a folder and uses RMF to delete it." - (declare (ignore p)) - (let* ((folder (prompt-for-folder)) - (*standard-output* *mh-utility-bit-bucket*)) - (mh "rmf" (list folder)) - ;; RMF doesn't recognize this documented switch. - ;; "-nointeractive")))) - (check-folder-name-table) - (delete-string (strip-folder-name folder) *folder-name-table*))) - - -(defvar *refile-default-destination* nil) - -(defcommand "Refile Message" (p) - "Prompts for a source folder, messages, pick expression, and a destination - folder to refile the messages." - "Prompts for a source folder, messages, pick expression, and a destination - folder to refile the messages." - (declare (ignore p)) - (let* ((src-folder (prompt-for-folder :prompt "Source folder: ")) - (hinfo (value headers-information)) - (temp-msgs (prompt-for-message - :folder src-folder - :messages - (if (and hinfo - (string= src-folder - (the simple-string - (headers-info-folder hinfo)))) - (headers-info-msg-strings hinfo)) - :prompt "MH messages to pick from: ")) - (pick-exp (prompt-for-pick-expression)) - ;; Return pick result or temp-msgs individually specified in a list. - (msgs (pick-messages src-folder temp-msgs pick-exp))) - (declare (simple-string src-folder)) - (refile-message src-folder msgs - (prompt-for-folder :must-exist nil - :prompt "Destination folder: " - :default *refile-default-destination*)))) - -(defcommand "Headers Refile Message" (p) - "Refile the current message. - When in a headers buffer, refiles the message on the current line, and when - in a message buffer, refiles that message, prompting for a destination - folder." - "When in a headers buffer, refiles the message on the current line, and when - in a message buffer, refiles that message, prompting for a destination - folder." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (refile-message (headers-info-folder hinfo) cur-msg - (prompt-for-folder - :must-exist nil - :prompt "Destination folder: " - :default *refile-default-destination*)))) - (minfo - (refile-message - (message-info-folder minfo) (message-info-msgs minfo) - (prompt-for-folder :must-exist nil - :prompt "Destination folder: " - :default *refile-default-destination*)) - (message "Message refiled.")) - (t - (editor-error "Not in a headers or message buffer."))))) - -;;; REFILE-MESSAGE refiles msg from src-folder to dst-folder. If dst-buffer -;;; doesn't exist, the user is prompted for creating it. All headers buffers -;;; concerning src-folder are updated. When msg is a list, we did a general -;;; message prompt, and we cannot know which headers lines to delete. -;;; -(defun refile-message (src-folder msg dst-folder) - (unless (folder-existsp dst-folder) - (cond ((prompt-for-y-or-n - :prompt "Destination folder doesn't exist. Create it? " - :default t :default-string "Y") - (create-folder dst-folder)) - (t (editor-error "Not refiling message.")))) - (mh "refile" `(,@(if (listp msg) msg (list msg)) - "-src" ,src-folder ,dst-folder)) - (setf *refile-default-destination* (strip-folder-name dst-folder)) - (if (listp msg) - (do-headers-buffers (hbuf src-folder hinfo) - (do-headers-lines (hbuf :line-var line :mark-var hmark) - (when (member (line-message-id line) msg :test #'string=) - (delete-headers-buffer-line hinfo hmark)))) - (do-headers-buffers (hbuf src-folder hinfo) - (with-headers-mark (hmark hbuf msg) - (delete-headers-buffer-line hinfo hmark))))) - - - -;;;; Miscellaneous commands. - -(defcommand "Mark Message" (p) - "Prompts for a folder, message, and sequence. By default the message is - added, but if an argument is supplied, the message is deleted. When in - a headers buffer or message buffer, only a sequence is prompted for." - "Prompts for a folder, message, and sequence. By default the message is - added, but if an argument is supplied, the message is deleted. When in - a headers buffer or message buffer, only a sequence is prompted for." - (let* ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (let ((seq-name (prompt-for-string :prompt "Sequence name: " - :trim t))) - (declare (simple-string seq-name)) - (when (string= "" seq-name) - (editor-error "Sequence name cannot be empty.")) - (mark-one-message (headers-info-folder hinfo) - cur-msg seq-name (if p :delete :add))))) - (minfo - (let ((msgs (message-info-msgs minfo)) - (seq-name (prompt-for-string :prompt "Sequence name: " - :trim t))) - (declare (simple-string seq-name)) - (when (string= "" seq-name) - (editor-error "Sequence name cannot be empty.")) - (mark-one-message (message-info-folder minfo) - (if (consp msgs) (car msgs) msgs) - seq-name (if p :delete :add)))) - (t - (let ((folder (prompt-for-folder)) - (seq-name (prompt-for-string :prompt "Sequence name: " - :trim t))) - (declare (simple-string seq-name)) - (when (string= "" seq-name) - (editor-error "Sequence name cannot be empty.")) - (mh "mark" `(,folder ,@(prompt-for-message :folder folder) - "-sequence" ,seq-name - ,(if p "-delete" "-add")))))))) - - -(defcommand "List Mail Buffers" (p) - "Show a list of all mail associated buffers. - If the buffer has an associated message buffer, it is displayed to the right - of the buffer name. If there is no message buffer, but the buffer is - associated with a headers buffer, then it is displayed. If the buffer is - modified then a * is displayed before the name." - "Display the names of all buffers in a with-random-typeout window." - (declare (ignore p)) - (let ((buffers nil)) - (declare (list buffers)) - (do-strings (n b *buffer-names*) - (declare (ignore n)) - (unless (eq b *echo-area-buffer*) - (cond ((hemlock-bound-p 'message-buffer :buffer b) - ;; Catches draft buffers associated with message buffers first. - (push (cons b (variable-value 'message-buffer :buffer b)) - buffers)) - ((hemlock-bound-p 'headers-buffer :buffer b) - ;; Then draft or message buffers associated with headers buffers. - (push (cons b (variable-value 'headers-buffer :buffer b)) - buffers)) - ((or (hemlock-bound-p 'draft-information :buffer b) - (hemlock-bound-p 'message-information :buffer b) - (hemlock-bound-p 'headers-information :buffer b)) - (push b buffers))))) - (with-pop-up-display (s :height (length buffers)) - (dolist (ele (nreverse buffers)) - (let* ((association (if (consp ele) (cdr ele))) - (b (if association (car ele) ele)) - (buffer-pathname (buffer-pathname b)) - (buffer-name (buffer-name b))) - (write-char (if (buffer-modified b) #\* #\space) s) - (if buffer-pathname - (format s "~A ~A~:[~;~50T~:*~A~]~%" - (file-namestring buffer-pathname) - (directory-namestring buffer-pathname) - (if association (buffer-name association))) - (format s "~A~:[~;~50T~:*~A~]~%" - buffer-name - (if association (buffer-name association))))))))) - - -(defcommand "Message Help" (p) - "Show this help." - "Show this help." - (declare (ignore p)) - (describe-mode-command nil "Message")) - -(defcommand "Headers Help" (p) - "Show this help." - "Show this help." - (declare (ignore p)) - (describe-mode-command nil "Headers")) - -(defcommand "Draft Help" (p) - "Show this help." - "Show this help." - (declare (ignore p)) - (describe-mode-command nil "Draft")) - - - -;;;; Prompting. - -;;; Folder prompting. -;;; - -(defun prompt-for-folder (&key (must-exist t) (prompt "MH Folder: ") - (default (mh-current-folder))) - "Prompts for a folder, using MH's idea of the current folder as a default. - The result will have a leading + in the name." - (check-folder-name-table) - (let ((folder (prompt-for-keyword (list *folder-name-table*) - :must-exist must-exist :prompt prompt - :default default :default-string default - :help "Enter folder name."))) - (declare (simple-string folder)) - (when (string= folder "") (editor-error "Must supply folder!")) - (let ((name (coerce-folder-name folder))) - (when (and must-exist (not (folder-existsp name))) - (editor-error "Folder does not exist -- ~S." name)) - name))) - -(defun coerce-folder-name (folder) - (if (char= (schar folder 0) #\+) - folder - (concatenate 'simple-string "+" folder))) - -(defun strip-folder-name (folder) - (if (char= (schar folder 0) #\+) - (subseq folder 1) - folder)) - - -;;; Message prompting. -;;; - -(defun prompt-for-message (&key (folder (mh-current-folder)) - (prompt "MH messages: ") - messages) - "Prompts for a message spec, using messages as a default. If messages is - not supplied, then the current message for folder is used. The result is - a list of strings which are the message ids, intervals, and/or sequence - names the user entered." - (let* ((cur-msg (cond ((not messages) (mh-current-message folder)) - ((stringp messages) messages) - ((consp messages) - (if (= (length (the list messages)) 1) - (car messages) - (format nil "~{~A~^ ~}" messages)))))) - (breakup-message-spec (prompt-for-string :prompt prompt - :default cur-msg - :default-string cur-msg - :trim t - :help "Enter MH message id(s).")))) - -(defun breakup-message-spec (msgs) - (declare (simple-string msgs)) - (let ((start 0) - (result nil)) - (loop - (let ((end (position #\space msgs :start start :test #'char=))) - (unless end - (return (if (zerop start) - (list msgs) - (nreverse (cons (subseq msgs start) result))))) - (push (subseq msgs start end) result) - (setf start (1+ end)))))) - - -;;; PICK expression prompting. -;;; - -(defhvar "MH Lisp Expression" - "When this is set (the default), MH expression prompts are read in a Lisp - syntax. Otherwise, the input is as if it had been entered on a shell - command line." - :value t) - -;;; This is dynamically bound to nil for argument processing routines. -;;; -(defvar *pick-expression-strings* nil) - -(defun prompt-for-pick-expression () - "Prompts for an MH PICK-like expression that is converted to a list of - strings suitable for EXT:RUN-PROGRAM. As a second value, the user's - expression is as typed in is returned." - (let ((exp (prompt-for-string :prompt "MH expression: " - :help "Expression to PICK over mail messages." - :trim t)) - (*pick-expression-strings* nil)) - (if (value mh-lisp-expression) - (let ((exp (let ((*package* *keyword-package*)) - (read-from-string exp)))) - (if exp - (if (consp exp) - (lisp-to-pick-expression exp) - (editor-error "Lisp PICK expressions cannot be atomic.")))) - (expand-mh-pick-spec exp)) - (values (nreverse *pick-expression-strings*) - exp))) - -(defun lisp-to-pick-expression (exp) - (ecase (car exp) - (:and (lpe-and/or exp "-and")) - (:or (lpe-and/or exp "-or")) - (:not (push "-not" *pick-expression-strings*) - (let ((nexp (cadr exp))) - (unless (consp nexp) (editor-error "Bad expression -- ~S" nexp)) - (lisp-to-pick-expression nexp))) - - (:cc (lpe-output-and-go exp "-cc")) - (:date (lpe-output-and-go exp "-date")) - (:from (lpe-output-and-go exp "-from")) - (:search (lpe-output-and-go exp "-search")) - (:subject (lpe-output-and-go exp "-subject")) - (:to (lpe-output-and-go exp "-to")) - (:-- (lpe-output-and-go (cdr exp) - (concatenate 'simple-string - "--" (string (cadr exp))))) - - (:before (lpe-after-and-before exp "-before")) - (:after (lpe-after-and-before exp "-after")) - (:datefield (lpe-output-and-go exp "-datefield")))) - -(defun lpe-after-and-before (exp op) - (let ((operand (cadr exp))) - (when (numberp operand) - (setf (cadr exp) - (if (plusp operand) - (number-string (- operand)) - (number-string operand))))) - (lpe-output-and-go exp op)) - -(defun lpe-output-and-go (exp op) - (push op *pick-expression-strings*) - (let ((operand (cadr exp))) - (etypecase operand - (string (push operand *pick-expression-strings*)) - (symbol (push (symbol-name operand) - *pick-expression-strings*))))) - -(defun lpe-and/or (exp op) - (push "-lbrace" *pick-expression-strings*) - (dolist (ele (cdr exp)) - (lisp-to-pick-expression ele) - (push op *pick-expression-strings*)) - (pop *pick-expression-strings*) ;Clear the extra "-op" arg. - (push "-rbrace" *pick-expression-strings*)) - -;;; EXPAND-MH-PICK-SPEC takes a string of "words" assumed to be separated -;;; by single spaces. If a "word" starts with a quotation mark, then -;;; everything is grabbed up to the next one and used as a single word. -;;; Currently, this does not worry about extra spaces (or tabs) between -;;; "words". -;;; -(defun expand-mh-pick-spec (spec) - (declare (simple-string spec)) - (let ((start 0)) - (loop - (let ((end (position #\space spec :start start :test #'char=))) - (unless end - (if (zerop start) - (setf *pick-expression-strings* (list spec)) - (push (subseq spec start) *pick-expression-strings*)) - (return)) - (cond ((char= #\" (schar spec start)) - (setf end (position #\" spec :start (1+ start) :test #'char=)) - (unless end (editor-error "Bad quoting syntax.")) - (push (subseq spec (1+ start) end) *pick-expression-strings*) - (setf start (+ end 2))) - (t (push (subseq spec start end) *pick-expression-strings*) - (setf start (1+ end)))))))) - - -;;; Password prompting. -;;; - -(defun prompt-for-password (&optional (prompt "Password: ")) - "Prompts for password with prompt." - (let ((hi::*parse-verification-function* #'(lambda (string) (list string)))) - (let ((hi::*parse-prompt* prompt)) - (hi::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* - (let ((result ())) - (declare (list result)) - (loop - (let ((char (read-char *editor-input*))) - (ring-pop hi::*character-history*) - (cond ((char= char #\return) - (return (prog1 (coerce (nreverse result) 'simple-string) - (fill result nil)))) - ((or (char= char #\control-u) (char= char #\control-\u)) - (setf result nil)) - (t (push char result))))))) - (setf (current-window) start-window))))) - - - - -;;;; Making mail buffers. - -;;; MAYBE-MAKE-MH-BUFFER looks up buffer with name, returning it if it exists -;;; after cleaning it up to a state "good as new". Currently, we don't -;;; believe it is possible to try to make two draft buffers with the same name -;;; since that would mean that composition, draft folder interaction, and -;;; draft folder current message didn't do what we expected -- or some user -;;; was modifying the draft folder in some evil way. -;;; -(defun maybe-make-mh-buffer (name use) - (let ((buf (getstring name *buffer-names*))) - (cond ((not buf) - (ecase use - (:headers (make-buffer name - :modes '("Headers") - :delete-hook '(cleanup-headers-buffer))) - - (:message - (make-buffer name :modes '("Message") - :modeline-fields - (value default-message-modeline-fields) - :delete-hook '(cleanup-message-buffer))) - - (:draft - (let ((buf (make-buffer - name :delete-hook '(cleanup-draft-buffer)))) - (setf (buffer-minor-mode buf "Draft") t) - buf)))) - ((hemlock-bound-p 'headers-information :buffer buf) - (setf (buffer-writable buf) t) - (delete-region (buffer-region buf)) - (cleanup-headers-buffer buf) - (delete-variable 'headers-information :buffer buf) - buf) - ((hemlock-bound-p 'message-information :buffer buf) - (setf (buffer-writable buf) t) - (delete-region (buffer-region buf)) - (cleanup-message-buffer buf) - (delete-variable 'message-information :buffer buf) - buf) - ((hemlock-bound-p 'draft-information :buffer buf) - (error "Attempt to create multiple draft buffers to same draft ~ - folder message -- ~S" - name))))) - - -;;;; Message buffer modeline fields. - -(make-modeline-field - :name :deleted-message :width 2 - :function - #'(lambda (buffer window) - "Returns \"D \" when message in buffer is deleted." - (declare (ignore window)) - (let* ((minfo (variable-value 'message-information :buffer buffer)) - (hmark (message-info-headers-mark minfo))) - (cond ((not hmark) - (let ((msgs (message-info-msgs minfo))) - (if (and (value virtual-message-deletion) - (mh-sequence-member-p - (if (consp msgs) (car msgs) msgs) - (mh-sequence-list (message-info-folder minfo) - "hemlockdeleted"))) - "D " - ""))) - ((line-message-deleted (mark-line hmark)) - "D ") - (t ""))))) - -(make-modeline-field - :name :replied-to-message :width 1 - :function - #'(lambda (buffer window) - "Returns \"A\" when message in buffer is deleted." - (declare (ignore window)) - (let* ((minfo (variable-value 'message-information :buffer buffer)) - (hmark (message-info-headers-mark minfo))) - (cond ((not hmark) - ;; Could do something nasty here to figure out the right value. - "") - (t - (mark-to-note-replied-msg hmark) - (if (char= (next-character hmark) #\A) - "A" - "")))))) - -;;; MARK-TO-NOTE-REPLIED-MSG moves the headers-buffer mark to a line position -;;; suitable for checking or setting the next character with respect to noting -;;; that a message has been replied to. -;;; -(defun mark-to-note-replied-msg (hmark) - (line-start hmark) - (find-attribute hmark :digit) - (find-attribute hmark :digit #'zerop) - (character-offset hmark 1)) - - -(defhvar "Default Message Modeline Fields" - "This is the default list of modeline-field objects for message buffers." - :value - (list (modeline-field :hemlock-literal) (modeline-field :package) - (modeline-field :modes) (modeline-field :buffer-name) - (modeline-field :replied-to-message) (modeline-field :deleted-message) - (modeline-field :buffer-pathname) (modeline-field :modifiedp))) - - - -;;;; MH interface. - -;;; Running an MH utility. -;;; - -(defhvar "MH Utility Pathname" - "MH utility names are merged with this. The default is - \"/usr/misc/.mh/bin/\"." - :value (pathname "/usr/misc/.mh/bin/")) - -(defvar *signal-mh-errors* t - "This is the default value for whether MH signals errors. It is useful to - bind this to nil when using PICK-MESSAGES with the \"Incorporate New Mail - Hook\".") - -(defvar *mh-error-output* (make-string-output-stream)) - -(defun mh (utility args &key (errorp *signal-mh-errors*) - password username environment) - "Runs the MH utility with the list of args (suitable for EXT:RUN-PROGRAM), - outputting to *standard-output*. If password is supplied, then the MH - utility is run with RFS authentication. If username is nil, this looks it - up on the editor's machine. Environment is a list of strings appended with - ext:*environment-list*. This returns t, unless there is an error. - When errorp, this reports any MH errors in the echo area as an editor error, - and this does not return; otherwise, nil and the error output from the MH - utility are returned." - (fresh-line) - (let* ((utility (namestring (truename - (merge-pathnames utility - (value mh-utility-pathname))))) - (proc (ext:run-program - utility args - :output *standard-output* - :error *mh-error-output* - :env (append environment ext:*environment-list*) - :before-execve - (if password - #'(lambda () - (mach:rfs-authenticate - (or username - (lisp::lookup-login-name (mach:unix-getuid))) - nil nil password)))))) - (fresh-line) - (ext:process-close proc) - (cond ((zerop (ext:process-exit-code proc)) - (values t nil)) - (errorp - (editor-error "MH Error -- ~A" - (get-output-stream-string *mh-error-output*))) - (t (values nil (get-output-stream-string *mh-error-output*)))))) - - - -;;; Draft folder name and pathname. -;;; - -(defun mh-draft-folder () - (let ((drafts (mh-profile-component "draft-folder"))) - (unless drafts - (error "There must be a draft-folder component in your profile.")) - drafts)) - -(defun mh-draft-folder-pathname () - "Returns the pathname of the MH draft folder directory." - (let ((drafts (mh-profile-component "draft-folder"))) - (unless drafts - (error "There must be a draft-folder component in your profile.")) - (merge-relative-pathnames drafts (mh-directory-pathname)))) - - -;;; Current folder name. -;;; - -(defun mh-current-folder () - "Returns the current MH folder from the context file." - (mh-profile-component "current-folder" (mh-context-pathname))) - - -;;; Current message name. -;;; - -(defun mh-current-message (folder) - "Returns the current MH message from the folder's sequence file." - (declare (simple-string folder)) - (let ((folder (strip-folder-name folder))) - (mh-profile-component - "cur" - (merge-pathnames ".mh_sequences" - (merge-relative-pathnames folder - (mh-directory-pathname)))))) - - -;;; Context pathname. -;;; - -(defvar *mh-context-pathname* nil) - -(defun mh-context-pathname () - "Returns the pathname of the MH context file." - (or *mh-context-pathname* - (setf *mh-context-pathname* - (merge-pathnames (or (mh-profile-component "context") "context") - (mh-directory-pathname))))) - - -;;; MH directory pathname. -;;; - -(defvar *mh-directory-pathname* nil) - -;;; MH-DIRECTORY-PATHNAME fetches the "path" MH component and bashes it -;;; appropriately to get an absolute directory pathname. -;;; -(defun mh-directory-pathname () - "Returns the pathname of the MH directory." - (if *mh-directory-pathname* - *mh-directory-pathname* - (let ((path (mh-profile-component "path"))) - (unless path (error "MH profile does not contain a Path component.")) - (setf *mh-directory-pathname* - (merge-relative-pathnames path (user-homedir-pathname)))))) - -;;; Profile components. -;;; - -(defun mh-profile-component (name &optional (pathname (mh-profile-pathname)) - (error-on-open t)) - "Returns the trimmed string value for the MH profile component name. If - the component is not present, nil is returned. This may be used on MH - context and sequence files as well due to their having the same format. - Error-on-open indicates that errors generated by OPEN should not be ignored, - which is the default. When opening a sequence file, it is better to supply - this as nil since the file may not exist or be readable in another user's - MH folder, and returning nil meaning the sequence could not be found is just - as useful." - (with-open-stream (s (if error-on-open - (open pathname) - (ignore-errors (open pathname)))) - (if s - (loop - (multiple-value-bind (line eofp) (read-line s nil :eof) - (when (eq line :eof) (return nil)) - (let ((colon (position #\: (the simple-string line) :test #'char=))) - (unless colon - (error "Bad record ~S in file ~S." line (namestring pathname))) - (when (string-equal name line :end2 colon) - (return (string-trim '(#\space #\tab) - (subseq line (1+ colon)))))) - (when eofp (return nil))))))) - - -;;; Profile pathname. -;;; - -(defvar *mh-profile-pathname* nil) - -(defun mh-profile-pathname () - "Returns the pathname of the MH profile." - (or *mh-profile-pathname* - (setf *mh-profile-pathname* - (merge-pathnames (or (cdr (assoc :mh ext:*environment-list*)) - ".mh_profile") - (user-homedir-pathname))))) - - - -;;;; Sequence handling. - -(defun mark-one-message (folder msg sequence add-or-delete) - "Msg is added or deleted to the sequence named sequence in the folder's - \".mh_sequence\" file. Add-or-delete is either :add or :delete." - (let ((seq-list (mh-sequence-list folder sequence))) - (ecase add-or-delete - (:add - (write-mh-sequence folder sequence (mh-sequence-insert msg seq-list))) - (:delete - (when (mh-sequence-member-p msg seq-list) - (write-mh-sequence folder sequence - (mh-sequence-delete msg seq-list))))))) - - -(defun mh-sequence-list (folder name) - "Returns a list representing the messages and ranges of id's for the - sequence name in folder from the \".mh_sequences\" file. A second value - is returned indicating whether the sequence was found or not." - (declare (simple-string folder)) - (let* ((folder (strip-folder-name folder)) - (seq-string (mh-profile-component - name - (merge-pathnames ".mh_sequences" - (merge-relative-pathnames - folder (mh-directory-pathname))) - nil))) - (if (not seq-string) - (values nil nil) - (let ((length (length (the simple-string seq-string))) - (result ()) - (intervalp nil) - (start 0)) - (declare (fixnum length start)) - (loop - (multiple-value-bind (msg index) - (parse-integer seq-string - :start start :end length - :junk-allowed t) - (unless msg (return)) - (cond ((or (= index length) - (char/= (schar seq-string index) #\-)) - (if intervalp - (setf (cdar result) msg) - (push (cons msg msg) result)) - (setf intervalp nil) - (setf start index)) - (t - (push (cons msg nil) result) - (setf intervalp t) - (setf start (1+ index))))) - (when (>= start length) (return))) - (values (nreverse result) t))))) - -(defun write-mh-sequence (folder name seq-list) - "Writes seq-list to folder's \".mh_sequences\" file. If seq-list is nil, - the sequence is removed from the file." - (declare (simple-string folder)) - (let* ((folder (strip-folder-name folder)) - (input (merge-pathnames ".mh_sequences" - (merge-relative-pathnames - folder (mh-directory-pathname)))) - (input-dir (pathname (directory-namestring input))) - (output (loop (let* ((sym (gensym)) - (f (merge-pathnames - (format nil "sequence-file-~A.tmp" sym) - input-dir))) - (unless (probe-file f) (return f))))) - (found nil)) - (cond ((not (file-writable output)) - (loud-message "Cannot write sequence temp file ~A.~%~ - Aborting output of ~S sequence." - name (namestring output))) - (t - (with-open-file (in input) - (with-open-file (out output :direction :output) - (loop - (multiple-value-bind (line eofp) (read-line in nil :eof) - (when (eq line :eof) - (return nil)) - (let ((colon (position #\: (the simple-string line) - :test #'char=))) - (unless colon - (error "Bad record ~S in file ~S." - line (namestring input))) - (cond ((and (not found) (string-equal name line - :end2 colon)) - (sub-write-mh-sequence - out (subseq line 0 colon) seq-list) - (setf found t)) - (t (write-line line out)))) - (when eofp (return)))) - (unless found - (fresh-line out) - (sub-write-mh-sequence out name seq-list)))) - (hacking-rename-file output input))))) - -(defun sub-write-mh-sequence (stream name seq-list) - (when seq-list - (write-string name stream) - (write-char #\: stream) - (let ((*print-base* 10)) - (dolist (range seq-list) - (write-char #\space stream) - (let ((low (car range)) - (high (cdr range))) - (declare (fixnum low high)) - (cond ((= low high) - (prin1 low stream)) - (t (prin1 low stream) - (write-char #\- stream) - (prin1 high stream)))))) - (terpri stream))) - - -;;; MH-SEQUENCE-< keeps SORT from consing rest args when FUNCALL'ing #'<. -;;; -(defun mh-sequence-< (x y) - (< x y)) - -(defun mh-sequence-insert (item seq-list) - "Inserts item into an mh sequence list. Item can be a string (\"23\"), - number (23), or a cons of two numbers ((23 . 23) or (3 . 5))." - (let ((range (typecase item - (string (let ((id (parse-integer item))) - (cons id id))) - (cons item) - (number (cons item item))))) - (cond (seq-list - (setf seq-list (sort (cons range seq-list) - #'mh-sequence-< :key #'car)) - (coelesce-mh-sequence-ranges seq-list)) - (t (list range))))) - -(defun coelesce-mh-sequence-ranges (seq-list) - (when seq-list - (let* ((current seq-list) - (next (cdr seq-list)) - (current-range (car current)) - (current-end (cdr current-range))) - (declare (fixnum current-end)) - (loop - (unless next - (setf (cdr current-range) current-end) - (setf (cdr current) nil) - (return)) - (let* ((next-range (car next)) - (next-start (car next-range)) - (next-end (cdr next-range))) - (declare (fixnum next-start next-end)) - (cond ((<= (1- next-start) current-end) - ;; - ;; Extend the current range since the next one overlaps. - (when (> next-end current-end) - (setf current-end next-end))) - (t - ;; - ;; Update the current range since the next one doesn't overlap. - (setf (cdr current-range) current-end) - ;; - ;; Make the next range succeed current. Then make it current. - (setf (cdr current) next) - (setf current next) - (setf current-range next-range) - (setf current-end next-end)))) - (setf next (cdr next)))) - seq-list)) - - -(defun mh-sequence-delete (item seq-list) - "Inserts item into an mh sequence list. Item can be a string (\"23\"), - number (23), or a cons of two numbers ((23 . 23) or (3 . 5))." - (let ((range (typecase item - (string (let ((id (parse-integer item))) - (cons id id))) - (cons item) - (number (cons item item))))) - (when seq-list - (do ((id (car range) (1+ id)) - (end (cdr range))) - ((> id end)) - (setf seq-list (sub-mh-sequence-delete id seq-list))) - seq-list))) - -(defun sub-mh-sequence-delete (id seq-list) - (do ((prev nil seq) - (seq seq-list (cdr seq))) - ((null seq)) - (let* ((range (car seq)) - (low (car range)) - (high (cdr range))) - (cond ((> id high)) - ((< id low) - (return)) - ((= id low) - (cond ((/= low high) - (setf (car range) (1+ id))) - (prev - (setf (cdr prev) (cdr seq))) - (t (setf seq-list (cdr seq-list)))) - (return)) - ((= id high) - (setf (cdr range) (1- id)) - (return)) - ((< low id high) - (setf (cdr range) (1- id)) - (setf (cdr seq) (cons (cons (1+ id) high) (cdr seq))) - (return))))) - seq-list) - - -(defun mh-sequence-member-p (item seq-list) - "Returns to or nil whether item is in the mh sequence list. Item can be a - string (\"23\") or a number (23)." - (let ((id (typecase item - (string (parse-integer item)) - (number item)))) - (dolist (range seq-list nil) - (let ((low (car range)) - (high (cdr range))) - (when (<= low id high) (return t)))))) - - -(defun mh-sequence-strings (seq-list) - "Returns a list of strings representing the ranges and messages id's in - seq-list." - (let ((result nil)) - (dolist (range seq-list) - (let ((low (car range)) - (high (cdr range))) - (if (= low high) - (push (number-string low) result) - (push (format nil "~D-~D" low high) result)))) - (nreverse result))) - - - -;;;; CMU Common Lisp support. - -;;; HACKING-RENAME-FILE renames old to new. This is used instead of Common -;;; Lisp's RENAME-FILE because it merges new pathname with old pathname, -;;; which loses when old has a name and type, and new has only a type (a -;;; Unix-oid "dot" file). -;;; -(defun hacking-rename-file (old new) - (let ((ses-name1 (namestring old)) - (ses-name2 (namestring new))) - (multiple-value-bind (res err) (mach:unix-rename ses-name1 ses-name2) - (unless res - (error "Failed to rename ~A to ~A: ~A." - ses-name1 ses-name2 (mach:get-unix-error-msg err)))))) - - -;;; Folder existence and creation. -;;; - -(defun folder-existsp (folder) - "Returns t if the directory for folder exists. Folder is a simple-string - specifying a folder name relative to the MH mail directoy." - (declare (simple-string folder)) - (let* ((folder (strip-folder-name folder)) - (pathname (merge-relative-pathnames folder (mh-directory-pathname))) - (ses-name (namestring pathname))) - (multiple-value-bind (winp type) - (mach:unix-subtestname ses-name) - (and winp (eq type :entry_directory))))) - -(defun create-folder (folder) - "Creates folder directory with default protection #o711 but considers the - MH profile for the \"Folder-Protect\" component. Folder is a simple-string - specifying a folder name relative to the MH mail directory." - (declare (simple-string folder)) - (let* ((folder (strip-folder-name folder)) - (pathname (merge-relative-pathnames folder (mh-directory-pathname))) - (ses-name (namestring pathname)) - (length-1 (1- (length ses-name))) - (name (if (= (position #\/ ses-name :test #'char= :from-end t) - length-1) - (subseq ses-name 0 (1- (length ses-name))) - ses-name)) - (protection (mh-profile-component "folder-protect"))) - (when protection - (setf protection - (parse-integer protection :radix 8 :junk-allowed t))) - (multiple-value-bind (winp err) - (mach:unix-mkdir name (or protection #o711)) - (unless winp - (error "Couldn't make directory ~S: ~A" - name - (mach:get-unix-error-msg err))) - (check-folder-name-table) - (setf (getstring folder *folder-name-table*) t)))) - - -;;; Checking for mail. -;;; - -(defvar *mailbox* nil) - -(defun new-mail-p () - (unless *mailbox* - (setf *mailbox* - (probe-file (or (cdr (assoc :mail ext:*environment-list*)) - (cdr (assoc :maildrop ext:*environment-list*)) - (mh-profile-component "mail-drop") - (merge-pathnames - (cdr (assoc :user ext:*environment-list*)) - "/usr/spool/mail/"))))) - (when *mailbox* - (multiple-value-bind (success dev ino mode nlink uid gid rdev size - atime) - (mach:unix-stat (namestring *mailbox*)) - (declare (ignore dev ino nlink uid gid rdev atime)) - (and success - (plusp (logand mach::s_ifreg mode)) - (not (zerop size)))))) - - - diff --git a/hemlock/morecoms.lisp b/hemlock/morecoms.lisp deleted file mode 100644 index 8f018c28b0195eb656f8e404f4421c1b61cd894f..0000000000000000000000000000000000000000 --- a/hemlock/morecoms.lisp +++ /dev/null @@ -1,825 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles and Rob MacLachlan. -;;; -;;; Even more commands... - -(in-package "HEMLOCK") - -(defhvar "Region Query Size" - "A number-of-lines threshold that destructive, undoable region commands - should ask the user about when the indicated region is too big." - :value 30) - -(defun check-region-query-size (region) - "Checks the number of lines in region against \"Region Query Size\" and - asks the user if the region crosses this threshold. If the user responds - negatively, then an editor error is signaled." - (let ((threshold (or (value region-query-size) 0))) - (if (and (plusp threshold) - (>= (count-lines region) threshold) - (not (prompt-for-y-or-n - :prompt "Region size exceeds \"Region Query Size\". Confirm: " - :must-exist t))) - (editor-error)))) - - - -;;;; Casing commands... - -(defcommand "Uppercase Word" (p) - "Uppercase a word at point. - With prefix argument uppercase that many words." - "Uppercase p words at the point." - (filter-words p (current-point) #'string-upcase)) - -(defcommand "Lowercase Word" (p) - "Uppercase a word at point. - With prefix argument uppercase that many words." - "Uppercase p words at the point." - (filter-words p (current-point) #'string-downcase)) - -;;; FILTER-WORDS implements "Uppercase Word" and "Lowercase Word". -;;; -(defun filter-words (p point function) - (let ((arg (or p 1))) - (with-mark ((mark point)) - (if (word-offset (if (minusp arg) mark point) arg) - (filter-region function (region mark point)) - (editor-error "Not enough words."))))) - -;;; "Capitalize Word" is different than uppercasing and lowercasing because -;;; the differences between Hemlock's notion of what a word is and Common -;;; Lisp's notion are too annoying. -;;; -(defcommand "Capitalize Word" (p) - "Lowercase a word capitalizing the first character. With a prefix - argument, capitalize that many words. A negative argument capitalizes - words before the point, but leaves the point where it was." - "Capitalize p words at the point." - (let ((point (current-point)) - (arg (or p 1))) - (with-mark ((start point :left-inserting) - (end point)) - (when (minusp arg) - (unless (word-offset start arg) (editor-error "No previous word."))) - (do ((region (region start end)) - (cnt (abs arg) (1- cnt))) - ((zerop cnt) (move-mark point end)) - (unless (find-attribute start :word-delimiter #'zerop) - (editor-error "No next word.")) - (move-mark end start) - (find-attribute end :word-delimiter) - (loop - (when (mark= start end) - (move-mark point end) - (editor-error "No alphabetic characters in word.")) - (when (alpha-char-p (next-character start)) (return)) - (character-offset start 1)) - (setf (next-character start) (char-upcase (next-character start))) - (mark-after start) - (filter-region #'string-downcase region))))) - -(defcommand "Uppercase Region" (p) - "Uppercase words from point to mark." - "Uppercase words from point to mark." - (declare (ignore p)) - (twiddle-region (current-region) #'string-upcase "Uppercase Region")) - -(defcommand "Lowercase Region" (p) - "Lowercase words from point to mark." - "Lowercase words from point to mark." - (declare (ignore p)) - (twiddle-region (current-region) #'string-downcase "Lowercase Region")) - -;;; TWIDDLE-REGION implements "Uppercase Region" and "Lowercase Region". -;;; -(defun twiddle-region (region function name) - (let* (;; don't delete marks start and end since undo stuff will. - (start (copy-mark (region-start region) :left-inserting)) - (end (copy-mark (region-end region) :left-inserting))) - (let* ((region (region start end)) - (undo-region (copy-region region))) - (check-region-query-size region) - (filter-region function region) - (make-region-undo :twiddle name region undo-region)))) - - - -;;;; More stuff. - -(defcommand "Delete Previous Character Expanding Tabs" (p) - "Delete the previous character. - When deleting a tab pretend it is the equivalent number of spaces. - With prefix argument, do it that many times." - "Delete the P previous characters, expanding tabs into spaces." - (let ((point (current-point)) - (n (or p 1))) - (when (minusp n) - (editor-error "Delete Previous Character Expanding Tabs only accepts ~ - positive arguments.")) - (let ((errorp nil)) - (with-mark ((mark point :left-inserting)) - (dotimes (i n) - (cond ((char= (previous-character mark) #\tab) - (let ((pos (mark-column mark))) - (delete-characters mark -1) - (dotimes (i (- pos (mark-column mark))) - (insert-character mark #\space)) - (mark-before mark))) - ((mark-before mark)) - (t (return))))) - (kill-characters point (- n)) - (when errorp - (editor-error "There were not ~D characters before point." n))))) - - -(defvar *scope-table* - (list (make-string-table :initial-contents - '(("Global" . :global) - ("Buffer" . :buffer) - ("Mode" . :mode))))) - -(defun prompt-for-place (prompt help) - (multiple-value-bind (word val) - (prompt-for-keyword *scope-table* :prompt prompt - :help help :default "Global") - (declare (ignore word)) - (case val - (:buffer - (values :buffer (prompt-for-buffer :help "Buffer to be local to." - :default (current-buffer)))) - (:mode - (values :mode (prompt-for-keyword - (list *mode-names*) - :prompt "Mode: " - :help "Mode to be local to." - :default (buffer-major-mode (current-buffer))))) - (:global :global)))) - -(defcommand "Bind Key" (p) - "Bind a command to a key. - The command, key and place to make the binding are prompted for." - "Prompt for stuff to do a bind-key." - (declare (ignore p)) - (multiple-value-call #'bind-key - (values (prompt-for-keyword - (list *command-names*) - :prompt "Command to bind: " - :help "Name of command to bind to a key.")) - (values (prompt-for-key - :prompt "Bind to: " :must-exist nil - :help "Key to bind command to, confirm to complete.")) - (prompt-for-place "Kind of binding: " - "The kind of binding to make."))) - -(defcommand "Delete Key Binding" (p) - "Delete a key binding. - The key and place to remove the binding are prompted for." - "Prompt for stuff to do a delete-key-binding." - (declare (ignore p)) - (let ((key (prompt-for-key - :prompt "Delete binding: " :must-exist nil - :help "Key to delete binding from."))) - (multiple-value-bind (kind where) - (prompt-for-place "Kind of binding: " - "The kind of binding to make.") - (unless (get-command key kind where) - (editor-error "No such binding: ~S" key)) - (delete-key-binding key kind where)))) - - -(defcommand "Set Variable" (p) - "Prompt for a Hemlock variable and a new value." - "Prompt for a Hemlock variable and a new value." - (declare (ignore p)) - (multiple-value-bind (name var) - (prompt-for-variable - :prompt "Variable: " - :help "The name of a variable to set.") - (declare (ignore name)) - (setf (variable-value var) - (handle-lisp-errors - (eval (prompt-for-expression - :prompt "Value: " - :help "Expression to evaluate for new value.")))))) - -(defcommand "Defhvar" (p) - "Define a hemlock variable in some location. If the named variable exists - currently, its documentation is propagated to the new instance, but this - never prompts for documentation." - "Define a hemlock variable in some location." - (declare (ignore p)) - (let* ((name (nstring-capitalize (prompt-for-variable :must-exist nil))) - (var (string-to-variable name)) - (doc (if (hemlock-bound-p var) - (variable-documentation var) - "")) - (hooks (if (hemlock-bound-p var) (variable-hooks var))) - (val (prompt-for-expression :prompt "Variable value: " - :help "Value for the variable."))) - (multiple-value-bind - (kind where) - (prompt-for-place - "Kind of binding: " - "Whether the variable is global, mode, or buffer specific.") - (if (eq kind :global) - (defhvar name doc :value val :hooks hooks) - (defhvar name doc kind where :value val :hooks hooks))))) - - -(defcommand "List Buffers" (p) - "Show a list of all buffers. - If the buffer is modified then a * is displayed before the name. If there - is an associated file then it's name is displayed last. With prefix - argument, only list modified buffers." - "Display the names of all buffers in a with-random-typeout window." - (with-pop-up-display (s) - (do-strings (n b *buffer-names*) - (declare (simple-string n)) - (unless (or (eq b *echo-area-buffer*) - (assoc b *random-typeout-buffers* :test #'eq)) - (let ((modified (buffer-modified b)) - (buffer-pathname (buffer-pathname b))) - (when (or (not p) modified) - (write-char (if modified #\* #\space) s) - (if buffer-pathname - (format s "~A ~25T~A~:[~68T~A~;~]~%" - (file-namestring buffer-pathname) - (directory-namestring buffer-pathname) - (string= (pathname-to-buffer-name buffer-pathname) n) - n) - (format s "~A~68T~D Line~:P~%" - n (count-lines (buffer-region b)))))))))) - -(defcommand "Select Random Typeout Buffer" (p) - "Select last random typeout buffer." - "Select last random typeout buffer." - (declare (ignore p)) - (if *random-typeout-buffers* - (change-to-buffer (caar *random-typeout-buffers*)) - (editor-error "There are no random typeout buffers."))) - - -(defcommand "Room" (p) - "Display stats on allocated storage." - "Run Room into a With-Random-Typeout window." - (declare (ignore p)) - (with-pop-up-display (*standard-output* :height 19) - (room))) - - -;;; This is used by the :edit-level modeline field which is defined in Main.Lisp. -;;; -(defvar *recursive-edit-count* 0) - -(defun do-recursive-edit () - "Does a recursive edit, wrapping []'s around the modeline of the current - window during its execution. The current window and buffer are saved - beforehand and restored afterward. If they have been deleted by the - time the edit is done then an editor-error is signalled." - (let* ((win (current-window)) - (buf (current-buffer))) - (unwind-protect - (let ((*recursive-edit-count* (1+ *recursive-edit-count*))) - (update-modeline-field *echo-area-buffer* *echo-area-window* - (modeline-field :edit-level)) - (recursive-edit)) - (update-modeline-field *echo-area-buffer* *echo-area-window* - (modeline-field :edit-level)) - (unless (and (memq win *window-list*) (memq buf *buffer-list*)) - (editor-error "Old window or buffer has been deleted.")) - (setf (current-window) win) - (unless (eq (window-buffer win) buf) - (setf (window-buffer win) buf)) - (setf (current-buffer) buf)))) - -(defcommand "Exit Recursive Edit" (p) - "Exit a level of recursive edit. Signals an error when not in a - recursive edit." - "Exit a level of recursive edit. Signals an error when not in a - recursive edit." - (declare (ignore p)) - (unless (in-recursive-edit) (editor-error "Not in a recursive edit!")) - (exit-recursive-edit ())) - -(defcommand "Abort Recursive Edit" (p) - "Abort the current recursive edit. Signals an error when not in a - recursive edit." - "Abort the current recursive edit. Signals an error when not in a - recursive edit." - (declare (ignore p)) - (unless (in-recursive-edit) (editor-error "Not in a recursive edit!")) - (abort-recursive-edit "Recursive edit aborted.")) - - -;;; TRANSPOSE REGIONS uses CURRENT-REGION to signal an error if the current -;;; region is not active and to get start2 and end2 in proper order. Delete1, -;;; delete2, and delete3 are necessary since we are possibly ROTATEF'ing the -;;; locals end1/start1, start1/start2, and end1/end2, and we need to know which -;;; marks to dispose of at the end of all this stuff. When we actually get to -;;; swapping the regions, we must delete both up front if they both are to be -;;; deleted since we don't know what kind of marks are in start1, start2, end1, -;;; and end2, and the marks will be moving around unpredictably as we insert -;;; text at them. We copy point into ipoint for insertion purposes since one -;;; of our four marks is the point. -;;; -(defcommand "Transpose Regions" (p) - "Transpose two regions with endpoints defined by the mark stack and point. - To use: mark start of region1, mark end of region1, mark start of region2, - and place point at end of region2. Invoking this immediately following - one use will put the regions back, but you will have to activate the - current region." - "Transpose two regions with endpoints defined by the mark stack and point." - (declare (ignore p)) - (unless (>= (ring-length (value buffer-mark-ring)) 3) - (editor-error "Need two marked regions to do Transpose Regions.")) - (let* ((region (current-region)) - (end2 (region-end region)) - (start2 (region-start region)) - (delete1 (pop-buffer-mark)) - (end1 (pop-buffer-mark)) - (delete2 end1) - (start1 (pop-buffer-mark)) - (delete3 start1)) - ;;get marks in the right order, to simplify the code that follows - (unless (mark<= start1 end1) (rotatef start1 end1)) - (unless (mark<= start1 start2) - (rotatef start1 start2) - (rotatef end1 end2)) - ;;order now guaranteed: <Buffer Start> start1 end1 start2 end2 <Buffer End> - (unless (mark<= end1 start2) - (editor-error "Can't transpose overlapping regions.")) - (let* ((adjacent-p (mark= end1 start2)) - (region1 (delete-and-save-region (region start1 end1))) - (region2 (unless adjacent-p - (delete-and-save-region (region start2 end2)))) - (point (current-point))) - (with-mark ((ipoint point :left-inserting)) - (let ((save-end2-loc (push-buffer-mark (copy-mark end2)))) - (ninsert-region (move-mark ipoint end2) region1) - (push-buffer-mark (copy-mark ipoint)) - (cond (adjacent-p - (push-buffer-mark (copy-mark start2)) - (move-mark point save-end2-loc)) - (t (push-buffer-mark (copy-mark end1)) - (ninsert-region (move-mark ipoint end1) region2) - (move-mark point ipoint)))))) - (delete-mark delete1) - (delete-mark delete2) - (delete-mark delete3))) - - -(defcommand "Goto Absolute Line" (p) - "Goes to the indicated line, if you counted them starting at the beginning - of the buffer with the number one. If a prefix argument is supplied, that - is the line numbe; otherwise, the user is prompted." - "Go to a user perceived line number." - (let ((p (or p (prompt-for-expression - :prompt "Line number: " - :help "Enter an absolute line number to goto.")))) - (unless (and (integerp p) (plusp p)) - (editor-error "Must supply a positive integer.")) - (let ((point (current-point))) - (with-mark ((m point)) - (unless (line-offset (buffer-start m) (1- p) 0) - (editor-error "Not enough lines in buffer.")) - (move-mark point m))))) - - - -;;;; Mouse Commands. - -(defcommand "Do Nothing" (p) - "Do nothing. - With prefix argument, do it that many times." - "Do nothing p times." - (dotimes (i (or p 1))) - (setf (last-command-type) (last-command-type))) - -(defun maybe-change-window (window) - (unless (eq window (current-window)) - (when (or (eq window *echo-area-window*) - (eq (current-window) *echo-area-window*) - (member window *random-typeout-buffers* - :key #'(lambda (cons) - (hi::random-typeout-stream-window (cdr cons))))) - (supply-generic-pointer-up-function #'lisp::do-nothing) - (editor-error "I'm afraid I can't let you do that Dave.")) - (setf (current-window) window) - (let ((buffer (window-buffer window))) - (unless (eq (current-buffer) buffer) - (setf (current-buffer) buffer))))) - -(defcommand "Top Line to Here" (p) - "Move the top line to the line the mouse is on. - If in the first two columns then scroll continuously until the button is - released." - "Move the top line to the line the mouse is on." - (declare (ignore p)) - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless y (editor-error)) - (cond ((< x 2) - (do ((ch (read-char-no-hang *editor-input*) - (read-char-no-hang *editor-input*))) - (ch) - (scroll-window window -1) - (redisplay) - (editor-finish-output window))) - (t - (scroll-window window (- y)))))) - -(defcommand "Here to Top of Window" (p) - "Move the line the mouse is on to the top of the window. - If in the first two columns then scroll continuously until the button is - released." - "Move the line the mouse is on to the top of the window." - (declare (ignore p)) - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless y (editor-error)) - (cond ((< x 2) - (do ((ch (read-char-no-hang *editor-input*) - (read-char-no-hang *editor-input*))) - (ch) - (scroll-window window 1) - (redisplay) - (editor-finish-output window))) - (t - (scroll-window window y))))) - - -(defvar *generic-pointer-up-fun* nil - "This is the function for the \"Generic Pointer Up\" command that defines - its action. Other commands set this in preparation for this command's - invocation.") -;;; -(defun supply-generic-pointer-up-function (fun) - "This provides the action \"Generic Pointer Up\" command performs." - (check-type fun function) - (setf *generic-pointer-up-fun* fun)) - -(defcommand "Generic Pointer Up" (p) - "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: - \"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. - \"Bufed Goto and Quit\" - The action is a no-op." - "Invoke whatever is on *generic-pointer-up-fun*." - (declare (ignore p)) - (unless *generic-pointer-up-fun* - (editor-error "No commands have supplied a \"Generic Pointer Up\" action.")) - (funcall *generic-pointer-up-fun*)) - - -(defcommand "Point to Here" (p) - "Move the point to the position of the mouse. - If in the modeline, move to the absolute position in the file indicated by - the position within the modeline, pushing the old position on the mark - stack. This supplies a function \"Generic Pointer Up\" invokes if it runs - without any intervening generic pointer up predecessors running. If the - position of the pointer is different than the current point when the user - invokes \"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." - "Move the point to the position of the mouse." - (declare (ignore p)) - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless x (editor-error)) - (maybe-change-window window) - (if y - (let ((m (cursorpos-to-mark x y window))) - (unless m (editor-error)) - (move-mark (current-point) m)) - (let* ((buffer (window-buffer window)) - (region (buffer-region buffer)) - (point (buffer-point buffer))) - (push-buffer-mark (copy-mark point)) - (move-mark point (region-start region)) - (line-offset point (round (* (1- (count-lines region)) x) - (1- (window-width window))))))) - (supply-generic-pointer-up-function #'point-to-here-up-action)) - -(defun point-to-here-up-action () - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless x (editor-error)) - (when y - (maybe-change-window window) - (let ((m (cursorpos-to-mark x y window))) - (unless m (editor-error)) - (when (eq (line-buffer (mark-line (current-point))) - (line-buffer (mark-line m))) - (unless (mark= m (current-point)) - (push-buffer-mark (copy-mark (current-point)) t))) - (move-mark (current-point) m))))) - - -(defcommand "Insert Kill Buffer" (p) - "Move current point to the mouse location and insert the kill buffer." - "Move current point to the mouse location and insert the kill buffer." - (declare (ignore p)) - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless x (editor-error)) - (maybe-change-window window) - (if y - (let ((m (cursorpos-to-mark x y window))) - (unless m (editor-error)) - (move-mark (current-point) m) - (un-kill-command nil)) - (editor-error "Can't insert kill buffer in modeline.")))) - - - -;;;; Page commands & stuff. - -(defvar *goto-page-last-num* 0) -(defvar *goto-page-last-string* "") - -(defcommand "Goto Page" (p) - "Go to an absolute page number (argument). If no argument, then go to - next page. A negative argument moves back that many pages if possible. - If argument is zero, prompt for string and goto page with substring - in title." - "Go to an absolute page number (argument). If no argument, then go to - next page. A negative argument moves back that many pages if possible. - If argument is zero, prompt for string and goto page with substring - in title." - (let ((point (current-point))) - (cond ((not p) - (page-offset point 1)) - ((zerop p) - (let* ((againp (eq (last-command-type) :goto-page-zero)) - (name (prompt-for-string :prompt "Substring of page title: " - :default (if againp - *goto-page-last-string* - *parse-default*))) - (dir (page-directory (current-buffer))) - (i 1)) - (declare (simple-string name)) - (cond ((not againp) - (push-buffer-mark (copy-mark point))) - ((string-equal name *goto-page-last-string*) - (setf dir (nthcdr *goto-page-last-num* dir)) - (setf i (1+ *goto-page-last-num*)))) - (loop - (when (null dir) - (editor-error "No page title contains ~S." name)) - (when (search name (the simple-string (car dir)) - :test #'char-equal) - (goto-page point i) - (setf (last-command-type) :goto-page-zero) - (setf *goto-page-last-num* i) - (setf *goto-page-last-string* name) - (return t)) - (incf i) - (setf dir (cdr dir))))) - ((minusp p) - (page-offset point p)) - (t (goto-page point p))) - (line-start (move-mark (window-display-start (current-window)) point)))) - -(defun goto-page (mark i) - (with-mark ((m mark)) - (buffer-start m) - (unless (page-offset m (1- i)) - (editor-error "No page numbered ~D." i)) - (move-mark mark m))) - - -(defcommand "View Page Directory" (p) - "Print a listing of the first non-blank line after each page mark - in a pop-up window." - "Print a listing of the first non-blank line after each page mark - in a pop-up window." - (declare (ignore p)) - (let ((dir (page-directory (current-buffer)))) - (declare (list dir)) - (with-pop-up-display (s :height (1+ (the fixnum (length dir)))) - (display-page-directory s dir)))) - -(defcommand "Insert Page Directory" (p) - "Insert a listing of the first non-blank line after each page mark at - the beginning of the buffer. A mark is dropped before going to the - beginning of the buffer. If an argument is supplied, insert the page - directory at point." - "Insert a listing of the first non-blank line after each page mark at - the beginning of the buffer." - (declare (ignore p)) - (let ((point (current-point))) - (unless p - (push-buffer-mark (copy-mark point)) - (buffer-start point)) - (push-buffer-mark (copy-mark point)) - (display-page-directory (make-hemlock-output-stream point :full) - (page-directory (current-buffer)))) - (setf (last-command-type) :ephemerally-active)) - -(defun display-page-directory (stream directory) - "This writes the list of strings, directory, to stream, enumerating them - in a field of three characters. The number and string are separated by - two spaces, and the first line contains headings for the numbers and - strings columns." - (write-line "Page First Non-blank Line" stream) - (do ((dir directory (cdr dir)) - (count 1 (1+ count))) - ((null dir)) - (declare (fixnum count)) - (format stream "~3D " count) - (write-line (car dir) stream))) - -(defun page-directory (buffer) - "Return a list of strings where each is the first non-blank line - following a :page-delimiter in buffer." - (with-mark ((m (buffer-point buffer))) - (buffer-start m) - (let ((end-of-buffer (buffer-end-mark buffer)) result) - (loop ;over pages. - (loop ;for first non-blank line. - (cond ((not (blank-after-p m)) - (let* ((str (line-string (mark-line m))) - (len (length str))) - (declare (simple-string str)) - (push (if (and (> len 1) - (= (character-attribute :page-delimiter - (schar str 0)) - 1)) - (subseq str 1) - str) - result)) - (unless (page-offset m 1) - (return-from page-directory (nreverse result))) - (when (mark= m end-of-buffer) - (return-from page-directory (nreverse result))) - (return)) - ((not (line-offset m 1 0)) - (return-from page-directory (nreverse result))) - ((= (character-attribute :page-delimiter (next-character m)) - 1) - (push "" result) - (mark-after m) - (return)))))))) - - -(defcommand "Previous Page" (p) - "Move to the beginning of the current page. - With prefix argument move that many pages." - "Move backward P pages." - (let ((point (current-point))) - (unless (page-offset point (- (or p 1))) - (editor-error "No such page.")) - (line-start (move-mark (window-display-start (current-window)) point)))) - -(defcommand "Next Page" (p) - "Move to the beginning of the next page. - With prefix argument move that many pages." - "Move forward P pages." - (let ((point (current-point))) - (unless (page-offset point (or p 1)) - (editor-error "No such page.")) - (line-start (move-mark (window-display-start (current-window)) point)))) - -(defcommand "Mark Page" (p) - "Put point at beginning, mark at end of current page. - With prefix argument, mark the page that many pages after the current one." - "Mark the P'th page after the current one." - (let ((point (current-point))) - (if p - (unless (page-offset point (1+ p)) (editor-error "No such page.")) - (page-offset point 1)) ;If this loses, we're at buffer-end. - (with-mark ((m point)) - (unless (page-offset point -1) - (editor-error "No such page.")) - (push-buffer-mark (copy-mark m) t) - (line-start (move-mark (window-display-start (current-window)) point))))) - -(defun page-offset (mark n) - "Move mark past n :page-delimiters that are in the zero'th line position. - If a :page-delimiter is the immediately next character after mark in the - appropriate direction, then skip it before starting." - (cond ((plusp n) - (find-attribute mark :page-delimiter #'zerop) - (dotimes (i n mark) - (unless (next-character mark) (return nil)) - (loop - (unless (find-attribute mark :page-delimiter) - (return-from page-offset nil)) - (unless (mark-after mark) - (return (if (= i (1- n)) mark))) - (when (= (mark-charpos mark) 1) (return))))) - (t - (reverse-find-attribute mark :page-delimiter #'zerop) - (prog1 - (dotimes (i (- n) mark) - (unless (previous-character mark) (return nil)) - (loop - (unless (reverse-find-attribute mark :page-delimiter) - (return-from page-offset nil)) - (mark-before mark) - (when (= (mark-charpos mark) 0) (return)))) - (let ((buffer (line-buffer (mark-line mark)))) - (unless (or (not buffer) (mark= mark (buffer-start-mark buffer))) - (mark-after mark))))))) - - - -;;;; Counting some stuff - -(defcommand "Count Lines Page" (p) - "Display number of lines in current page and position within page. - With prefix argument do on entire buffer." - "Count some lines, Man." - (let ((point (current-point))) - (if p - (let ((r (buffer-region (current-buffer)))) - (count-lines-function "Buffer" (region-start r) point (region-end r))) - (with-mark ((m1 point) - (m2 point)) - (unless (and (= (character-attribute :page-delimiter - (previous-character m1)) - 1) - (= (mark-charpos m1) 1)) - (page-offset m1 -1)) - (unless (and (= (character-attribute :page-delimiter - (next-character m2)) - 1) - (= (mark-charpos m2) 0)) - (page-offset m2 1)) - (count-lines-function "Page" m1 point m2))))) - -(defun count-lines-function (msg start mark end) - (let ((before (1- (count-lines (region start mark)))) - (after (count-lines (region mark end)))) - (message "~A: ~D lines, ~D/~D" msg (+ before after) before after))) - -(defcommand "Count Lines" (p) - "Display number of lines in the region." - "Display number of lines in the region." - (declare (ignore p)) - (multiple-value-bind (region activep) (get-count-region) - (message "~:[After point~;Active region~]: ~A lines" - activep (count-lines region)))) - -(defcommand "Count Words" (p) - "Prints in the Echo Area the number of words in the region - between the point and the mark by using word-offset. The - argument is ignored." - "Prints Number of Words in the Region" - (declare (ignore p)) - (multiple-value-bind (region activep) (get-count-region) - (let ((end-mark (region-end region))) - (with-mark ((beg-mark (region-start region))) - (let ((word-count 0)) - (loop - (when (mark>= beg-mark end-mark) - (return)) - (unless (word-offset beg-mark 1) - (return)) - (incf word-count)) - (message "~:[After point~;Active region~]: ~D Word~:P" - activep word-count)))))) - -;;; GET-COUNT-REGION -- Internal Interface. -;;; -;;; Returns the active region or the region between point and end-of-buffer. -;;; As a second value, it returns whether the region was active. -;;; -;;; Some searching commands use this routine. -;;; -(defun get-count-region () - (if (region-active-p) - (values (current-region) t) - (values (region (current-point) (buffer-end-mark (current-buffer))) - nil))) - - - -;;;; Some modes: - -(defcommand "Fundamental Mode" (p) - "Put the current buffer into \"Fundamental\" mode." - "Put the current buffer into \"Fundamental\" mode." - (declare (ignore p)) - (setf (buffer-major-mode (current-buffer)) "Fundamental")) - -(defmode "Text" :major-p t) -(defcommand "Text Mode" (p) - "Put the current buffer into \"Text\" mode." - "Put the current buffer into \"Text\" mode." - (declare (ignore p)) - (setf (buffer-major-mode (current-buffer)) "Text")) diff --git a/hemlock/notes.txt b/hemlock/notes.txt deleted file mode 100644 index 3da86bbe711a350233e7484ee5daf7d09579d574..0000000000000000000000000000000000000000 --- a/hemlock/notes.txt +++ /dev/null @@ -1,27 +0,0 @@ -(defcommand "Find File From Sources" (p) - "" "" - (declare (ignore p)) - (let ((point (current-point))) - (with-mark ((start point) - (end point)) - (find-file-command - nil - (merge-pathnames "src:" - (region-to-string (region (line-start start) - (line-end end)))))))) - -* abbrev.lisp -* doccoms.lisp -* echo.lisp -* echocoms.lisp -* filecoms.lisp -* lisp-lib.lisp ;Blew away help command, should do describe mode. -* lispbuf.lisp -* lispeval.lisp ;Maybe write MESSAGE-EVAL_FORM-RESULTS. -* macros.lisp <<< Already changed in WORK: -* mh.lisp <<< Ask Bill about INC in "Incorporate New Mail". -* morecoms.lisp -* register.lisp -* scribe.lisp -* searchcoms.lisp -* spellcoms.lisp diff --git a/hemlock/overwrite.lisp b/hemlock/overwrite.lisp deleted file mode 100644 index 7d8d139fce05cfb9e4aec146f0dd3c8ca9ff739c..0000000000000000000000000000000000000000 --- a/hemlock/overwrite.lisp +++ /dev/null @@ -1,64 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles. -;;; - -(in-package 'hemlock) - - -(defmode "Overwrite") - - -(defcommand "Overwrite Mode" (p) - "Printing characters overwrite characters instead of pushing them to the right. - A positive argument turns Overwrite mode on, while zero or a negative - argument turns it off. With no arguments, it is toggled. Use C-Q to - insert characters normally." - "Determine if in Overwrite mode or not and set the mode accordingly." - (setf (buffer-minor-mode (current-buffer) "Overwrite") - (if p - (plusp p) - (not (buffer-minor-mode (current-buffer) "Overwrite"))))) - - -(defcommand "Self Overwrite" (p) - "Replace the next character with the last character typed, - but insert at end of line. With prefix argument, do it that many times." - "Implements ``Self Overwrite'', calling this function is not meaningful." - (let ((char (text-character *last-character-typed*)) - (point (current-point))) - (unless char (editor-error "Can't insert that character.")) - (do ((n (or p 1) (1- n))) - ((zerop n)) - (case (next-character point) - (#\tab - (let ((col1 (mark-column point)) - (col2 (mark-column (mark-after point)))) - (if (= (- col2 col1) 1) - (setf (previous-character point) char) - (insert-character (mark-before point) char)))) - ((#\newline nil) (insert-character point char)) - (t (setf (next-character point) char) - (mark-after point)))))) - - -(defcommand "Overwrite Delete Previous Character" (p) - "Replaces previous character with space, but tabs and newlines are deleted. - With prefix argument, do it that many times." - "Replaces previous character with space, but tabs and newlines are deleted." - (do ((point (current-point)) - (n (or p 1) (1- n))) - ((zerop n)) - (case (previous-character point) - ((#\newline #\tab) (delete-characters point -1)) - ((nil) (editor-error)) - (t (setf (previous-character point) #\space) - (mark-before point))))) diff --git a/hemlock/pascal.lisp b/hemlock/pascal.lisp deleted file mode 100644 index 2e5288b138b141f8e7c147e6e3571ee7e36ecaba..0000000000000000000000000000000000000000 --- a/hemlock/pascal.lisp +++ /dev/null @@ -1,45 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Just barely enough to be a Pascal/C mode. Maybe more some day. -;;; -(in-package 'hemlock) - -(defmode "Pascal" :major-p t) -(defcommand "Pascal Mode" (p) - "Put the current buffer into \"Pascal\" mode." - "Put the current buffer into \"Pascal\" mode." - (declare (ignore p)) - (setf (buffer-major-mode (current-buffer)) "Pascal")) - -(defhvar "Indent Function" - "Indentation function which is invoked by \"Indent\" command. - It must take one argument that is the prefix argument." - :value #'generic-indent - :mode "Pascal") - -(defhvar "Auto Fill Space Indent" - "When non-nil, uses \"Indent New Comment Line\" to break lines instead of - \"New Line\"." - :mode "Pascal" :value t) - -(defhvar "Comment Start" - "String that indicates the start of a comment." - :mode "Pascal" :value "(*") - -(defhvar "Comment End" - "String that ends comments. Nil indicates #\newline termination." - :mode "Pascal" :value " *)") - -(defhvar "Comment Begin" - "String that is inserted to begin a comment." - :mode "Pascal" :value "(* ") - -(shadow-attribute :scribe-syntax #\< nil "Pascal") diff --git a/hemlock/perq-hemlock.log b/hemlock/perq-hemlock.log deleted file mode 100644 index 6629d63f5b6a744b6e209b71f1679753f452da81..0000000000000000000000000000000000000000 --- a/hemlock/perq-hemlock.log +++ /dev/null @@ -1,146 +0,0 @@ -/Lisp2/Slisp/Hemlock/perqsite.slisp#1, 23-Mar-85 11:05:16, Edit by Ram - Made wait-for-more use logical-char=. - -/lisp2/slisp/hemlock/echocoms.slisp#1, 22-Mar-85 13:41:10, Edit by Ram - Made "Complete Keyword" and "Help on Parse" pass the parse default into - Complete-File and Ambiguous-Files, respectively. - -/Lisp2/Slisp/Hemlock/echocoms.slisp#1, 22-Mar-85 10:51:09, Edit by Ram - Updated to correspond to new prompting conventions. - -/Lisp2/Slisp/Hemlock/echo.slisp#1, 22-Mar-85 10:21:19, Edit by Ram - Changes to make defaulting work better. *parse-default* is now a string - which we pretend we read when we confirm an empty parse. - *parse-default-string* is now only used in displaying the default, as it - should be. The prompt and help can now be a list of format string and format - arguments. The feature of help being a function is gone. - -/Lisp2/Slisp/Hemlock/echo.slisp#1, 22-Mar-85 08:00:01, Edit by Ram - Made Parse-For-Something specify NIL to Recursive-Edit so that C-G's will - blow away prompts. - -/Lisp2/Slisp/Hemlock/buffer.slisp#1, 22-Mar-85 07:57:49, Edit by Ram - Added the optional Handle-Abort argument to recursive-edit so that we can - have recursive-edits that aren't blown away by C-G's. - -/Lisp2/Slisp/Hemlock/spellcoms.slisp#1, 22-Mar-85 07:35:01, Edit by Ram - Made Sub-Correct-Last-Misspelled-Word delete the marks pointing to misspelled - words when it pops them off the ring. - -/lisp2/slisp/hemlock/syntax.slisp#1, 18-Mar-85 07:20:53, Edit by Ram - Fixed problem with the old value not being saved if a shadow-attribute was - dowe for a mode that is currently active. - -/lisp2/slisp/hemlock/defsyn.slisp#1, 14-Mar-85 09:42:53, Edit by Ram - Made #\. be a word delimiter by default. For old time's sake, it is not - a delimiter in "Fundamental" mode. - -/Lisp2/Slisp/Hemlock/filecoms.slisp#1, 13-Mar-85 00:25:19, Edit by Ram - Changed write-da-file not to compare write dates if the file desn't exist. - -/Lisp2/Slisp/Hemlock/perqsite.slisp#1, 13-Mar-85 00:15:31, Edit by Ram - Changed emergency message stuff to divide the message size by 8. - -/Lisp2/Slisp/Hemlock/htext2.slisp#1, 13-Mar-85 00:07:13, Edit by Ram - Changed %set-next-character to use the body of Modifying-Buffer. Made - string-to-region give the region a disembodied buffer count. - -/Lisp2/Slisp/Hemlock/htext3.slisp#1, 12-Mar-85 23:53:57, Edit by Ram - Changed everyone to use the body of modifying-buffer. - -/Lisp2/Slisp/Hemlock/htext1.slisp#1, 12-Mar-85 23:45:51, Edit by Ram - Made Modifying-Buffer have a body and wrap a without-interrupts around the - body. Changed %set-line-string to run within the body of modifying-buffer. - -/Lisp2/Slisp/Hemlock/echocoms.slisp#1, 12-Mar-85 23:28:40, Edit by Ram - Made "Confirm Parse" push the input before calling the confirm function so - that if it gets an error, you don't have to type it again. Also changed it - to directly return the default if there is empty input, rather than calling - the confirm function on the default string. It used to be this way, and I - changed it, but don't remember why. - -/Lisp2/Slisp/Hemlock/group.slisp#1, 12-Mar-85 23:10:43, Edit by Ram - Made group-read-file go to the beginning of the buffer, which is useful in - the case where the file was already read. - -/Lisp2/Slisp/Hemlock/lispbuf.slisp#1, 12-Mar-85 22:58:03, Edit by Ram - Made "Compile File" use buffer-default-pathname to get defaults for the - prompt. Added "Compile Group" command. - -/lisp2/slisp/hemlock/kbdmac.slisp#1, 09-Mar-85 20:53:33, Edit by Ram - Made default-kbdmac-transform bind *invoke-hook* so that recursive edits - don't try do clever stuff. - -/lisp2/slisp/hemlock/perqsite.slisp#1, 09-Mar-85 14:16:41, Edit by Ram - Changed editor-input stream to use new stream representation. Moved - Input-Waiting here from Streams, changed definition to return T or NIL - instead of number of chars. Made Wait-For-More not unread the character if - it is rubout. Made level-1-abort handler clear input. - -/lisp2/slisp/hemlock/streams.slisp#1, 09-Mar-85 14:59:02, Edit by Ram - Changed to use new stream representation. - -/lisp2/slisp/hemlock/pane-stream.slisp#1, 09-Mar-85 14:51:25, Edit by Ram - Changed to use new stream representation. - -/lisp2/slisp/hemlock/lispmode.slisp#1, 05-Mar-85 11:59:15, Edit by Ram - Changed the "Defindent" command to go to the beginning of the line before - doing the backward-up-list. This means that we always find the form - controlling indentation for the current line, rather than the enclosing form. - Do a "Indent For Lisp" after we redefine the indentation, since it presumably - changed. - -/lisp2/slisp/hemlock/spell-corr.slisp#1, 05-Mar-85 11:39:19, Edit by Ram - Fixed everyone to use gr-call. Made Correct-Spelling call - maybe-read-spell-dictionary, rather than trying to look at - *spell-opeining-return*. - -/lisp2/slisp/hemlock/spell-augment.slisp#1, 05-Mar-85 11:53:04, Edit by Ram - Fixed everyone to use gr-call and friends. - -/Lisp2/Slisp/Hemlock/command.slisp#1, 21-Feb-85 00:56:52, Edit by Ram - Edited back in change to "Scroll Next Window ..." commands to make them - complain if there is only one window. - -/Lisp2/Slisp/Hemlock/filecoms.slisp#1, 21-Feb-85 00:48:00, Edit by Ram - Edited back in changes: - Make "Backup File" message the file written. - Make Previous-Buffer return any buffer other than the current buffer - and the echo area buffer it there is nothing good in the history. - -/Lisp2/Slisp/Hemlock/bindings.slisp#1, 21-Feb-85 00:30:48, Edit by Ram - Removed spurious binding of #\' to "Check Word Spelling". - -/Lisp2/Boot/Hemlock/spellcoms.slisp#1, 05-Feb-85 13:58:54, Edit by Ram - Added call to Region-To-String in "Add Word to Spelling Dictionary" so that - it worked. - -/Lisp2/Boot/Hemlock/fill.slisp#1, 31-Jan-85 12:09:01, Edit by Ram - Made "Set Fill Prefix" and "Set Fill Column" define a buffer local variable - so that the values are buffer local. - -/Lisp2/Boot/Hemlock/fill.slisp#1, 26-Jan-85 17:19:57, Edit by Ram - Made / be a paragraph delimiter. - -/Lisp2/Boot/Hemlock/search2.slisp#1, 26-Jan-85 17:07:37, Edit by Ram - Fixed the reclaim-function for set search patterns to reclaim the set instead - of the search-pattern structure. - -/Lisp2/Boot/Hemlock/group.slisp#1, 25-Jan-85 22:07:15, Edit by Ram - Changed the way Group-Read-File works. We always use "Find File" to read in - the file, but if "Group Find File" is false, and we created a new buffer, we - rename the buffer to "Group Search", nuking any old buffer of that name. If - we are in the "Group Search" buffer when we finish, we nuke it and go to the - previous buffer. - -/Lisp2/Boot/Hemlock/macros.slisp#1, 25-Jan-85 22:35:26, Edit by Ram - Fixed Hlet so that it worked. Evidently nobody had used it before. - -/Lisp2/Boot/Hemlock/filecoms.slisp#1, 25-Jan-85 23:26:35, Edit by Ram - Made "Log Change" merge the buffer pathname defaults into the log file name. - Added the feature that the location for the point in the change log entry - template can be specified by placing a "@" in the template. - -/Lisp2/Boot/Hemlock/search2.slisp#1, 25-Jan-85 23:23:35, Edit by Ram - Fixed various one-off errors in the end args being passed to position and - %sp-find-character-with-attribute. diff --git a/hemlock/pop-up-stream.lisp b/hemlock/pop-up-stream.lisp deleted file mode 100644 index 48b548f242e87344886abe6742f821681d8386ad..0000000000000000000000000000000000000000 --- a/hemlock/pop-up-stream.lisp +++ /dev/null @@ -1,225 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contatins the stream operations for pop-up-displays. -;;; -;;; Written by Blaine Burks. -;;; - -(in-package "HEMLOCK-INTERNALS") - - - -;;;; Line-buffered Stream Methods. - -(defun random-typeout-line-out (stream char) - (insert-character (random-typeout-stream-mark stream) char) - (when (and (char= char #\newline) - (not (random-typeout-stream-no-prompt stream))) - (funcall (device-random-typeout-line-more - (device-hunk-device - (window-hunk (random-typeout-stream-window stream)))) - stream 1))) - -(defun random-typeout-line-sout (stream string start end) - (declare (ignore start end)) - (insert-string (random-typeout-stream-mark stream) string start end) - (unless (random-typeout-stream-no-prompt stream) - (let ((count (count #\newline string))) - (when count - (funcall (device-random-typeout-line-more - (device-hunk-device - (window-hunk (random-typeout-stream-window stream)))) - stream count))))) - -(defun random-typeout-line-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - ((:force-output :finish-output) - (random-typeout-redisplay (random-typeout-stream-window stream))) - (:charpos - (mark-charpos (random-typeout-stream-mark stream))))) - - -;;; Bitmap line-buffered support. - -;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to -;;; a line-buffered-random-typeout-stream on the bitmap. It does a lot of -;;; checking to make sure that strings of characters longer than the width of -;;; the window don't screw us. The code is a little wierd, so a brief -;;; explanation is below. -;;; -;;; The more-mark is how we tell when we will next need to more. Each time -;;; we do a more-prompt, we point the mark at the last visible character in -;;; the random typeout window. That way, when the mark is no longer -;;; DISPLAYED-P, we know it's time to do another more prompt. -;;; -;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying -;;; if there was at least one newline in the last batch of output. If we -;;; haven't done a more prompt yet (indicated by a value of T for -;;; first-more-p), then since we know the end of the buffer isn't visible, we -;;; need to do a more-prompt. If neither of the first two tests returns T, -;;; then we can only need to do a more-prompt if our more-mark has scrolled -;;; off the top of the screen. If it hasn't, everything is peechy-keen, so -;;; we scroll the screen one line and redisplay. -;;; -(defun update-bitmap-line-buffered-stream (stream newline-count) - (let* ((window (random-typeout-stream-window stream)) - (count 0)) - (when (plusp newline-count) (random-typeout-redisplay window)) - (loop - (cond ((no-text-past-bottom-p window) - (return)) - ((or (random-typeout-stream-first-more-p stream) - (not (displayed-p (random-typeout-stream-more-mark stream) - window))) - (do-bitmap-more-prompt stream) - (return)) - (t - (scroll-window window 1) - (random-typeout-redisplay window))) - (when (= (incf count) newline-count) (return))))) - -;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed -;;; in the random-typeout window. It does this by first making sure there is a -;;; line past the WINDOW-DISPLAY-END of the window. If there is, this line -;;; must be empty, and BUFFER-END-MARK must be on this line. The final test is -;;; that the window-end is displayed within the window. If it is not, then the -;;; last line wraps past the end of the window, and there is text past the -;;; bottom. -;;; -;;; Win-end is bound after the call to DISPLAYED-P because it updates the -;;; window's image moving WINDOW-DISPLAY-END. We want this updated value for -;;; the display end. -;;; -(defun no-text-past-bottom-p (window) - (let* ((window-end (window-display-end window)) - (window-end-displayed-p (displayed-p window-end window))) - (with-mark ((win-end window-end)) - (let ((one-after-end (line-offset win-end 1))) - (if one-after-end - (and (empty-line-p win-end) - (same-line-p win-end (buffer-end-mark (window-buffer window))) - window-end-displayed-p) - window-end-displayed-p))))) - -(defun reset-more-mark (stream) - (let* ((window (random-typeout-stream-window stream)) - (more-mark (random-typeout-stream-more-mark stream)) - (end (window-display-end window))) - (move-mark more-mark end) - (unless (displayed-p end window) (character-offset more-mark -1)))) - -;;; DO-BITMAP-MORE-PROMPT is the function that atually displays the more prompt -;;; and reacts to it. Things are pretty clear. The loop is neccessary because -;;; someone could screw us by never outputting newlines. Improbable, but -;;; possible. -;;; -(defun do-bitmap-more-prompt (stream) - (let* ((window (random-typeout-stream-window stream)) - (height (window-height window))) - (setf (random-typeout-stream-first-more-p stream) nil) - (reset-more-mark stream) - (loop - (when (no-text-past-bottom-p window) (return)) - (display-more-prompt stream) - (do ((i 0 (1+ i))) - ((or (= i height) (no-text-past-bottom-p window))) - (scroll-window window 1) - (random-typeout-redisplay window))) - (unless (displayed-p (random-typeout-stream-more-mark stream) window) - (reset-more-mark stream)))) - - -;;; Tty line-buffered support. - -;;; UPDATE-TTY-LINE-BUFFERED-STREAM is called when anything is written to -;;; a line-buffered-random-typeout-stream on the tty. It just makes sure -;;; hemlock doesn't choke on extra-long strings. -;;; -(defun update-tty-line-buffered-stream (stream newline-count) - (let ((window (random-typeout-stream-window stream))) - (when (plusp newline-count) (random-typeout-redisplay window)) - (loop - (when (no-text-past-bottom-p window) (return)) - (display-more-prompt stream) - (scroll-window window (window-height window)) - (random-typeout-redisplay window)))) - - -;;;; Full-buffered Stream Methods. - -(defun random-typeout-full-out (stream char) - (insert-character (random-typeout-stream-mark stream) char)) - -(defun random-typeout-full-sout (stream string start end) - (declare (ignore start end)) - (insert-string (random-typeout-stream-mark stream) string start end)) - -(defun random-typeout-full-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - (:charpos - (mark-charpos (random-typeout-stream-mark stream))))) - - -;;; Bitmap full-buffered support. - -;;; DO-BITMAP-FULL-MORE and DO-TTY-FULL-MORE scroll through the fresh text in -;;; random typeout buffer. The bitmap function does some checking so that -;;; we don't overshoot the end of the buffer. -;;; -(defun do-bitmap-full-more (stream) - (let* ((window (random-typeout-stream-window stream)) - (buffer (window-buffer window)) - (height (window-height window))) - (with-mark ((end-check (buffer-end-mark buffer))) - (when (and (mark/= (buffer-start-mark buffer) end-check) - (empty-line-p end-check)) - (line-end (line-offset end-check -1))) - (loop - (when (displayed-p end-check window) - (return)) - (display-more-prompt stream) - (do ((i 0 (1+ i))) - ((or (= i height) (displayed-p end-check window))) - (scroll-window window 1) - (random-typeout-redisplay window)))))) - - -;;; Tty full-buffered support. - -(defun do-tty-full-more (stream) - (let* ((window (random-typeout-stream-window stream)) - (buffer (window-buffer window))) - (with-mark ((end-check (buffer-end-mark buffer))) - (when (and (mark/= (buffer-start-mark buffer) end-check) - (empty-line-p end-check)) - (line-end (line-offset end-check -1))) - (loop - (when (displayed-p end-check window) - (return)) - (display-more-prompt stream) - (scroll-window window (window-height window)))))) - - -;;; Proclaim this special so the compiler doesn't warn me. I hate that. -;;; -(proclaim '(special *more-prompt-action*)) - -(defun display-more-prompt (stream) - (unless (random-typeout-stream-no-prompt stream) - (let ((window (random-typeout-stream-window stream)) - (*more-prompt-action* :more)) - (update-modeline-field (window-buffer window) window :more-prompt) - (random-typeout-redisplay window) - (wait-for-more stream) - (let ((*more-prompt-action* :empty)) - (update-modeline-field (window-buffer window) window :more-prompt))))) diff --git a/hemlock/rcs.lisp b/hemlock/rcs.lisp deleted file mode 100644 index ce6f22138ae01555d80a21b2de62e7d4a459c718..0000000000000000000000000000000000000000 --- a/hemlock/rcs.lisp +++ /dev/null @@ -1,482 +0,0 @@ -;;; -*- Package: HEMLOCK; Mode: Lisp -*- -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.15 1990/03/16 19:39:05 ch Exp $ -;;; -;;; Various commands for dealing with RCS under Hemlock. -;;; -(in-package "HEMLOCK") - - -;;;; - -(defun current-buffer-pathname () - (let ((pathname (buffer-pathname (current-buffer)))) - (unless pathname - (editor-error "The buffer has no pathname.")) - pathname)) - - -(defmacro in-directory (directory &body forms) - (let ((cwd (gensym))) - `(let ((,cwd (ext:default-directory))) - (unwind-protect - (progn - (setf (ext:default-directory) (directory-namestring ,directory)) - ,@forms) - (setf (ext:default-directory) ,cwd))))) - - -(defvar *error-stream* (make-string-output-stream)) - -(defmacro do-command (&rest args) - (let ((proc (gensym))) - `(progn - (get-output-stream-string *error-stream*) - (let ((,proc (ext:run-program ,@args :error *error-stream*))) - (case (ext:process-status ,proc) - (:exited - (unless (zerop (ext:process-exit-code ,proc)) - (editor-error "~A" (get-output-stream-string *error-stream*)))) - (:signaled - (editor-error "~A killed with signal ~A ~@[core dumped]" - ',(car args) - (ext:process-exit-code ,proc) - (ext:process-core-dumped ,proc))) - (t - (editor-error "~S still alive?" ,proc))))))) - -(defun buffer-different-from-file (buffer filename) - (with-open-file (file filename) - (do ((buffer-line (mark-line (buffer-start-mark buffer)) - (line-next buffer-line)) - (file-line (read-line file nil nil) - (read-line file nil nil))) - ((and (or (null buffer-line) - (zerop (line-length buffer-line))) - (null file-line)) - nil) - (when (or (null buffer-line) - (null file-line) - (string/= (line-string buffer-line) file-line)) - (return t))))) - -(defun turn-auto-save-off (buffer) - (setf (buffer-minor-mode buffer "Save") nil) - ;; - ;; William's personal hack - (when (getstring "Ckp" *mode-names*) - (setf (buffer-minor-mode buffer "Ckp") nil))) - - -(defhvar "RCS Lock File Hook" - "RCS Lock File Hook" - :value nil) - -(defun rcs-lock-file (buffer pathname) - (message "Locking ~A ..." (namestring pathname)) - (in-directory pathname - (let ((file (file-namestring pathname))) - (do-command "rcs" `("-l" ,file)) - (multiple-value-bind (won dev ino mode) (mach:unix-stat file) - (declare (ignore ino)) - (cond (won - (mach:unix-chmod file (logior mode mach:writeown))) - (t - (editor-error "MACH:UNIX-STAT lost in RCS-LOCK-FILE: ~A" - (mach:get-unix-error-msg dev))))))) - (invoke-hook rcs-lock-file-hook buffer pathname)) - - -(defhvar "RCS Unlock File Hook" - "RCS Unlock File Hook" - :value nil) - -(defun rcs-unlock-file (buffer pathname) - (message "Unlocking ~A ..." (namestring pathname)) - (in-directory pathname - (do-command "rcs" `("-u" ,(file-namestring pathname)))) - (invoke-hook rcs-unlock-file-hook buffer pathname)) - - -;;;; Check In - -(defhvar "RCS Check In File Hook" - "RCS Check In File Hook" - :value nil) - -(defun rcs-check-in-file (buffer pathname keep-lock) - (let ((old-buffer (current-buffer)) - (allow-delete nil) - (log-buffer nil)) - (unwind-protect - (when (block in-recursive-edit - (do ((i 0 (1+ i))) - ((not (null log-buffer))) - (setf log-buffer - (make-buffer - (format nil "RCS Log Entry ~D for ~S" i - (file-namestring pathname)) - :modes '("Text") - :delete-hook - (list #'(lambda (buffer) - (declare (ignore buffer)) - (unless allow-delete - (return-from in-recursive-edit t))))))) - (turn-auto-save-off log-buffer) - (change-to-buffer log-buffer) - (do-recursive-edit) - - (message "Checking in ~A~:[~; keeping the lock~] ..." - (namestring pathname) keep-lock) - (let ((log-stream (make-hemlock-region-stream - (buffer-region log-buffer)))) - (sub-check-in-file pathname keep-lock log-stream)) - (invoke-hook rcs-check-in-file-hook buffer pathname) - nil) - (editor-error "Someone deleted the RCS Log Entry buffer.")) - (change-to-buffer old-buffer) - (setf allow-delete t) - (delete-buffer-if-possible log-buffer)))) - -(defun sub-check-in-file (pathname keep-lock log-stream) - (let* ((filename (file-namestring pathname)) - (rcs-filename (concatenate 'simple-string - "./RCS/" filename ",v"))) - (in-directory pathname - (do-command "rcsci" `(,@(if keep-lock '("-l")) - "-u" - ,filename) - :input log-stream) - ;; - ;; Set the times on the user's file to be equivalent to that of - ;; the rcs file. - (multiple-value-bind - (dev ino mode nlink uid gid rdev size atime mtime) - (mach:unix-stat rcs-filename) - (declare (ignore mode nlink uid gid rdev size)) - (cond (dev - (multiple-value-bind - (wonp errno) - (mach:unix-utimes filename (list atime 0 mtime 0)) - (unless wonp - (editor-error "MACH:UNIX-UTIMES failed: ~A" - (mach:get-unix-error-msg errno))))) - (t - (editor-error "MACH:UNIX-STAT failed: ~A" - (mach:get-unix-error-msg ino)))))))) - - -;;;; Check Out - -(defhvar "RCS Check Out File Hook" - "RCS Check Out File Hook" - :value nil) - -(defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p) - (sub-maybe-rcs-check-out-files buffer (list pathname) - lock always-overwrite-p)) - -(defun maybe-rcs-check-out-files (pathnames lock always-overwrite-p) - (sub-maybe-rcs-check-out-files nil pathnames lock always-overwrite-p)) - -(defun sub-maybe-rcs-check-out-files (buffer pathnames lock always-overwrite-p) - (let ((check-out-count 0)) - (macrolet ((frob () - `(progn - (rcs-check-out-file buffer pathname lock) - (incf check-out-count)))) - (dolist (pathname pathnames) - (cond - ((and (not always-overwrite-p) - (probe-file pathname) (ext:file-writable pathname)) - ;; File exists and is writable so check and see if the user really - ;; wants to check it out. - (command-case (:prompt - (format nil "The file ~A is writable. Overwrite? " - (file-namestring pathname)) - :help - "Type one of the following single-character commands:") - ((:yes :confirm) - "Overwrite the file." - (frob)) - (:no - "Skip checking out this file.") - ((#\r #\R) - "Rename the file before checking it out." - (let ((new-pathname (prompt-for-file - :prompt "New Filename: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil))) - (rename-file pathname new-pathname) - (frob))) - (:do-all - "Overwrite this file and all remaining files." - (setf always-overwrite-p t) - (frob)) - (:do-once - "Overwrite this file and then exit." - (frob) - (return)))) - (t - (frob))))) - check-out-count)) - -(defun rcs-check-out-file (buffer pathname lock) - (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock) - (in-directory pathname - (let ((backup - (if (probe-file pathname) - (lisp::pick-backup-name (namestring pathname)) - nil))) - (when backup (rename-file pathname backup)) - (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname))) - (invoke-hook rcs-check-out-file-hook buffer pathname) - (when backup (delete-file backup))))) - -(defun pick-temp-file (defaults) - (let ((index 0)) - (loop - (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults))) - (cond ((probe-file name) - (incf index)) - (t - (return name))))))) - - -;;;; Checking In / Checking Out and Locking / Unlocking - -(defcommand "RCS Lock Buffer File" (p) - "Attempt to lock the file in the current buffer." - "Attempt to lock the file in the current buffer." - (declare (ignore p)) - (let ((file (current-buffer-pathname)) - (buffer (current-buffer)) - (name (pick-temp-file "/tmp/"))) - (rcs-lock-file buffer file) - (unwind-protect - (progn - (in-directory file - (do-command "rcsco" `("-p" ,(file-namestring file)) - :output (namestring name))) - (when (buffer-different-from-file buffer name) - (message - "RCS file is different: be sure to merge in your changes.")) - (setf (buffer-writable buffer) t) - (message "Buffer is now writable.")) - (when (probe-file name) - (delete-file name))))) - -(defcommand "RCS Lock File" (p) - "Prompt for a file, and attempt to lock it." - "Prompt for a file, and attempt to lock it." - (declare (ignore p)) - (rcs-lock-file nil (prompt-for-file :prompt "File to lock: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil))) - -(defcommand "RCS Unlock Buffer File" (p) - "Unlock the file in the current buffer." - "Unlock the file in the current buffer." - (declare (ignore p)) - (rcs-unlock-file (current-buffer) (current-buffer-pathname)) - (setf (buffer-writable (current-buffer)) nil) - (message "Buffer is no longer writable.")) - -(defcommand "RCS Unlock File" (p) - "Prompt for a file, and attempt to unlock it." - "Prompt for a file, and attempt to unlock it." - (declare (ignore p)) - (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil))) - -(defcommand "RCS Check In Buffer File" (p) - "Checkin the file in the current buffer. With an argument, do not - release the lock." - "Checkin the file in the current buffer. With an argument, do not - release the lock." - (let ((buffer (current-buffer)) - (pathname (current-buffer-pathname))) - (when (buffer-modified buffer) - (save-file-command nil)) - (rcs-check-in-file buffer pathname p) - (visit-file-command nil pathname buffer))) - -(defcommand "RCS Check In File" (p) - "Prompt for a file, and attempt to check it in. With an argument, do - not release the lock." - "Prompt for a file, and attempt to check it in. With an argument, do - not release the lock." - (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: " - :default - (buffer-default-pathname - (current-buffer)) - :must-exist nil) - p)) - -(defcommand "RCS Check Out Buffer File" (p) - "Checkout the file in the current buffer. With an argument, lock the - file." - "Checkout the file in the current buffer. With an argument, lock the - file." - (let* ((buffer (current-buffer)) - (pathname (current-buffer-pathname)) - (point (current-point)) - (lines (1- (count-lines (region (buffer-start-mark buffer) point))))) - (when (buffer-modified buffer) - (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? ")) - (editor-error "Aborted."))) - (maybe-rcs-check-out-file buffer pathname p nil) - (setf (buffer-modified buffer) nil) - (when p - (setf (buffer-writable buffer) t) - (message "Buffer is now writable.")) - (visit-file-command nil pathname) - (unless (line-offset point lines) - (buffer-end point)))) - -(defcommand "RCS Check Out File" (p) - "Prompt for a file and attempt to check it out. With an argument, - lock the file." - "Prompt for a file and attempt to check it out. With an argument, - lock the file." - (let ((pathname (prompt-for-file :prompt "File to check out: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil))) - (maybe-rcs-check-out-file nil pathname p nil) - (find-file-command nil pathname))) - - -;;;; Log File - -(defhvar "RCS Log Entry Buffer" - "Name of the buffer to put RCS log entries into." - :value "RCS Log") - -(defhvar "RCS Log Buffer Hook" - "RCS Log Buffer Hook" - :value nil) - -(defun get-log-buffer () - (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*))) - (unless buffer - (setf buffer (make-buffer (value rcs-log-entry-buffer))) - (turn-auto-save-off buffer) - (invoke-hook rcs-log-buffer-hook buffer)) - buffer)) - -(defcommand "RCS Buffer File Log Entry" (p) - "Get the RCS Log for the file in the current buffer in a buffer." - "Get the RCS Log for the file in the current buffer in a buffer." - (declare (ignore p)) - (let ((buffer (get-log-buffer)) - (pathname (current-buffer-pathname))) - (delete-region (buffer-region buffer)) - (message "Extracting log info ...") - (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) - (in-directory pathname - (do-command "rlog" (list (file-namestring pathname)) - :output (make-hemlock-output-stream mark)))) - (change-to-buffer buffer) - (buffer-start (current-point)) - (setf (buffer-modified buffer) nil))) - -(defcommand "RCS File Log Entry" (p) - "Prompt for a file and get its RCS log entry in a buffer." - "Prompt for a file and get its RCS log entry in a buffer." - (declare (ignore p)) - (let ((file (prompt-for-file :prompt "File to get log of: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil)) - (buffer (get-log-buffer))) - (delete-region (buffer-region buffer)) - (message "Extracing log info ...") - (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) - (in-directory file - (do-command "rlog" (list (file-namestring file)) - :output (make-hemlock-output-stream mark)))) - (change-to-buffer buffer) - (buffer-start (current-point)) - (setf (buffer-modified buffer) nil))) - - -;;;; Directory Support - -(defun list-out-of-date-files (dir) - (let ((rcsdir (make-pathname :host (pathname-host dir) - :device (pathname-device dir) - :directory (concatenate 'simple-vector - (pathname-directory dir) - (vector "RCS")))) - (out-of-date-files nil)) - (unless (directoryp rcsdir) - (editor-error "Could not find the RCS directory.")) - (dolist (rcsfile (directory rcsdir)) - (let ((rcsname (file-namestring rcsfile))) - (when (string= rcsname ",v" :start1 (- (length rcsname) 2)) - (let* ((name (subseq rcsname 0 (- (length rcsname) 2))) - (file (merge-pathnames (parse-namestring name) dir))) - (unless (and (probe-file file) - (>= (file-write-date file) (file-write-date rcsfile))) - (push file out-of-date-files)))))) - out-of-date-files)) - -(defun rcs-prompt-for-directory (prompt) - (let* ((default (buffer-default-pathname (current-buffer))) - (dir (prompt-for-file :prompt prompt - :default (make-pathname - :host (pathname-host default) - :device (pathname-device default) - :directory (pathname-directory default) - :defaults nil) - :must-exist nil))) - (unless (directoryp dir) - (let ((with-slash (parse-namestring (concatenate 'simple-string - (namestring dir) - "/")))) - (unless (directoryp with-slash) - (editor-error "~S is not a directory" (namestring dir))) - (setf dir with-slash))) - dir)) - -(defcommand "RCS Update Directory" (p) - "Prompt for a directory and check out all files that are older than - their corresponding RCS files. With an argument, never ask about - overwriting writable files." - "Prompt for a directory and check out all files that are older than - the corresponding RCS file. With an argument, never ask about - overwriting writable files." - (let* ((directory (rcs-prompt-for-directory "Directory to update: ")) - (out-of-date-files (list-out-of-date-files directory)) - (n-out-of-date (length out-of-date-files))) - (cond ((zerop n-out-of-date) - (message "All RCS files in ~A are up to date." - (namestring directory))) - (t - (let ((n-checked-out - (maybe-rcs-check-out-files out-of-date-files nil p))) - (message "Number of files out of date: ~D; ~ - number of files checked out: ~D" - n-out-of-date n-checked-out))))))) - -(defcommand "RCS List Out Of Date Files" (p) - "Prompt for a directory and list all of the files that are older than - their corresponding RCS files." - "Prompt for a directory and list all of the files that are older than - their corresponding RCS files." - (declare (ignore p)) - (let* ((directory (rcs-prompt-for-directory "Directory: ")) - (out-of-date-files (list-out-of-date-files directory))) - (cond ((null out-of-date-files) - (message "All RCS files in ~A are up to date." - (namestring directory))) - (t - (with-pop-up-display (s :buffer-name "*RCS Out of Date Files*") - (format s "Directory: ~A~%~%" (namestring directory)) - (dolist (file out-of-date-files) - (format s "~A~%" (file-namestring file)))))))) diff --git a/hemlock/register.lisp b/hemlock/register.lisp deleted file mode 100644 index eb49e71ebb2f2fe1bf2821fe9a7863a735ec117f..0000000000000000000000000000000000000000 --- a/hemlock/register.lisp +++ /dev/null @@ -1,181 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Registers for holding text and positions. -;;; -;;; Written by Dave Touretzky. -;;; Modified by Bill Chiles for Hemlock consistency. -;;; -(in-package 'hemlock) - - - -;;;; Registers implementation. - -;;; Registers are named by characters. Each register refers to a mark or -;;; a cons of a region and the buffer it came from. -;;; -(defvar *registers* (make-hash-table)) - -(defun register-count () - (hash-table-count *registers*)) - -(defun register-value (reg-name) - (gethash reg-name *registers*)) - -(defsetf register-value (reg-name) (new-value) - (let ((name (gensym)) - (value (gensym)) - (old-value (gensym))) - `(let* ((,name ,reg-name) - (,value ,new-value) - (,old-value (gethash ,name *registers*))) - (when (and ,old-value (markp ,old-value)) - (delete-mark ,old-value)) - (setf (gethash ,name *registers*) ,value)))) - -(defun prompt-for-register (&optional (prompt "Register: ") must-exist) - (let ((reg-name (char-upcase (prompt-for-character :prompt prompt)))) - (unless (or (not must-exist) (gethash reg-name *registers*)) - (editor-error "Register ~A is empty." reg-name)) - reg-name)) - - -(defmacro do-registers ((name value &optional sorted) &rest body) - (if sorted - (let ((sorted-regs (gensym)) - (reg (gensym))) - `(let ((,sorted-regs nil)) - (declare (list ,sorted-regs)) - (maphash #'(lambda (,name ,value) - (push (cons ,name ,value) ,sorted-regs)) - *registers*) - (setf ,sorted-regs (sort ,sorted-regs #'char-lessp :key #'car)) - (dolist (,reg ,sorted-regs) - (let ((,name (car ,reg)) - (,value (cdr ,reg))) - ,@body)))) - `(maphash #'(lambda (,name ,value) - ,@body) - *registers*))) - - -;;; Hook to clean things up if a buffer is deleted while registers point to it. -;;; -(defun flush-reg-references-to-deleted-buffer (buffer) - (do-registers (name value) - (declare (ignore name)) - (etypecase value - (mark (when (eq (line-buffer (mark-line value)) buffer) - (free-register name))) - (cons (free-register-value value buffer))))) -;;; -(add-hook delete-buffer-hook 'flush-reg-references-to-deleted-buffer) - - -(defun free-register (name) - (let ((value (register-value name))) - (when value (free-register-value value))) - (remhash name *registers*)) - -(defun free-register-value (value &optional buffer) - (etypecase value - (mark - (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer)) - (delete-mark value))) - (cons - (when (and buffer (eq (cdr value) buffer)) - (setf (cdr value) nil))))) - - - -;;;; Commands. - -;;; These commands all stash marks and regions with marks that point into some -;;; buffer, and they assume that the register values have the same property. -;;; - -(defcommand "Save Position" (p) - "Saves the current location in a register. Prompts for register name." - "Saves the current location in a register. Prompts for register name." - (declare (ignore p)) - (let ((reg-name (prompt-for-register))) - (setf (register-value reg-name) - (copy-mark (current-point) :left-inserting)))) - -(defcommand "Jump to Saved Position" (p) - "Moves the point to a location previously saved in a register." - "Moves the point to a location previously saved in a register." - (declare (ignore p)) - (let* ((reg-name (prompt-for-register "Jump to Register: " t)) - (val (register-value reg-name))) - (unless (markp val) - (editor-error "Register ~A does not hold a location." reg-name)) - (change-to-buffer (line-buffer (mark-line val))) - (move-mark (current-point) val))) - -(defcommand "Kill Register" (p) - "Kill a regist er. Prompts for the name." - "Kill a register. Prompts for the name." - (declare (ignore p)) - (free-register (prompt-for-register "Register to kill: "))) - -(defcommand "List Registers" (p) - "Lists all registers in a pop-up window." - "Lists all registers in a pop-up window." - (declare (ignore p)) - (with-pop-up-display (f :height (* 2 (register-count))) - (do-registers (name val :sorted) - (write-string "Reg " f) - (print-pretty-character name f) - (write-string ": " f) - (etypecase val - (mark - (let* ((line (mark-line val)) - (buff (line-buffer line)) - (len (line-length line))) - (format f "Line ~S, col ~S in buffer ~A~% ~A~:[~;...~]~%" - (count-lines (region (buffer-start-mark buff) val)) - (mark-column val) - (buffer-name buff) - (subseq (line-string line) 0 (min 61 len)) - (> len 60)))) - (cons - (let* ((str (region-to-string (car val))) - (nl (position #\newline str :test #'char=)) - (len (length str)) - (buff (cdr val))) - (declare (simple-string str)) - (format f "Text~@[ from buffer ~A~]~% ~A~:[~;...~]~%" - (if buff (buffer-name buff)) - (subseq str 0 (if nl (min 61 len nl) (min 61 len))) - (> len 60)))))))) - -(defcommand "Put Register" (p) - "Copies a region into a register. Prompts for register name." - "Copies a region into a register. Prompts for register name." - (declare (ignore p)) - (let ((region (current-region))) - ;; Bind the region before prompting in case the region isn't active. - (setf (register-value (prompt-for-register)) - (cons (copy-region region) (current-buffer))))) - -(defcommand "Get Register" (p) - "Copies a region from a register to the current point." - "Copies a region from a register to the current point." - (declare (ignore p)) - (let* ((reg-name (prompt-for-register "Register from which to get text: " t)) - (val (register-value reg-name))) - (unless (and (consp val) (regionp (car val))) - (editor-error "Register ~A does not hold a region." reg-name)) - (let ((point (current-point))) - (push-buffer-mark (copy-mark point)) - (insert-region (current-point) (car val)))) - (setf (last-command-type) :ephemerally-active)) diff --git a/hemlock/ring.lisp b/hemlock/ring.lisp deleted file mode 100644 index 6dccacb3d03df64e5987a62e420fd4523d594ffd..0000000000000000000000000000000000000000 --- a/hemlock/ring.lisp +++ /dev/null @@ -1,204 +0,0 @@ -;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; -;;; This file defines a ring-buffer type and access functions. -;;; -(in-package 'hemlock-internals) -(export '(ring ringp make-ring ring-push ring-pop ring-length ring-ref - rotate-ring)) - - -(defun %print-hring (obj stream depth) - (declare (ignore depth obj)) - (write-string "#<Hemlock Ring>" stream)) - -;;;; The ring data structure: -;;; -;;; An empty ring is indicated by an negative First value. -;;; The Bound is made (1- (- Size)) to make length work. Things are -;;; pushed at high indices first. -;;; -(defstruct (ring (:predicate ringp) - (:constructor internal-make-ring) - (:print-function %print-hring)) - "Used with Ring-Push and friends to implement ring buffers." - (first -1 :type fixnum) ;The index of the first position used. - (bound () :type fixnum) ;The index after the last element. - delete-function ;The function to be called on deletion. - (vector () :type simple-vector)) ;The vector. - -;;; make-ring -- Public -;;; -;;; Make a new empty ring with some maximum size and type. -;;; -(defun make-ring (size &optional (delete-function #'identity)) - "Make a ring-buffer which can hold up to Size objects. Delete-Function - is a function which is called with each object that falls off the - end." - (unless (and (fixnump size) (> size 0)) - (error "Ring size, ~S is not a positive fixnum." size)) - (internal-make-ring :delete-function delete-function - :vector (make-array size) - :bound (1- (- size)))) - -;;; ring-push -- Public -;;; -;;; Decrement first modulo the maximum size, delete any old -;;; element, and add the new one. -;;; -(defun ring-push (object ring) - "Push an object into a ring, deleting an element if necessary." - (let ((first (ring-first ring)) - (vec (ring-vector ring)) victim) - (declare (simple-vector vec) (fixnum first victim)) - (cond - ;; If zero, wrap around to end. - ((zerop first) - (setq victim (1- (length vec)))) - ;; If empty then fix up pointers. - ((minusp first) - (setf (ring-bound ring) 0) - (setq victim (1- (length vec)))) - (t - (setq victim (1- first)))) - (when (= first (ring-bound ring)) - (funcall (ring-delete-function ring) (aref vec victim)) - (setf (ring-bound ring) victim)) - (setf (ring-first ring) victim) - (setf (aref vec victim) object))) - - -;;; ring-pop -- Public -;;; -;;; Increment first modulo the maximum size. -;;; -(defun ring-pop (ring) - "Pop an object from a ring and return it." - (let* ((first (ring-first ring)) - (vec (ring-vector ring)) - (new (if (= first (1- (length vec))) 0 (1+ first))) - (bound (ring-bound ring))) - (declare (fixnum first new bound) (simple-vector vec)) - (cond - ((minusp bound) - (error "Cannot pop from an empty ring.")) - ((= new bound) - (setf (ring-first ring) -1 (ring-bound ring) (1- (- (length vec))))) - (t - (setf (ring-first ring) new))) - (shiftf (aref vec first) nil))) - - -;;; ring-length -- Public -;;; -;;; Return the current and maximum size. -;;; -(defun ring-length (ring) - "Return as values the current and maximum size of a ring." - (let ((diff (- (ring-bound ring) (ring-first ring))) - (max (length (ring-vector ring)))) - (declare (fixnum diff max)) - (values (if (plusp diff) diff (+ max diff)) max))) - -;;; ring-ref -- Public -;;; -;;; Do modulo arithmetic to find the correct element. -;;; -(defun ring-ref (ring index) - (declare (fixnum index)) - "Return the index'th element of a ring. This can be set with Setf." - (let ((first (ring-first ring))) - (declare (fixnum first)) - (cond - ((and (zerop index) (not (minusp first))) - (aref (ring-vector ring) first)) - (t - (let* ((diff (- (ring-bound ring) first)) - (sum (+ first index)) - (vec (ring-vector ring)) - (max (length vec))) - (declare (fixnum diff max sum) (simple-vector vec)) - (when (or (>= index (if (plusp diff) diff (+ max diff))) - (minusp index)) - (error "Ring index ~D out of bounds." index)) - (aref vec (if (>= sum max) (- sum max) sum))))))) - - -;;; %set-ring-ref -- Internal -;;; -;;; Setf form for ring-ref, set a ring element. -;;; -(defun %set-ring-ref (ring index value) - (declare (fixnum index)) - (let* ((first (ring-first ring)) - (diff (- (ring-bound ring) first)) - (sum (+ first index)) - (vec (ring-vector ring)) - (max (length vec))) - (declare (fixnum diff first max) (simple-vector vec)) - (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index)) - (error "Ring index ~D out of bounds." index)) - (setf (aref vec (if (>= sum max) (- sum max) sum)) value))) - -(eval-when (compile eval) -(defmacro 1+m (exp base) - `(if (= ,exp ,base) 0 (1+ ,exp))) -(defmacro 1-m (exp base) - `(if (zerop ,exp) ,base (1- ,exp))) -) ;eval-when (compile eval) - -;;; rotate-ring -- Public -;;; -;;; Rotate a ring, blt'ing elements as necessary. -;;; -(defun rotate-ring (ring offset) - "Rotate a ring forward, i.e. second -> first, with positive offset, - or backwards with negative offset." - (declare (fixnum offset)) - (let* ((first (ring-first ring)) - (bound (ring-bound ring)) - (vec (ring-vector ring)) - (max (length vec))) - (declare (fixnum first bound max) (simple-vector vec)) - (cond - ((= first bound) - (let ((new (rem (+ offset first) max))) - (declare (fixnum new)) - (if (minusp new) (setq new (+ new max))) - (setf (ring-first ring) new) - (setf (ring-bound ring) new))) - ((not (minusp first)) - (let* ((diff (- bound first)) - (1-max (1- max)) - (length (if (plusp diff) diff (+ max diff))) - (off (rem offset length))) - (declare (fixnum diff length off 1-max)) - (cond - ((minusp offset) - (do ((dst (1-m first 1-max) (1-m dst 1-max)) - (src (1-m bound 1-max) (1-m src 1-max)) - (cnt off (1+ cnt))) - ((zerop cnt) - (setf (ring-first ring) (1+m dst 1-max)) - (setf (ring-bound ring) (1+m src 1-max))) - (declare (fixnum dst src cnt)) - (shiftf (aref vec dst) (aref vec src) nil))) - (t - (do ((dst bound (1+m dst 1-max)) - (src first (1+m src 1-max)) - (cnt off (1- cnt))) - ((zerop cnt) - (setf (ring-first ring) src) - (setf (ring-bound ring) dst)) - (declare (fixnum dst src cnt)) - (shiftf (aref vec dst) (aref vec src) nil)))))))) - ring) diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp deleted file mode 100644 index 6bef157eee7a1835e98ca4a4053fde79f1a733e6..0000000000000000000000000000000000000000 --- a/hemlock/rompsite.lisp +++ /dev/null @@ -1,1538 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; "Site dependent" stuff for the editor while on the IBM RT PC machine. -;;; - -(in-package "SYSTEM") - -(export '(without-hemlock)) - - -(in-package "HEMLOCK-INTERNALS" :nicknames '("HI")) - -(export '(show-mark editor-sleep text-character print-pretty-character - *input-transcript* *real-editor-input* input-waiting - fun-defined-from-pathname editor-describe-function pause-hemlock - store-cut-string fetch-cut-string schedule-event - remove-scheduled-event enter-window-autoraise directoryp - last-key-event-cursorpos merge-relative-pathnames *editor-input* - *last-character-typed* *character-history* - ;; - ;; Export default-font to prevent a name conflict that occurs due to - ;; the Hemlock variable "Default Font" defined in SITE-INIT below. - ;; - default-font)) - - -;;; SYSTEM:WITHOUT-HEMLOCK -- Public. -;;; -;;; Code:lispinit.lisp uses this for a couple interrupt handlers, and -;;; eval-server.lisp. -;;; -(defmacro system:without-hemlock (&body body) - "When in the editor and not in the debugger, call the exit method of Hemlock's - device, so we can type. Do the same thing on exit but call the init method." - `(progn - (when (and *in-the-editor* (not debug::*in-the-debugger*)) - (let ((device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-exit device) device))) - ,@body - (when (and *in-the-editor* (not debug::*in-the-debugger*)) - (let ((device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-init device) device))))) - - - -;;;; SITE-INIT. - -;;; *character-history* is defined much later in this file, but it needs to -;;; be set in SITE-INIT, since MAKE-RING doesn't exist at load time for this -;;; file. -;;; -(proclaim '(special *character-history*)) - -;;; SITE-INIT -- Internal -;;; -;;; This function is called at init time to set up any site stuff. -;;; -(defun site-init () - (defhvar "Beep Border Width" - "Width in pixels of the border area inverted by beep." - :value 20) - (defhvar "Default Window Width" - "This is used to make a window when prompting the user. The value is in - characters." - :value 80) - (defhvar "Default Window Height" - "This is used to make a window when prompting the user. The value is in - characters." - :value 24) - (defhvar "Default Initial Window Width" - "This is used when Hemlock first starts up to make its first window. - The value is in characters." - :value 80) - (defhvar "Default Initial Window Height" - "This is used when Hemlock first starts up to make its first window. - The value is in characters." - :value 24) - (defhvar "Default Initial Window X" - "This is used when Hemlock first starts up to make its first window. - The value is in pixels." - :value nil) - (defhvar "Default Initial Window Y" - "This is used when Hemlock first starts up to make its first window. - The value is in pixels." - :value nil) - (defhvar "Bell Style" - "This controls what beeps do in Hemlock. Acceptable values are :border-flash - (which is the default), :feep, :border-flash-and-feep, :flash, - :flash-and-feep, and NIL (do nothing)." - :value :border-flash) - (defhvar "Reverse Video" - "Paints white on black in window bodies, black on white in modelines." - :value nil - :hooks '(reverse-video-hook-fun)) - (defhvar "Cursor Bitmap File" - "File to read to setup cursors for Hemlock windows. The mask is found by - merging this name with \".mask\"." - :value "/usr/misc/.lisp/lib/hemlock11.cursor") - (defhvar "Enter Window Hook" - "When the mouse enters an editor window, this hook is invoked. These - functions take the Hemlock Window as an argument." - :value nil) - (defhvar "Exit Window Hook" - "When the mouse exits an editor window, this hook is invoked. These - functions take the Hemlock Window as an argument." - :value nil) - (defhvar "Set Window Autoraise" - "When non-nil, setting the current window will automatically raise that - window via a function on \"Set Window Hook\". If the value is :echo-only - (the default), then only the echo area window will be raised - automatically upon becoming current." - :value :echo-only) - (defhvar "Default Font" - "The string name of the font to be used for Hemlock -- buffer text, - modelines, random typeout, etc. The font is loaded when initializing - Hemlock." - :value "8x13") - (defhvar "Thumb Bar Meter" - "When non-nil (the default), windows will be created to be displayed with - a ruler in the bottom border of the window." - :value t) - - (setf *character-history* (make-ring 60)) - nil) - - - -;;;; Some generally useful file-system functions. - -;;; MERGE-RELATIVE-PATHNAMES takes a pathname that is either absolute or -;;; relative to default-dir, merging it as appropriate and returning a definite -;;; directory pathname. If the component comes back with a trailing slash, we -;;; have to remove it to get the MERGE-PATHNAMES to work correctly. The result -;;; must have a trailing slash. -;;; -(defun merge-relative-pathnames (pathname default-directory) - "Merges pathname with default-directory. If pathname is not absolute, it - is assumed to be relative to default-directory. The result is always a - directory." - (setf pathname (pathname pathname)) - (flet ((return-with-slash (pathname) - (let ((ns (namestring pathname))) - (declare (simple-string ns)) - (if (char= #\/ (schar ns (1- (length ns)))) - pathname - (pathname (concatenate 'simple-string ns "/")))))) - (let ((dir (pathname-directory pathname))) - (if dir - (let ((dev (pathname-device pathname))) - (if (eq dev :absolute) - (return-with-slash pathname) - (return-with-slash - (make-pathname :device (pathname-device default-directory) - :directory - (concatenate - 'simple-vector - (pathname-directory default-directory) - dir) - :defaults pathname)))) - (return-with-slash (merge-pathnames pathname default-directory)))))) - -(defun directoryp (pathname) - (not (or (pathname-name pathname) (pathname-type pathname)))) - - - -;;;; I/O specials and initialization - -(defvar *editor-input* nil - "Input stream to get unechoed unbuffered terminal input.") - -(defvar *real-editor-input* () - "The real editor input stream. Useful when we want to read from the - terminal when *editor-input* is rebound.") - - -;;; File descriptor for the terminal. -;;; -(defvar *editor-file-descriptor*) - - -;;; This is a hack, so screen can tell how to initialize screen management -;;; without re-opening the display. It is set in INIT-RAW-IO and referenced -;;; in WINDOWED-MONITOR-P. -;;; -(defvar *editor-windowed-input* nil) - - -;;; These are used for selecting X events. -;;; -;;; This says to send :key-press, :button-press, :button-release, :enter-notify, -;;; and :leave-notify events. -;;; -(defconstant input/boundary-xevents-selection-keys - '(:key-press :button-press :button-release :enter-window :leave-window)) -(defconstant input/boundary-xevents-mask - (apply #'xlib:make-event-mask input/boundary-xevents-selection-keys)) -;;; -;;; This says to send :exposure, :destroy-notify, :unmap-notify, :map-notify, -;;; :reparent-notify, :configure-notify, :gravity-notify, and :circulate-notify -;;; in addition to the above events. Of those enumerated here, we only care -;;; about :exposure and :configure-notify. -;;; -(defconstant interesting-xevents-receive-keys - '(:key-press :button-press :button-release :enter-notify :leave-notify - :exposure :graphics-exposure :configure-notify :destroy-notify :unmap-notify - :map-notify :reparent-notify :gravity-notify :circulate-notify)) -(defconstant interesting-xevents-mask - (apply #'xlib:make-event-mask - (append input/boundary-xevents-selection-keys - '(:exposure :structure-notify)))) - -(defconstant random-typeout-xevents-mask - (apply #'xlib:make-event-mask - (append input/boundary-xevents-selection-keys - '(:exposure)))) - - -(proclaim '(special ed::*open-paren-highlight-font* - ed::*active-region-highlight-font*)) - -(defparameter lisp-fonts-pathnames - '("/usr/misc/.lisp/lib/fonts/" - "/afs/cs.cmu.edu/unix/rt_mach/omega/usr/misc/.lisp/lib/fonts/")) - - -;;; INIT-RAW-IO -- Internal -;;; -;;; This function should be called whenever the editor is entered in a new -;;; lisp. It sets up process specific data structures. -;;; -(defun init-raw-io (display) - (setf *editor-windowed-input* nil) - (cond (display - (setf *editor-windowed-input* (ext:open-clx-display display)) - (setf *editor-input* (make-editor-window-input-stream)) - (ext:carefully-add-font-paths *editor-windowed-input* - lisp-fonts-pathnames) - (setup-font-family *editor-windowed-input* - (variable-value 'ed::default-font) - "8x13u" "8x13bold")) - (t ;; The editor's file descriptor is Unix standard input (0). - ;; We don't need to affect system:*file-input-handlers* here - ;; because the init and exit methods for tty redisplay devices - ;; take care of this. - ;; - (setf *editor-file-descriptor* 0) - (setf *editor-input* (make-editor-tty-input-stream 0)))) - (setf *real-editor-input* *editor-input*) - *editor-windowed-input*) - -;;; Stop flaming from compiler due to CLX macros expanding into illegal -;;; declarations. -;;; -(proclaim '(declaration values)) -(proclaim '(special *default-font-family*)) - -;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would -;;; assume it to be special, issuing a nasty warning. -;;; -(defconstant font-map-size 16 - "The number of possible fonts in a font-map.") - - -;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names -;;; passed in. The font family structure is filled in from the first argument. -;;; Actually, this ignores default-highlight-font and default-open-paren-font -;;; in lieu of "Active Region Highlighting Font" and "Open Paren Highlighting -;;; Font" when these are defined. -;;; -(defun setup-font-family (display default-font default-highlight-font - default-open-paren-font) - (let* ((font-family (make-font-family :map (make-array font-map-size - :initial-element 0) - :cursor-x-offset 0 - :cursor-y-offset 0)) - (font-family-map (font-family-map font-family))) - (declare (simple-vector font-family-map)) - (setf *default-font-family* font-family) - (let ((font (xlib:open-font display default-font))) - (unless font (error "Cannot open font -- ~S" default-font)) - (fill font-family-map font) - (let ((width (xlib:max-char-width font))) - (setf (font-family-width font-family) width) - (setf (font-family-cursor-width font-family) width)) - (let* ((baseline (xlib:font-ascent font)) - (height (+ baseline (xlib:font-descent font)))) - (setf (font-family-height font-family) height) - (setf (font-family-cursor-height font-family) height) - (setf (font-family-baseline font-family) baseline))) - (setup-one-font display - (or (variable-value 'ed::open-paren-highlighting-font) - default-open-paren-font) - font-family-map - ed::*open-paren-highlight-font*) - (setup-one-font display - (or (variable-value 'ed::active-region-highlighting-font) - default-highlight-font) - font-family-map - ed::*active-region-highlight-font*))) - -;;; SETUP-ONE-FONT tries to open font-name for display, storing the result in -;;; font-family-map at index. XLIB:OPEN-FONT will return font stuff regardless -;;; if the request is valid or not, so we finish the output to get synch'ed -;;; with the server which will cause any errors to get signaled. At this -;;; level, we want to deal with this error here returning nil if the font -;;; couldn't be opened. -;;; -(defun setup-one-font (display font-name font-family-map index) - (handler-case (let ((font (xlib:open-font display (namestring font-name)))) - (xlib:display-finish-output display) - (setf (svref font-family-map index) font)) - (xlib:name-error () - (warn "Cannot open font -- ~S" font-name) - nil))) - - - -;;;; HEMLOCK-BEEP. - -(defvar *editor-bell* (make-string 1 :initial-element #\bell)) - -;;; TTY-BEEP is used in Hemlock for beeping when running under a terminal. -;;; Send a #\bell to unix standard output. -;;; -(defun tty-beep (&optional device stream) - (declare (ignore device stream)) - (when (variable-value 'ed::bell-style) - (mach:unix-write 1 *editor-bell* 0 1))) - -(proclaim '(special *current-window*)) - -;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed -;;; input. -;;; -(defun bitmap-beep (display stream) - (declare (ignore stream)) - (ecase (variable-value 'ed::bell-style) - (:border-flash - (flash-window-border *current-window*)) - (:feep - (xlib:bell display) - (xlib:display-force-output display)) - (:border-flash-and-feep - (xlib:bell display) - (xlib:display-force-output display) - (flash-window-border *current-window*)) - (:flash - (flash-window *current-window*)) - (:flash-and-feep - (xlib:bell display) - (xlib:display-force-output display) - (flash-window *current-window*)) - ((nil) ;Do nothing. - ))) - -(proclaim '(special *foreground-background-xor*)) - -(defun flash-window-border (window) - (let* ((hunk (window-hunk window)) - (xwin (bitmap-hunk-xwindow hunk)) - (gcontext (bitmap-hunk-gcontext hunk)) - (display (bitmap-device-display (device-hunk-device hunk))) - (border (variable-value 'ed::beep-border-width)) - (h (or (bitmap-hunk-modeline-pos hunk) (bitmap-hunk-height hunk))) - (top-border (min (ash h -1) border)) - (w (bitmap-hunk-width hunk)) - (side-border (min (ash w -1) border)) - (top-width (max 0 (- w (ash side-border 1)))) - (right-x (- w side-border)) - (bottom-y (- h top-border))) - (xlib:with-gcontext (gcontext :function xlib::boole-xor - :foreground *foreground-background-xor*) - (dotimes (i 8) - (xlib:draw-rectangle xwin gcontext 0 0 side-border h t) - (xlib:display-force-output display) - (xlib:draw-rectangle xwin gcontext side-border bottom-y - top-width top-border t) - (xlib:display-force-output display) - (xlib:draw-rectangle xwin gcontext right-x 0 side-border h t) - (xlib:display-force-output display) - (xlib:draw-rectangle xwin gcontext side-border 0 top-width top-border t) - (xlib:display-force-output display))))) - -(defun flash-window (window) - (let* ((hunk (window-hunk window)) - (xwin (bitmap-hunk-xwindow hunk)) - (gcontext (bitmap-hunk-gcontext hunk)) - (display (bitmap-device-display (device-hunk-device hunk))) - (width (bitmap-hunk-width hunk)) - (height (or (bitmap-hunk-modeline-pos hunk) - (bitmap-hunk-height hunk)))) - (xlib:with-gcontext (gcontext :function xlib::boole-xor - :foreground *foreground-background-xor*) - (xlib:draw-rectangle xwin gcontext 0 0 width height t) - (xlib:display-force-output display) - (xlib:draw-rectangle xwin gcontext 0 0 width height t) - (xlib:display-force-output display)))) - - - -(defun hemlock-beep (stream) - "Using the current window, calls the device's beep function on stream." - (let ((device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-beep device) (bitmap-device-display device) stream))) - - - -;;;; GC messages. - -;;; HEMLOCK-GC-NOTIFY-BEFORE and HEMLOCK-GC-NOTIFY-AFTER both MESSAGE GC -;;; notifications when Hemlock is not running under X11. It cannot affect -;;; its window's without using its display connection. Since GC can occur -;;; inside CLX request functions, using the same display confuses CLX. -;;; - -(defun hemlock-gc-notify-before (bytes-in-use) - (let ((control "~%[GC threshold exceeded with ~:D bytes in use. ~ - Commencing GC.]~%")) - (cond ((not hi::*editor-windowed-input*) - (beep) - #|(message control bytes-in-use)|#) - (t - ;; Can't call BEEP since it would use Hemlock's display connection. - (lisp::default-beep-function *standard-output*) - (format t control bytes-in-use) - (finish-output))))) - -(defun hemlock-gc-notify-after (bytes-retained bytes-freed trigger) - (let ((control - "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%~ - [GC will next occur when at least ~:D bytes are in use.]~%")) - (cond ((not hi::*editor-windowed-input*) - (beep) - #|(message control bytes-retained bytes-freed)|#) - (t - ;; Can't call BEEP since it would use Hemlock's display connection. - (lisp::default-beep-function *standard-output*) - (format t control bytes-retained bytes-freed trigger) - (finish-output))))) - - - -;;;; Site-Wrapper-Macro and standard device init/exit functions. - -(defun in-hemlock-standard-input-read (stream &rest ignore) - (declare (ignore ignore)) - (error "You cannot read off this stream while in Hemlock -- ~S" - stream)) - -(defvar *illegal-read-stream* - (lisp::make-stream :in #'in-hemlock-standard-input-read)) - -(defmacro site-wrapper-macro (&body body) - `(unwind-protect - (progn - (when *editor-has-been-entered* - (let ((device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-init device) device))) - (let ((*beep-function* #'hemlock-beep) - (*gc-notify-before* #'hemlock-gc-notify-before) - (*gc-notify-after* #'hemlock-gc-notify-after) - (*standard-input* *illegal-read-stream*) - (*query-io* *illegal-read-stream*)) - (cond ((not *editor-windowed-input*) - ,@body) - (t - (ext:with-clx-event-handling - (*editor-windowed-input* #'ext:object-set-event-handler) - ,@body))))) - (let ((device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-exit device) device)))) - -(defun standard-device-init () - (setup-input)) - -(defun standard-device-exit () - (reset-input)) - -(proclaim '(special *echo-area-window*)) - -;;; Maybe bury/unbury hemlock window when we go to and from Lisp. -;;; This should do something more sophisticated when we know what that is. -;;; -(defun default-hemlock-window-mngt (display on) - (let ((win (bitmap-hunk-xwindow (window-hunk *current-window*))) - (ewin (bitmap-hunk-xwindow (window-hunk *echo-area-window*)))) - (cond (on (setf (xlib:window-priority ewin) :above) - (clear-input *editor-input*) - (setf (xlib:window-priority win) :above)) - (t (setf (xlib:window-priority ewin) :below) - (setf (xlib:window-priority win) :below)))) - (xlib:display-force-output display)) - -(defvar *hemlock-window-mngt* #'default-hemlock-window-mngt - "This function is called by HEMLOCK-WINDOW, passing its arguments. This may - be nil.") - -(defun hemlock-window (display on) - "Calls *hemlock-window-mngt* on the argument ON when *current-window* is - bound. This is called in the device init and exit methods for X bitmap - devices." - (when (and *hemlock-window-mngt* *current-window*) - (funcall *hemlock-window-mngt* display on))) - - - -;;;; Current terminal character translation. - -(defvar *terminal-translation-table* (make-array 128)) - -;;; Converting ASCII control characters to Common Lisp control characters: -;;; ASCII control character codes are separated from the codes of the -;;; "non-controlified" characters by the code of atsign. The ASCII control -;;; character codes range from ^@ (0) through ^_ (one less than the code of -;;; space). We iterate over this range adding the ASCII code of atsign to -;;; get the "non-controlified" character code. With each of these, we turn -;;; the code into a Common Lisp character and set its :control bit. Certain -;;; ASCII control characters have to be translated to special Common Lisp -;;; characters outside of the loop. -;;; With the advent of Hemlock running under X, and all the key bindings -;;; changing, we also downcase each Common Lisp character (where normally -;;; control characters come in upcased) in an effort to obtain normal command -;;; bindings. Commands bound to uppercase modified characters will not be -;;; accessible to terminal interaction. -;;; -(let ((@-code (char-code #\@))) - (dotimes (i (char-code #\space)) - (setf (svref *terminal-translation-table* i) - (set-char-bit (char-downcase (code-char (+ i @-code))) :control t)))) -(setf (svref *terminal-translation-table* 9) #\tab) -(setf (svref *terminal-translation-table* 10) #\linefeed) -(setf (svref *terminal-translation-table* 13) #\return) -(setf (svref *terminal-translation-table* 27) #\alt) -(setf (svref *terminal-translation-table* 8) #\backspace) -;;; -;;; Other ASCII codes are exactly the same as the Common Lisp codes. -;;; -(do ((i (char-code #\space) (1+ i))) - ((= i 128)) - (setf (svref *terminal-translation-table* i) (code-char i))) - -;;; TRANSLATE-TTY-CHAR is our interface to be used in GET-EDITOR-INPUT. -;;; -(proclaim '(inline translate-tty-char)) -(defun translate-tty-char (char) - (svref *terminal-translation-table* char)) - - -(defconstant termcap-file "/etc/termcap") - -(defun cl-termcap-char (char) - (if (char-bit char :control) - (code-char (the fixnum - (- (the fixnum (char-code char)) - 64))) ;(char-code #\@) - (case char - (#\alt (code-char 27)) - (#\newline (code-char 10)) - (#\return (code-char 13)) - (#\tab (code-char 9)) - (#\backspace (code-char 8)) - (#\formfeed (code-char 12)) - (t char)))) - - - -;;;; Common editor input: stream def, event queue mngt, kbdmac waiting, -;;;; more prompt, input method macro. - -;;; This is the basic editor stream definition. More particular stream -;;; definitions below include this. -;;; -(defstruct (editor-input-stream - (:include stream) - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (write-string "#<Editor-Input stream>" stream))) - (:constructor make-editor-input-stream - (head &optional (tail head)))) - ;; - ;; FIFO queue of events on this stream. The queue always contains - ;; at least one one element, which is the character most recently read. - ;; If no event has been read, the event is a dummy with a NIL char. - head ; First key event in queue. - tail) ; Last event in queue. - - -;;; Key event queue. -;;; - -(defstruct (key-event - (:constructor make-key-event ())) - next ; Next queued event, or NIL if none. - hunk ; Screen hunk event was read from. - char ; Character read. - x ; X and Y character position of mouse cursor. - y - unread-p) - -(defvar *free-key-events* ()) - -(defun new-event (char x y hunk next &optional unread-p) - (let ((res (if *free-key-events* - (shiftf *free-key-events* (key-event-next *free-key-events*)) - (make-key-event)))) - (setf (key-event-char res) char) - (setf (key-event-x res) x) - (setf (key-event-y res) y) - (setf (key-event-hunk res) hunk) - (setf (key-event-next res) next) - (setf (key-event-unread-p res) unread-p) - res)) - -(defvar *last-character-typed* () - "This variable contains the last character typed to the command - interpreter.") - -;;; *character-history* is setup in SITE-INIT. -;;; -(defvar *character-history* nil - "This ring holds the last 60 characters read by the command interpreter.") - -(proclaim '(special *input-transcript*)) - -;;; DQ-EVENT is used in editor stream methods for popping off input. -;;; If there is an event not yet read in Stream, then pop the queue -;;; and return the character. If there is none, return NIL. -;;; -(defun dq-event (stream) - (without-interrupts - (let* ((head (editor-input-stream-head stream)) - (next (key-event-next head))) - (if next - (let ((char (key-event-char next))) - (setf (editor-input-stream-head stream) next) - (shiftf (key-event-next head) *free-key-events* head) - (ring-push char *character-history*) - (setq *last-character-typed* char) - (when *input-transcript* - (vector-push-extend char *input-transcript*)) - char))))) - -;;; Q-EVENT is used in low level input fetching routines to add input to the -;;; editor stream. -;;; -(defun q-event (stream char &optional x y hunk) - (without-interrupts - (let ((new (new-event char x y hunk nil)) - (tail (editor-input-stream-tail stream))) - (setf (key-event-next tail) new) - (setf (editor-input-stream-tail stream) new)))) - -(defun un-event (char stream) - (without-interrupts - (let* ((head (editor-input-stream-head stream)) - (next (key-event-next head)) - (new (new-event char (key-event-x head) (key-event-y head) - (key-event-hunk head) next t))) - (setf (key-event-next head) new) - (unless next (setf (editor-input-stream-tail stream) new))))) - - -;;; Keyboard macro hacks. -;;; - -(defvar *input-transcript* () - "If this variable is non-null then it should contain an adjustable vector - with a fill pointer into which all keyboard input will be pushed.") - -;;; INPUT-WAITING -- Internal -;;; -;;; An Evil hack that tells us whether there is an unread character on -;;; *editor-input*. Note that this is applied to the real *editor-input* -;;; rather than to a kbdmac stream. -;;; -(defun input-waiting () - "Returns true if there is a character which has been unread-char'ed - on *editor-input*. Used by the keyboard macro stuff." - (let ((next (key-event-next (editor-input-stream-head *real-editor-input*)))) - (and next (key-event-unread-p next)))) - - -;;; Random typeout hacks. -;;; - -(defun wait-for-more (stream) - (let ((ch (more-read-ch))) - (cond ((logical-char= ch :yes)) - ((or (logical-char= ch :do-all) - (logical-char= ch :exit)) - (setf (random-typeout-stream-no-prompt stream) t) - (random-typeout-cleanup stream)) - ((logical-char= ch :keep) - (setf (random-typeout-stream-no-prompt stream) t) - (maybe-keep-random-typeout-window stream) - (random-typeout-cleanup stream)) - ((logical-char= ch :no) - (random-typeout-cleanup stream) - (throw 'more-punt nil)) - (t - (unread-char ch *editor-input*) - (random-typeout-cleanup stream) - (throw 'more-punt nil))))) - -(proclaim '(special *more-prompt-action*)) - -(defun maybe-keep-random-typeout-window (stream) - (let* ((window (random-typeout-stream-window stream)) - (buffer (window-buffer window)) - (start (buffer-start-mark buffer))) - (when (typep (hi::device-hunk-device (hi::window-hunk window)) - 'hi::bitmap-device) - (let ((*more-prompt-action* :normal)) - (update-modeline-field buffer window :more-prompt) - (random-typeout-redisplay window)) - (buffer-start (buffer-point buffer)) - (unless (make-window start :window (make-xwindow-like-hwindow window)) - (editor-error "Could not create random typeout window."))))) - -(defun end-random-typeout (stream) - (let ((*more-prompt-action* :flush) - (window (random-typeout-stream-window stream))) - (update-modeline-field (window-buffer window) window :more-prompt) - (random-typeout-redisplay window)) - (unless (random-typeout-stream-no-prompt stream) - (let* ((ch (more-read-ch)) - (keep-p (logical-char= ch :keep))) - (when keep-p (maybe-keep-random-typeout-window stream)) - (random-typeout-cleanup stream) - (unless (or (logical-char= ch :do-all) - (logical-char= ch :exit) - (logical-char= ch :no) - (logical-char= ch :yes) - keep-p) - (unread-char ch *editor-input*))))) - -;;; MORE-READ-CH gets some input from the type of stream bound to -;;; *editor-input*. Need to loop over SERVE-EVENT since it returns on any kind -;;; of event (not necessarily a key or button event). -;;; -;;; Currently this does not work for keyboard macro streams! -;;; -(defun more-read-ch () - (clear-input *editor-input*) - (let ((ch (do ((ch (dq-event *editor-input*) (dq-event *editor-input*))) - (ch ch) - (system:serve-event)))) - (when (or (char= ch #\control-g) (char= ch #\control-\g)) - (beep) - (throw 'editor-top-level-catcher nil)) - ch)) - - -;;; Input method macro. -;;; - -(defvar *in-hemlock-stream-input-method* nil - "This keeps us from undefined nasties like re-entering Hemlock stream - input methods from input hooks and scheduled events.") - -(proclaim '(special *screen-image-trashed*)) - -;;; EDITOR-INPUT-METHOD-MACRO is used in EDITOR-TTY-IN and EDITOR-WINDOW-IN. -;;; Somewhat odd stuff goes on here because this is the place where Hemlock -;;; waits, so this is where we redisplay, check the time for scheduled -;;; events, etc. In the loop, we call the input hook when we get a character -;;; and leave the loop. If there isn't any input, invoke any scheduled -;;; events whose time is up. Unless SERVE-EVENT returns immediately and did -;;; something, (serve-event 0), call redisplay, note that we are going into -;;; a read wait, and call SERVE-EVENT with a wait or infinite timeout. Upon -;;; exiting the loop, turn off the read wait note and check for the abort -;;; character. Return the character we got. -;;; We bind an error condition handler here because the default Hemlock -;;; error handler goes into a little debugging prompt loop, but if we got -;;; an error in getting input, we should prompt the user using the input -;;; method (recursively even). -;;; -(eval-when (compile eval) -(defmacro editor-input-method-macro (&optional screen-image-trashed-concern) - `(handler-bind ((error #'(lambda (condition) - (let ((device (device-hunk-device - (window-hunk (current-window))))) - (funcall (device-exit device) device)) - (invoke-debugger condition)))) -; (when *in-hemlock-stream-input-method* -; (error "Entering Hemlock stream input method recursively!")) - (let ((*in-hemlock-stream-input-method* t) - (nrw-fun (device-note-read-wait - (device-hunk-device (window-hunk (current-window))))) - char) - (loop - (when (setf char (dq-event stream)) - (dolist (f (variable-value 'ed::input-hook)) (funcall f)) - (return)) - (invoke-scheduled-events) - (unless (system:serve-event 0) - (internal-redisplay) - ,@(if screen-image-trashed-concern - '((when *screen-image-trashed* (internal-redisplay)))) - (when nrw-fun (funcall nrw-fun t)) - (let ((wait (next-scheduled-event-wait))) - (if wait (system:serve-event wait) (system:serve-event))))) - (when nrw-fun (funcall nrw-fun nil)) - (when (and (or (char= char #\control-g) (char= char #\control-\g)) - eof-error-p) - (beep) - (throw 'editor-top-level-catcher nil)) - char))) -) ;eval-when - - - -;;;; Editor tty input streams. - -(defstruct (editor-tty-input-stream - (:include editor-input-stream - (:in #'editor-tty-in) - (:misc #'editor-tty-misc)) - (:print-function - (lambda (obj stream n) - (declare (ignore obj n)) - (write-string "#<Editor-Tty-Input stream>" stream))) - (:constructor make-editor-tty-input-stream - (fd &optional (head (make-key-event)) (tail head)))) - fd) - - -(defun editor-tty-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) - (case operation - (:listen (cond ((key-event-next (editor-input-stream-head stream)) t) - ((editor-tty-listen stream) t) - (t nil))) - (:unread - (un-event arg1 stream)) - (:clear-input - (without-interrupts - (let* ((head (editor-input-stream-head stream)) - (next (key-event-next head))) - (when next - (setf (key-event-next head) nil) - (shiftf (key-event-next (editor-input-stream-tail stream)) - *free-key-events* next) - (setf (editor-input-stream-tail stream) head))))) - (:element-type 'character))) - - -(defun editor-tty-in (stream eof-error-p eof-value) - (declare (ignore eof-value)) - (editor-input-method-macro t)) - - - -;;;; Editor window input streams. - -(defstruct (editor-window-input-stream - (:include editor-input-stream - (:in #'editor-window-in) - (:misc #'editor-window-misc)) - (:print-function - (lambda (s stream d) - (declare (ignore s d write)) - (write-string "#<Editor-Window-Input stream>" stream))) - (:constructor make-editor-window-input-stream - (&optional (head (make-key-event)) (tail head)))) - hunks) ; List of bitmap-hunks which input to this stream. - - -(defun editor-window-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) - (case operation - (:listen - (loop (unless (system:serve-event 0) - ;; If nothing is pending, check the queued input. - (return (not (null (key-event-next - (editor-input-stream-head stream)))))) - (when (key-event-next (editor-input-stream-head stream)) - ;; Don't service anymore events if we just got some input. - (return t)))) - (:unread - (un-event arg1 stream)) - (:clear-input - (loop (unless (system:serve-event 0) (return))) - (without-interrupts - (let* ((head (editor-input-stream-head stream)) - (next (key-event-next head))) - (when next - (setf (key-event-next head) nil) - (shiftf (key-event-next (editor-input-stream-tail stream)) - *free-key-events* next) - (setf (editor-input-stream-tail stream) head))))) - (:element-type 'character))) - - -(defun editor-window-in (stream eof-error-p eof-value) - (declare (ignore eof-value)) - (editor-input-method-macro)) - - - -;;; LAST-KEY-EVENT-CURSORPOS -- Public -;;; -;;; Just look up the saved info in the last read key event. -;;; -(defun last-key-event-cursorpos () - "Return as values, the (X, Y) character position and window where the - last key event happened. If this cannot be determined, Nil is returned. - If in the modeline, return a Y position of NIL and the correct X and window. - Returns nil for terminal input." - (let* ((ev (editor-input-stream-head *real-editor-input*)) - (hunk (key-event-hunk ev)) - (window (and hunk (device-hunk-window hunk)))) - (when window - (values (key-event-x ev) (key-event-y ev) window)))) - - -;;; Window-Input-Handler -- Internal -;;; -;;; This is the input-handler function for hunks that implement windows. -;;; It just queues the events on the *real-editor-input* stream. -;;; -(defun window-input-handler (hunk char x y) - (q-event *real-editor-input* char x y hunk)) - - - -;;;; Event scheduling. - -;;; The time queue provides a ROUGH mechanism for scheduling events to -;;; occur after a given amount of time has passed, optionally repeating -;;; using the given time as an interval for rescheduling. When the input -;;; loop goes around, it will check the current time and process all events -;;; that should have happened before or at this time. The function gets -;;; called on the number of seconds that have elapsed since it was last -;;; called. -;;; -;;; NEXT-SCHEDULED-EVENT-WAIT and INVOKE-SCHEDULED-EVENTS are used in the -;;; editor stream in methods. -;;; -;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces. - -(defstruct (tq-event (:print-function print-tq-event) - (:constructor make-tq-event - (time last-time interval function))) - time ; When the event should happen. - last-time ; When the event was scheduled. - interval ; When non-nil, how often the event should happen. - function) ; What to do. - -(defun print-tq-event (obj stream n) - (declare (ignore n)) - (format stream "#<Tq-Event ~S>" (tq-event-function obj))) - -(defvar *time-queue* nil - "This is the time priority queue used in Hemlock input streams for event - scheduling.") - -;;; QUEUE-TIME-EVENT inserts event into the time priority queue *time-queue*. -;;; Event is inserted before the first element that it is less than (which -;;; means that it gets inserted after elements that are the same). -;;; *time-queue* is returned. -;;; -(defun queue-time-event (event) - (let ((time (tq-event-time event))) - (if *time-queue* - (if (< time (tq-event-time (car *time-queue*))) - (push event *time-queue*) - (do ((prev *time-queue* rest) - (rest (cdr *time-queue*) (cdr rest))) - ((or (null rest) - (< time (tq-event-time (car rest)))) - (push event (cdr prev)) - *time-queue*))) - (push event *time-queue*)))) - -;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for -;;; the next event to happen. -;;; -(defun next-scheduled-event-wait () - (if *time-queue* - (let ((wait (round (- (tq-event-time (car *time-queue*)) - (get-internal-real-time)) - internal-time-units-per-second))) - (if (plusp wait) wait 0)))) - -;;; INVOKE-SCHEDULED-EVENTS invokes all the functions in *time-queue* whose -;;; time has come. If we run out of events, or there are none, then we get -;;; out. If we popped an event whose time hasn't come, we push it back on the -;;; queue. Each function is called on how many seconds, roughly, went by since -;;; the last time it was called (or scheduled). If it has an interval, we -;;; re-queue it. While invoking the function, bind *time-queue* to nothing in -;;; case the event function tries to read off *editor-input*. -;;; -(defun invoke-scheduled-events () - (let ((time (get-internal-real-time))) - (loop - (unless *time-queue* (return)) - (let* ((event (car *time-queue*)) - (event-time (tq-event-time event))) - (cond ((>= time event-time) - (let ((*time-queue* nil)) - (funcall (tq-event-function event) - (round (- time (tq-event-last-time event)) - internal-time-units-per-second))) - (without-interrupts - (let ((interval (tq-event-interval event))) - (when interval - (setf (tq-event-time event) (+ time interval)) - (setf (tq-event-last-time event) time) - (pop *time-queue*) - (queue-time-event event))))) - (t (return))))))) - -(defun schedule-event (time function &optional (repeat t)) - "This causes function to be called after time seconds have passed, - optionally repeating every time seconds. This is a rough mechanism - since commands can take an arbitrary amount of time to run; the function - will be called at the first possible moment after time has elapsed. - Function takes the time that has elapsed since the last time it was - called (or since it was scheduled for the first invocation)." - (let ((now (get-internal-real-time)) - (itime (* internal-time-units-per-second time))) - (queue-time-event (make-tq-event (+ itime now) now (if repeat itime) - function)))) - -(defun remove-scheduled-event (function) - "Removes function queued with SCHEDULE-EVENT." - (setf *time-queue* (delete function *time-queue* :key #'tq-event-function))) - - - -;;;; Editor sleeping. - -(defun editor-sleep (time) - "Sleep for approximately Time seconds." - (unless (or (zerop time) (listen *editor-input*)) - (internal-redisplay) - (sleep-for-time time) - nil)) - -(defun sleep-for-time (time) - (let ((nrw-fun (device-note-read-wait - (device-hunk-device (window-hunk (current-window))))) - (end (+ (get-internal-real-time) - (truncate (* time internal-time-units-per-second))))) - (loop - (when (listen *editor-input*) (return)) - (let ((left (- end (get-internal-real-time)))) - (unless (plusp left) (return nil)) - (when nrw-fun (funcall nrw-fun t)) - (system:serve-event (/ (float left) - (float internal-time-units-per-second))))) - (when nrw-fun (funcall nrw-fun nil)))) - - - -;;;; Showing a mark. - -(defun show-mark (mark window time) - "Highlights the position of Mark within Window for Time seconds, - possibly by moving the cursor there. If Mark is not displayed within - Window return NIL. The wait may be aborted if there is pending input." - (let* ((result t)) - (catch 'redisplay-catcher - (redisplay-window window) - (setf result - (multiple-value-bind (x y) (mark-to-cursorpos mark window) - (funcall (device-show-mark - (device-hunk-device (window-hunk window))) - window x y time)))) - result)) - -(defun tty-show-mark (window x y time) - (cond ((listen *editor-input*)) - (x (internal-redisplay) - (let* ((hunk (window-hunk window)) - (device (device-hunk-device hunk))) - (funcall (device-put-cursor device) hunk x y) - (when (device-force-output device) - (funcall (device-force-output device))) - (sleep-for-time time)) - t) - (t nil))) - -(defun bitmap-show-mark (window x y time) - (cond ((listen *editor-input*)) - (x (let* ((hunk (window-hunk window)) - (display (bitmap-device-display (device-hunk-device hunk)))) - (internal-redisplay) - (hunk-show-cursor hunk x y) - (drop-cursor) - (xlib:display-finish-output display) - (sleep-for-time time) - (lift-cursor) - t)) - (t nil))) - - - -;;;; Funny character stuff. - -;;; TEXT-CHARACTER and PRINT-PRETTY-CHARACTER are documented Hemlock primitives. -;;; - -(defun text-character (char) - "Translate a character as read from *editor-input* into one suitable for - inserting into text. If this is not possible, nil is returned." - (cond ((or (char-bit char :meta) - (char-bit char :super) - (char-bit char :hyper)) - nil) - ((char= char #\return) #\newline) - ((char-bit char :control) - (let* ((nchar (char-upcase (make-char char))) - (code (char-code nchar))) - (if (<= 64 code 95) - (code-char (- code 64)) - nil))) - (t char))) - -(defun print-pretty-character (char stream) - "Prints char to stream suitably for documentation, data displays, etc. - Control, Meta, Super, and Hyper bits are shown as C-, M-, S-, and H-, - respectively. If the character is not a standard character other than - #\space or #\newline, and it has a name, then the name is printed." - (when (char-bit char :control) (write-string "C-" stream)) - (when (char-bit char :meta) (write-string "M-" stream)) - (when (char-bit char :super) (write-string "S-" stream)) - (when (char-bit char :hyper) (write-string "H-" stream)) - (let ((code (char-code char)) - (safe-char (make-char char))) - (if (<= (char-code #\!) code (char-code #\~)) - (write-char safe-char stream) - (let ((name (char-name (code-char code)))) - (cond (name (write-string (string-capitalize name) stream)) - ((< code (char-code #\space)) - (write-char #\^ stream) - (write-char (code-char (+ code (char-code #\@))) stream)) - (t - (write-char safe-char stream))))))) - -(defvar *line-wrap-char* #\! - "The character to be displayed to indicate wrapped lines.") - - - -;;;; Function description and defined-from. - -;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object. It -;;; returns a pathname for the file the function was defined in. If it was -;;; not defined in some file, then nil is returned. -;;; -(defun fun-defined-from-pathname (function) - "Takes a symbol or function and returns the pathname for the file the function - was defined in. If it was not defined in some file, nil is returned." - (typecase function - (symbol (fun-defined-from-pathname (careful-symbol-function function))) - (compiled-function - (let* ((string (%primitive header-ref function - system:%function-defined-from-slot)) - (file (subseq string 0 (position #\space string :test #'char=)))) - (declare (simple-string file)) - (if (or (char= #\# (schar file 0)) - (string-equal file "lisp")) - nil - (if (string= file "/.." :end1 3) - (pathname (subseq file - (position #\/ file :test #'char= :start 4))) - (pathname file))))) - (t nil))) - - -(defvar *editor-describe-stream* - (system:make-indenting-stream *standard-output*)) - -;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to -;;; work. These apparently work fine for DESCRIBE, for which they were defined, -;;; but not in general. It seems they don't indent initial text, only that -;;; following a newline, so inside our use of INDENTING-FURTHER, we need some -;;; form before the WRITE-STRING. To get this to work, I had to remove the ~% -;;; from the FORMAT string, and use FRESH-LINE; simply using FRESH-LINE with -;;; the ~% caused an extra blank line. Possibly I should not have glommed onto -;;; this hack whose interface comes from three different packages, but it did -;;; the right thing .... -;;; -;;; Also, we have set INDENTING-STREAM-STREAM to make sure the indenting stream -;;; is based on whatever *standard-output* is when we are called. -;;; -(defun editor-describe-function (fun sym) - "Calls DESCRIBE on fun. If fun is compiled, and its original name is not sym, - then this also outputs any 'function documentation for sym to - *standard-output*." - (describe fun) - (when (and (compiled-function-p fun) - (not (eq (%primitive header-ref fun %function-name-slot) sym))) - (let ((doc (documentation sym 'function))) - (when doc - (format t "~&Function documentation for ~S:" sym) - (setf (lisp::indenting-stream-stream *editor-describe-stream*) - *standard-output*) - (ext:indenting-further *editor-describe-stream* 2 - (fresh-line *editor-describe-stream*) - (write-string doc *editor-describe-stream*)))))) - - - - -;;;; X Stuff. - -;;; Setting window cursors ... -;;; - -(proclaim '(special *default-foreground-pixel* *default-background-pixel*)) - -(defvar *hemlock-cursor* nil "Holds cursor for Hemlock windows.") - -;;; DEFINE-WINDOW-CURSOR in shoved on the "Make Window Hook". -;;; -(defun define-window-cursor (window) - (setf (xlib:window-cursor (bitmap-hunk-xwindow (window-hunk window))) - *hemlock-cursor*)) - -;;; These are set in INIT-BITMAP-SCREEN-MANAGER and REVERSE-VIDEO-HOOK-FUN. -;;; -(defvar *cursor-foreground-color* nil) -(defvar *cursor-background-color* nil) -(defun make-white-color () (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)) -(defun make-black-color () (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)) - - -;;; GET-HEMLOCK-CURSOR is used in INIT-BITMAP-SCREEN-MANAGER to load the -;;; hemlock cursor for DEFINE-WINDOW-CURSOR. -;;; -(defun get-hemlock-cursor (display) - (when *hemlock-cursor* (xlib:free-cursor *hemlock-cursor*)) - (let* ((cursor-file (truename (variable-value 'ed::cursor-bitmap-file))) - (mask-file (probe-file (make-pathname :type "mask" - :defaults cursor-file))) - (root (xlib:screen-root (xlib:display-default-screen display))) - (mask-pixmap (if mask-file (get-cursor-pixmap root mask-file)))) - (multiple-value-bind (cursor-pixmap cursor-x-hot cursor-y-hot) - (get-cursor-pixmap root cursor-file) - (setf *hemlock-cursor* - (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap - :x cursor-x-hot :y cursor-y-hot - :foreground *cursor-foreground-color* - :background *cursor-background-color*)) - (xlib:free-pixmap cursor-pixmap) - (when mask-pixmap (xlib:free-pixmap mask-pixmap))))) - -(defun get-cursor-pixmap (root pathname) - (let* ((image (xlib:read-bitmap-file pathname)) - (pixmap (xlib:create-pixmap :width 16 :height 16 - :depth 1 :drawable root)) - (gc (xlib:create-gcontext - :drawable pixmap :function boole-1 - :foreground *default-foreground-pixel* - :background *default-background-pixel*))) - (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16) - (xlib:free-gcontext gc) - (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image)))) - - -;;; Setting up grey borders ... -;;; - -(defparameter hemlock-grey-bitmap-data - '(#*10 #*01)) - -(defun get-hemlock-grey-pixmap (display) - (let* ((screen (xlib:display-default-screen display)) - (depth (xlib:screen-root-depth screen)) - (root (xlib:screen-root screen)) - (height (length hemlock-grey-bitmap-data)) - (width (length (car hemlock-grey-bitmap-data))) - (image (apply #'xlib:bitmap-image hemlock-grey-bitmap-data)) - (pixmap (xlib:create-pixmap :width width :height height - :depth depth :drawable root)) - (gc (xlib:create-gcontext :drawable pixmap - :function boole-1 - :foreground *default-foreground-pixel* - :background *default-background-pixel*))) - (xlib:put-image pixmap gc image - :x 0 :y 0 :width width :height height :bitmap-p t) - (xlib:free-gcontext gc) - pixmap)) - - -;;; Cut Buffer manipulation ... -;;; - -(defun store-cut-string (display string) - (check-type string simple-string) - (setf (xlib:cut-buffer display) string)) - -(defun fetch-cut-string (display) - (xlib:cut-buffer display)) - - -;;; Window naming ... -;;; -(defun set-window-name-for-buffer-name (buffer new-name) - (dolist (ele (buffer-windows buffer)) - (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk ele)) - :icon-name new-name))) - -(defun set-window-name-for-window-buffer (window new-buffer) - (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk window)) - :icon-name (buffer-name new-buffer))) - - - -;;;; Some hacks for supporting Hemlock under Mach. - -;;; WINDOWED-MONITOR-P is used by the reverse video variable's hook function -;;; to determine if it needs to go around fixing all the windows. -;;; -(defun windowed-monitor-p () - "This returns whether the monitor is being used with a window system. It - returns the console's CLX display structure." - *editor-windowed-input*) - -(defun get-terminal-name () - (cdr (assoc :term *environment-list* :test #'eq))) - -(defun get-termcap-env-var () - (cdr (assoc :termcap *environment-list* :test #'eq))) - - - -(defvar *editor-buffer* (make-string 256)) - -;;; GET-EDITOR-TTY-INPUT reads from stream's Unix file descriptor queuing events -;;; in the stream's queue. -;;; -(defun get-editor-tty-input (fd) - (let* ((buf *editor-buffer*) - (len (mach:unix-read fd buf 256)) - (i 0)) - (declare (simple-string buf) (fixnum len i)) - (loop - (when (>= i len) (return t)) - (q-event *real-editor-input* - (translate-tty-char (char-code (schar buf i)))) - (incf i)))) - -;;; This is used to get listening during smart redisplay to pick up input -;;; in between displaying each line by listening longer (or slowing down -;;; line output depending on your model). 10-20 seems to be good for 9600 -;;; baud, and 250 seems to do it with 1200 baud. -;;; -(defparameter listen-iterations-hack 1) ; 10-20 seems to really pick up input. - -(defun editor-tty-listen (stream) - (mach::with-trap-arg-block mach::int1 nc - (dotimes (i listen-iterations-hack nil) - (multiple-value-bind (val err) - (mach::Unix-ioctl (editor-tty-input-stream-fd stream) - mach::FIONREAD - (lisp::alien-value-sap - mach::int1)) - (declare (ignore err)) - (when (and val - (> (alien-access (mach::int1-int (alien-value nc))) 0)) - (return t)))))) - - - -(defvar old-flags) - -(defvar old-tchars) - -(defvar old-ltchars) - -(defun setup-input () - (let ((fd *editor-file-descriptor*)) - (when (mach:unix-isatty 0) - (mach:with-trap-arg-block mach:sgtty sg - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCGETP - (lisp::alien-value-sap mach:sgtty)) - (if (null val) - (error "Could not get tty information, unix error ~S." - (mach:get-unix-error-msg err))) - (let ((flags (alien-access (mach::sgtty-flags (alien-value sg))))) - (setq old-flags flags) - (setf (alien-access (mach::sgtty-flags (alien-value sg))) - (logand (logior flags mach::tty-cbreak) - (lognot mach::tty-echo) - (lognot mach::tty-crmod))) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSETP - (lisp::alien-value-sap mach:sgtty)) - (if (null val) - (error "Could not set tty information, unix error ~S." - (mach:get-unix-error-msg err))))))) - (mach:with-trap-arg-block mach:tchars tc - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCGETC - (lisp::alien-value-sap mach:tchars)) - (if (null val) - (error "Could not get tty tchars information, unix error ~S." - (mach:get-unix-error-msg err))) - (setq old-tchars - (vector (alien-access (mach::tchars-intrc (alien-value tc))) - (alien-access (mach::tchars-quitc (alien-value tc))) - (alien-access (mach::tchars-startc (alien-value tc))) - (alien-access (mach::tchars-stopc (alien-value tc))) - (alien-access (mach::tchars-eofc (alien-value tc))) - (alien-access (mach::tchars-brkc (alien-value tc)))))) - (setf (alien-access (mach::tchars-intrc (alien-value tc))) - (if *editor-windowed-input* -1 28)) - (setf (alien-access (mach::tchars-quitc (alien-value tc))) -1) - (setf (alien-access (mach::tchars-startc (alien-value tc))) -1) - (setf (alien-access (mach::tchars-stopc (alien-value tc))) -1) - (setf (alien-access (mach::tchars-eofc (alien-value tc))) -1) - (setf (alien-access (mach::tchars-brkc (alien-value tc))) -1) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSETC - (lisp::alien-value-sap mach:tchars)) - (if (null val) (error "Failed to set tchars, unix error ~S." - (mach:get-unix-error-msg err))))) - (mach:with-trap-arg-block mach:ltchars tc - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCGLTC - (lisp::alien-value-sap mach:ltchars)) - (if (null val) - (error "Could not get tty ltchars information, unix error ~S." - (mach:get-unix-error-msg err))) - (setq old-ltchars - (vector (alien-access (mach::ltchars-suspc (alien-value tc))) - (alien-access (mach::ltchars-dsuspc (alien-value tc))) - (alien-access (mach::ltchars-rprntc (alien-value tc))) - (alien-access (mach::ltchars-flushc (alien-value tc))) - (alien-access (mach::ltchars-werasc (alien-value tc))) - (alien-access (mach::ltchars-lnextc (alien-value tc)))))) - (setf (alien-access (mach::ltchars-suspc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-dsuspc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-rprntc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-flushc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-werasc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-lnextc (alien-value tc))) -1) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSLTC - (lisp::alien-value-sap mach:ltchars)) - (if (null val) (error "Failed to set ltchars, unix error ~S." - (mach:get-unix-error-msg err)))))))) - - -(defun reset-input () - (when (mach:unix-isatty 0) - (if (boundp 'old-flags) - (let ((fd *editor-file-descriptor*)) - (mach:with-trap-arg-block mach:sgtty sg - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCGETP - (lisp::alien-value-sap mach:sgtty)) - (if (null val) - (error "Could not get tty information, unix error ~S." - (mach:get-unix-error-msg err))) - (setf (alien-access (mach::sgtty-flags (alien-value sg))) - old-flags) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSETP - (lisp::alien-value-sap mach:sgtty)) - (if (null val) - (error "Could not set tty information, unix error ~S." - (mach:get-unix-error-msg err)))))) - (cond ((and (boundp 'old-tchars) - (simple-vector-p old-tchars) - (eq (length old-tchars) 6)) - (mach:with-trap-arg-block mach:tchars tc - (setf (alien-access (mach::tchars-intrc (alien-value tc))) - (svref old-tchars 0)) - (setf (alien-access (mach::tchars-quitc (alien-value tc))) - (svref old-tchars 1)) - (setf (alien-access (mach::tchars-startc (alien-value tc))) - (svref old-tchars 2)) - (setf (alien-access (mach::tchars-stopc (alien-value tc))) - (svref old-tchars 3)) - (setf (alien-access (mach::tchars-eofc (alien-value tc))) - (svref old-tchars 4)) - (setf (alien-access (mach::tchars-brkc (alien-value tc))) - (svref old-tchars 5)) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSETC - (lisp::alien-value-sap mach:tchars)) - (if (null val) - (error "Failed to set tchars, unix error ~S." - (mach:get-unix-error-msg err))))))) - (cond ((and (boundp 'old-ltchars) - (simple-vector-p old-ltchars) - (eq (length old-ltchars) 6)) - (mach:with-trap-arg-block mach:ltchars tc - (setf (alien-access (mach::ltchars-suspc (alien-value tc))) - (svref old-ltchars 0)) - (setf (alien-access (mach::ltchars-dsuspc (alien-value tc))) - (svref old-ltchars 1)) - (setf (alien-access (mach::ltchars-rprntc (alien-value tc))) - (svref old-ltchars 2)) - (setf (alien-access (mach::ltchars-flushc (alien-value tc))) - (svref old-ltchars 3)) - (setf (alien-access (mach::ltchars-werasc (alien-value tc))) - (svref old-ltchars 4)) - (setf (alien-access (mach::ltchars-lnextc (alien-value tc))) - (svref old-ltchars 5)) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSLTC - (lisp::alien-value-sap mach:ltchars)) - (if (null val) - (error "Failed to set ltchars, unix error ~S." - (mach:get-unix-error-msg err))))))))))) - - -(defun pause-hemlock () - "Pause hemlock and pop out to the Unix Shell." - (mach:unix-kill (mach:unix-getpid) mach:sigtstp) - T) diff --git a/hemlock/screen.lisp b/hemlock/screen.lisp deleted file mode 100644 index a82f122d0b4df965113e00976133a774e80d7ed4..0000000000000000000000000000000000000000 --- a/hemlock/screen.lisp +++ /dev/null @@ -1,188 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles. -;;; -;;; Device independent screen management functions. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(make-window delete-window next-window previous-window)) - - - -;;;; Screen management initialization. - -(proclaim '(special *echo-area-buffer*)) - -;;; %INIT-SCREEN-MANAGER creates the initial windows and sets up the data -;;; structures used by the screen manager. The "Main" and "Echo Area" buffer -;;; modelines are set here in case the user modified these Hemlock variables in -;;; his init file. Since these buffers don't have windows yet, these sets -;;; won't cause any updates to occur. This is called from %INIT-REDISPLAY. -;;; -(defun %init-screen-manager (display) - (setf (buffer-modeline-fields *current-buffer*) - (value ed::default-modeline-fields)) - (setf (buffer-modeline-fields *echo-area-buffer*) - (value ed::default-status-line-fields)) - (if (windowed-monitor-p) - (init-bitmap-screen-manager display) - (init-tty-screen-manager (get-terminal-name)))) - - - -;;;; Window operations. - -(defun make-window (start &key - (modelinep t) - (device nil) - window - (font-family *default-font-family*) - (ask-user nil) - x y - (width (value ed::default-window-width)) - (height (value ed::default-window-height))) - "Make a window that displays text starting at the mark Start. - - Modelinep specifies whether the window should display buffer modelines. - - Device is the Hemlock device to make the window on. If it is nil, then - the window is made on the same device as CURRENT-WINDOW. - - Window is an X window to be used for the Hemlock window. If not specified, - we make one by calling the function in *create-window-hook*. This hook maps - the window to the screen. - - Font-Family is the font-family used for displaying text in the window. - - If Ask-User is non-nil, the user is prompted for missing X, Y, Width, and - Height arguments. X and Y are supplied as pixels, but Width and Height are - supplied in characters. Otherwise, the current window's height is halved, - and the new window fills the created space. If halving the current window - results in too small of a window, then a new one is made the same size as - the current, offsetting its vertical placement on the screen some pixels." - - (let* ((device (or device (device-hunk-device (window-hunk (current-window))))) - (window (funcall (device-make-window device) - device start modelinep window font-family - ask-user x y width height))) - (unless window (editor-error "Could not make a window.")) - (invoke-hook ed::make-window-hook window) - window)) - -(defun delete-window (window) - "Make Window go away, removing it from the screen. Uses *delete-window-hook* - to get rid of bitmap window system windows." - (when (eq window *current-window*) - (error "Cannot kill the current window.")) - (invoke-hook ed::delete-window-hook window) - (setq *window-list* (delq window *window-list*)) - (funcall (device-delete-window (device-hunk-device (window-hunk window))) - window)) - -(defun next-window (window) - "Return the next window after Window, wrapping around if Window is the - bottom window." - (check-type window window) - (funcall (device-next-window (device-hunk-device (window-hunk window))) - window)) - -(defun previous-window (window) - "Return the previous window after Window, wrapping around if Window is the - top window." - (check-type window window) - (funcall (device-previous-window (device-hunk-device (window-hunk window))) - window)) - - - -;;;; Random typeout support. - -;;; PREPARE-FOR-RANDOM-TYPEOUT -- Internal -;;; -;;; The WITH-POP-UP-DISPLAY macro calls this just before displaying output -;;; for the user. This goes to some effor to compute the height of the window -;;; in text lines if it is not supplied. Whether it is supplied or not, we -;;; add one to the height for the modeline, and we subtract one line if the -;;; last line is empty. Just before using the height, make sure it is at -;;; least two -- one for the modeline and one for text, so window making -;;; primitives don't puke. -;;; -(defun prepare-for-random-typeout (stream height) - (let* ((buffer (line-buffer (mark-line (random-typeout-stream-mark stream)))) - (real-height (1+ (or height (rt-count-lines buffer)))) - (device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-random-typeout-setup device) device stream - (max (if (and (empty-line-p (buffer-end-mark buffer)) (not height)) - (1- real-height) - real-height) - 2)))) - -;;; RT-COUNT-LINES computes the correct height for a window. This includes -;;; taking wrapping line characters into account. Take the MARK-COLUMN at -;;; the end of each line. This is how many characters long hemlock thinks -;;; the line is. When it is displayed, however, end of line characters are -;;; added to the end of each line that wraps. The second INCF form adds -;;; these to the current line length. Then INCF the current height by the -;;; CEILING of the width of the random typeout window and the line length -;;; (with added line-end chars). Use CEILING because there is always at -;;; least one line. Finally, jump out of the loop if we're at the end of -;;; the buffer. -;;; -(defun rt-count-lines (buffer) - (with-mark ((mark (buffer-start-mark buffer))) - (let ((width (window-width (current-window))) - (count 0)) - (loop - (let* ((column (mark-column (line-end mark))) - (temp (ceiling (incf column (floor (1- column) width)) - width))) - ;; Lines with no characters yield zero temp. - (incf count (if (zerop temp) 1 temp)) - (unless (line-offset mark 1) (return count))))))) - - -;;; RANDOM-TYPEOUT-CLEANUP -- Internal -;;; -;;; Clean up after random typeout. This clears the area where the -;;; random typeout was and redisplays any affected windows. -;;; -(defun random-typeout-cleanup (stream &optional (degree t)) - (let* ((window (random-typeout-stream-window stream)) - (buffer (window-buffer window)) - (device (device-hunk-device (window-hunk window))) - (*more-prompt-action* :normal)) - (update-modeline-field buffer window :more-prompt) - (random-typeout-redisplay window) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) - (funcall (device-random-typeout-cleanup device) stream degree) - (when (device-force-output device) - (funcall (device-force-output device))))) - -;;; *more-prompt-action* is bound in random typeout streams before -;;; redisplaying. -;;; -(defvar *more-prompt-action* :normal) -(defvar *random-typeout-ml-fields* - (list (make-modeline-field - :name :more-prompt - :function #'(lambda (buffer window) - (declare (ignore buffer window)) - (ecase *more-prompt-action* - (:more "--More--") - (:flush "--Flush--") - (:empty "") - (:normal - (concatenate 'simple-string - "Random Typeout Buffer [" - (buffer-name buffer) - "]"))))))) diff --git a/hemlock/scribe.lisp b/hemlock/scribe.lisp deleted file mode 100644 index fdca55675179108679877811f7017fc3f6a1372b..0000000000000000000000000000000000000000 --- a/hemlock/scribe.lisp +++ /dev/null @@ -1,434 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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 'hemlock) - - - -;;;; Variables. - -(defvar *scribe-para-break-table* (make-hash-table :test #'equal) - "A table of the Scribe commands that should be paragraph delimiters.") -;;; -(dolist (todo '("begin" "newpage" "make" "device" "caption" "tag" "end" - "chapter" "section" "appendix" "subsection" "paragraph" - "unnumbered" "appendixsection" "prefacesection" "heading" - "majorheading" "subheading")) - (setf (gethash todo *scribe-para-break-table*) t)) - -(defhvar "Open Paren Character" - "The open bracket inserted by Scribe commands." - :value #\[) - -(defhvar "Close Paren Character" - "The close bracket inserted by Scribe commands." - :value #\]) - -(defhvar "Escape Character" - "The escape character inserted by Scribe commands." - :value #\@) - -(defhvar "Scribe Bracket Table" - "This table maps a Scribe brackets, open and close, to their opposing - brackets." - :value (make-array char-code-limit)) -;;; -(mapc #'(lambda (x y) - (setf (svref (value scribe-bracket-table) (char-code x)) y) - (setf (svref (value scribe-bracket-table) (char-code y)) x)) - '(#\( #\[ #\{ #\<) '(#\) #\] #\} #\>)) -;;; -(eval-when (compile eval) - (defmacro opposing-bracket (bracket) - `(svref (value scribe-bracket-table) (char-code ,bracket))) -) ;eval-when - - - -;;;; "Scribe Syntax" Attribute. - -(defattribute "Scribe Syntax" - "For Scribe Syntax, Possible types are: - :ESCAPE ; basically #\@. - :OPEN-PAREN ; Characters that open a Scribe paren: #\[, #\{, #\(, #\<. - :CLOSE-PAREN ; Characters that close a Scribe paren: #\], #\}, #\), #\>. - :SPACE ; Delimits end of a Scribe command. - :NEWLINE ; Delimits end of a Scribe command." - 'symbol nil) - -(setf (character-attribute :SCRIBE-SYNTAX #\)) :CLOSE-PAREN) -(setf (character-attribute :SCRIBE-SYNTAX #\]) :CLOSE-PAREN) -(setf (character-attribute :SCRIBE-SYNTAX #\}) :CLOSE-PAREN) -(setf (character-attribute :SCRIBE-SYNTAX #\>) :CLOSE-PAREN) - -(setf (character-attribute :SCRIBE-SYNTAX #\() :OPEN-PAREN) -(setf (character-attribute :SCRIBE-SYNTAX #\[) :OPEN-PAREN) -(setf (character-attribute :SCRIBE-SYNTAX #\{) :OPEN-PAREN) -(setf (character-attribute :SCRIBE-SYNTAX #\<) :OPEN-PAREN) - -(setf (character-attribute :SCRIBE-SYNTAX #\Space) :SPACE) -(setf (character-attribute :SCRIBE-SYNTAX #\Newline) :NEWLINE) -(setf (character-attribute :SCRIBE-SYNTAX #\@) :ESCAPE) - - - -;;;; "Scribe" mode and setup. - -(defmode "Scribe" :major-p t) - -(shadow-attribute :paragraph-delimiter #\@ 1 "Scribe") -(shadow-attribute :word-delimiter #\' 0 "Scribe") ;from Text Mode -(shadow-attribute :word-delimiter #\backspace 0 "Scribe") ;from Text Mode -(shadow-attribute :word-delimiter #\_ 0 "Scribe") ;from Text Mode - -(define-file-type-hook ("mss") (buffer type) - (declare (ignore type)) - (setf (buffer-major-mode buffer) "Scribe")) - - - -;;;; Commands. - -(defcommand "Scribe Mode" (p) - "Puts buffer in Scribe mode. Sets up comment variables and has delimiter - matching. The definition of paragraphs is changed to know about scribe - commands." - "Puts buffer in Scribe mode." - (declare (ignore p)) - (setf (buffer-major-mode (current-buffer)) "Scribe")) - -(defcommand "Select Scribe Warnings" (p) - "Goes to the Scribe Warnings buffer if it exists." - "Goes to the Scribe Warnings buffer if it exists." - (declare (ignore p)) - (let ((buffer (getstring "Scribe Warnings" *buffer-names*))) - (if buffer - (change-to-buffer buffer) - (editor-error "There is no Scribe Warnings buffer.")))) - -(defcommand "Add Scribe Paragraph Delimiter" - (p &optional - (word (prompt-for-string - :prompt "Scribe command: " - :help "Name of Scribe command to make delimit paragraphs." - :trim t))) - "Prompts for a name to add to the table of commands that delimit paragraphs - in Scribe mode. If a prefix argument is supplied, then the command name is - removed from the table." - "Add or remove Word in the *scribe-para-break-table*, depending on P." - (setf (gethash word *scribe-para-break-table*) (not p))) - -(defcommand "List Scribe Paragraph Delimiters" (p) - "Pops up a display of the Scribe commands that delimit paragraphs." - "Pops up a display of the Scribe commands that delimit paragraphs." - (declare (ignore p)) - (let (result) - (maphash #'(lambda (k v) - (declare (ignore v)) - (push k result)) - *scribe-para-break-table*) - (setf result (sort result #'string<)) - (with-pop-up-display (s :height (length result)) - (dolist (ele result) (write-line ele s))))) - -(defcommand "Scribe Insert Bracket" (p) - "Inserts a the bracket it is bound to and then shows the matching bracket." - "Inserts a the bracket it is bound to and then shows the matching bracket." - (declare (ignore p)) - (scribe-insert-paren (current-point) *last-character-typed*)) - - -(defhvar "Scribe Command Table" - "This is a character dispatching table indicating which Scribe command or - environment to use." - :value (make-hash-table) - :mode "Scribe") - -(defvar *scribe-directive-type-table* - (make-string-table :initial-contents - '(("Command" . :command) - ("Environment" . :environment)))) - -(defcommand "Add Scribe Directive" (p &optional - (command-name nil command-name-p) - type key (mode "Scribe")) - "Adds a new scribe function to put into \"Scribe Command Table\"." - "Adds a new scribe function to put into \"Scribe Command Table\"." - (declare (ignore p)) - (let ((command-name (if command-name-p - command-name - (or command-name - (prompt-for-string :help "Directive Name" - :prompt "Directive: "))))) - (multiple-value-bind (ignore type) - (if type - (values nil type) - (prompt-for-keyword - (list *scribe-directive-type-table*) - :help "Enter Command or Environment." - :prompt "Command or Environment: ")) - (declare (ignore ignore)) - (let ((key (or key - (prompt-for-character :prompt "Dispatch Character: ")))) - (setf (gethash key (variable-value 'scribe-command-table :mode mode)) - (cons type command-name)))))) - -(defcommand "Insert Scribe Directive" (p) - "Prompts for a character to dispatch on. Some indicate \"commands\" versus - \"environments\". Commands are wrapped around the previous or current word. - If there is no previous word, the command is insert, leaving point between - the brackets. Environments are wrapped around the next or current - paragraph, but when the region is active, this wraps the environment around - the region. Each uses \"Open Paren Character\" and \"Close Paren - Character\"." - "Wrap some text with some stuff." - (declare (ignore p)) - (command-case (:bind key :prompt "Dispatch Character: ") - (:help "help" - (directive-help) - (reprompt)) - (t (let ((table-entry (gethash key (value scribe-command-table)))) - (if (eq (car table-entry) :command) - (insert-scribe-directive (current-point) (cdr table-entry)) - (enclose-with-environment (current-point) (cdr table-entry))))))) - - - -;;;; "Insert Scribe Directive" support. - -(defun directive-help () - (let ((commands ()) - (environments ())) - (declare (list commands environments)) - (maphash #'(lambda (k v) - (if (eql (car v) :command) - (push (cons k (cdr v)) commands) - (push (cons k (cdr v)) environments))) - (variable-value 'Scribe-Command-Table :mode "Scribe")) - (setq commands (sort commands #'string< :key #'cdr)) - (setq environments (sort environments #'string< :key #'cdr)) - (with-pop-up-display (s :height (1+ (max (length commands) - (length environments)))) - (format s "~2TCommands~47TEnvironments~%") - (do ((commands commands (rest commands)) - (environments environments (rest environments))) - ((and (endp commands) (endp environments))) - (let* ((command (first commands)) - (environment (first environments)) - (cmd-char (first command)) - (cmd-name (rest command)) - (env-char (first environment)) - (env-name (rest environment))) - (write-string " " s) - (when cmd-char - (print-pretty-character cmd-char s) - (format s "~7T") - (write-string (or cmd-name "<prompts for command name>") s)) - (when env-char - (format s "~47T") - (print-pretty-character env-char s) - (format s "~51T") - (write-string (or env-name "<prompts for command name>") s)) - (terpri s)))))) - -;;; INSERT-SCRIBE-DIRECTIVE first looks for the current or previous word at -;;; mark. Word-p says if we found one. If mark is immediately before a word, -;;; we use that word instead of the previous. This is because if mark -;;; corresponds to the CURRENT-POINT, the Hemlock cursor is displayed on the -;;; first character of the word making users think the mark is in the word -;;; instead of before it. If we find a word, then we see if it already has -;;; the given command-string, and if it does, we extend the use of the command- -;;; string to the previous word. At the end, if we hadn't found a word, we -;;; backup the mark one character to put it between the command brackets. -;;; -(defun insert-scribe-directive (mark &optional command-string) - (with-mark ((word-start mark :left-inserting) - (word-end mark :left-inserting)) - (let ((open-paren-char (value open-paren-character)) - (word-p (if (and (zerop (character-attribute - :word-delimiter - (next-character word-start))) - (= (character-attribute - :word-delimiter - (previous-character word-start)) - 1)) - word-start - (word-offset word-start -1))) - (command-string (or command-string - (prompt-for-string - :trim t :prompt "Environment: " - :help "Name of environment to enclose with.")))) - (declare (simple-string command-string)) - (when word-p - (word-offset (move-mark word-end word-start) 1) - (when (test-char (next-character word-end) :scribe-syntax - :close-paren) - (with-mark ((command-start word-start) - (command-end word-end)) - (balance-paren (mark-after command-end)) - (word-offset (move-mark command-start command-end) -1) - (when (string= (the simple-string - (region-to-string (region command-start - command-end))) - command-string) - (mark-before command-start) - (mark-after command-end) - (setf open-paren-char - (opposing-bracket (next-character word-end))) - (delete-region (region command-start command-end)) - (delete-characters word-end) - (word-offset (move-mark word-start command-start) -1))))) - (insert-character word-start (value escape-character)) - (insert-string word-start command-string) - (insert-character word-start open-paren-char) - (insert-character word-end (value close-paren-character)) - (unless word-p (mark-before mark))))) - -(defun enclose-with-environment (mark &optional environment) - (if (region-active-p) - (let ((region (current-region))) - (with-mark ((top (region-start region) :left-inserting) - (bottom (region-end region) :left-inserting)) - (get-and-insert-environment top bottom environment))) - (with-mark ((bottom-mark mark :left-inserting)) - (let ((paragraphp (paragraph-offset bottom-mark 1))) - (unless (or paragraphp - (and (last-line-p bottom-mark) - (end-line-p bottom-mark) - (not (blank-line-p (mark-line bottom-mark))))) - (editor-error "No paragraph to enclose.")) - (with-mark ((top-mark bottom-mark :left-inserting)) - (paragraph-offset top-mark -1) - (cond ((not (blank-line-p (mark-line top-mark))) - (insert-character top-mark #\Newline) - (mark-before top-mark)) - (t - (insert-character top-mark #\Newline))) - (cond ((and (last-line-p bottom-mark) - (not (blank-line-p (mark-line bottom-mark)))) - (insert-character bottom-mark #\Newline)) - (t - (insert-character bottom-mark #\Newline) - (mark-before bottom-mark))) - (get-and-insert-environment top-mark bottom-mark environment)))))) - -(defun get-and-insert-environment (top-mark bottom-mark environment) - (let ((environment (or environment - (prompt-for-string - :trim t :prompt "Environment: " - :help "Name of environment to enclose with.")))) - (insert-environment top-mark "Begin" environment) - (insert-environment bottom-mark "End" environment))) - -(defun insert-environment (mark command environment) - (let ((esc-char (value escape-character)) - (open-paren (value open-paren-character)) - (close-paren (value close-paren-character))) - (insert-character mark esc-char) - (insert-string mark command) - (insert-character mark open-paren) - (insert-string mark environment) - (insert-character mark close-paren))) - - -(Add-Scribe-Directive-Command nil nil :Environment #\Control-\l) -(Add-Scribe-Directive-Command nil nil :Command #\Control-\w) -(Add-Scribe-Directive-Command nil "Begin" :Command #\b) -(Add-Scribe-Directive-Command nil "End" :Command #\e) -(Add-Scribe-Directive-Command nil "Center" :Environment #\c) -(Add-Scribe-Directive-Command nil "Description" :Environment #\d) -(Add-Scribe-Directive-Command nil "Display" :Environment #\Control-\d) -(Add-Scribe-Directive-Command nil "Enumerate" :Environment #\n) -(Add-Scribe-Directive-Command nil "Example" :Environment #\x) -(Add-Scribe-Directive-Command nil "FileExample" :Environment #\y) -(Add-Scribe-Directive-Command nil "FlushLeft" :Environment #\l) -(Add-Scribe-Directive-Command nil "FlushRight" :Environment #\r) -(Add-Scribe-Directive-Command nil "Format" :Environment #\f) -(Add-Scribe-Directive-Command nil "Group" :Environment #\g) -(Add-Scribe-Directive-Command nil "Itemize" :Environment #\Control-\i) -(Add-Scribe-Directive-Command nil "Multiple" :Environment #\m) -(Add-Scribe-Directive-Command nil "ProgramExample" :Environment #\p) -(Add-Scribe-Directive-Command nil "Quotation" :Environment #\q) -(Add-Scribe-Directive-Command nil "Text" :Environment #\t) -(Add-Scribe-Directive-Command nil "i" :Command #\i) -(Add-Scribe-Directive-Command nil "b" :Command #\Control-\b) -(Add-Scribe-Directive-Command nil "-" :Command #\-) -(Add-Scribe-Directive-Command nil "+" :Command #\+) -(Add-Scribe-Directive-Command nil "u" :Command #\Control-\j) -(Add-Scribe-Directive-Command nil "p" :Command #\Control-\p) -(Add-Scribe-Directive-Command nil "r" :Command #\Control-\r) -(Add-Scribe-Directive-Command nil "t" :Command #\Control-\t) -(Add-Scribe-Directive-Command nil "g" :Command #\Control-\a) -(Add-Scribe-Directive-Command nil "un" :Command #\Control-\n) -(Add-Scribe-Directive-Command nil "ux" :Command #\Control-\x) -(Add-Scribe-Directive-Command nil "c" :Command #\Control-\k) - - - -;;;; Scribe paragraph delimiter function. - -(defhvar "Paragraph Delimiter Function" - "Scribe Mode's way of delimiting paragraphs." - :mode "Scribe" - :value 'scribe-delim-para-function) - -(defun scribe-delim-para-function (mark) - "Returns whether there is a paragraph delimiting Scribe command on the - current line. Add or remove commands for this purpose with the command - \"Add Scribe Paragraph Delimiter\"." - (let ((next-char (next-character mark))) - (when (paragraph-delimiter-attribute-p next-char) - (if (eq (character-attribute :scribe-syntax next-char) :escape) - (with-mark ((begin mark) - (end mark)) - (mark-after begin) - (if (scan-char end :scribe-syntax (or :space :newline :open-paren)) - (gethash (nstring-downcase (region-to-string (region begin end))) - *scribe-para-break-table*) - (editor-error "Unable to find Scribe command ending."))) - t)))) - - - -;;;; Bracket matching. - -(defun scribe-insert-paren (mark bracket-char) - (insert-character mark bracket-char) - (with-mark ((m mark)) - (if (balance-paren m) - (when (value paren-pause-period) - (unless (show-mark m (current-window) (value paren-pause-period)) - (clear-echo-area) - (message "~A" (line-string (mark-line m))))) - (editor-error)))) - -;;; BALANCE-PAREN moves the mark to the matching open paren character, or -;;; returns nil. The mark must be after the closing paren. -;;; -(defun balance-paren (mark) - (with-mark ((m mark)) - (when (rev-scan-char m :scribe-syntax (or :open-paren :close-paren)) - (mark-before m) - (let ((paren-count 1) - (first-paren (next-character m))) - (loop - (unless (rev-scan-char m :scribe-syntax (or :open-paren :close-paren)) - (return nil)) - (if (test-char (previous-character m) :scribe-syntax :open-paren) - (setq paren-count (1- paren-count)) - (setq paren-count (1+ paren-count))) - (when (< paren-count 0) (return nil)) - (when (= paren-count 0) - ;; OPPOSING-BRACKET calls VALUE (each time around the loop) - (cond ((char= (opposing-bracket (previous-character m)) first-paren) - (mark-before (move-mark mark m)) - (return t)) - (t (editor-error "Scribe paren mismatch.")))) - (mark-before m)))))) diff --git a/hemlock/search1.lisp b/hemlock/search1.lisp deleted file mode 100644 index 0fe8d11aab0220eb8bd08c085aab4d8f91d71dc0..0000000000000000000000000000000000000000 --- a/hemlock/search1.lisp +++ /dev/null @@ -1,649 +0,0 @@ -;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Searching and replacing functions for Hemlock. -;;; Originally written by Skef Wholey, Rewritten by Rob MacLachlan. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(search-pattern search-pattern-p find-pattern replace-pattern - new-search-pattern)) - - - -;;; The search pattern structure is used only by simple searches, more -;;; complex ones make structures which include it. - -(defstruct (search-pattern (:print-function %print-search-pattern) - (:constructor internal-make-search-pattern)) - kind ; The kind of pattern to search for. - direction ; The direction to search in. - pattern ; The search pattern to use. - search-function ; The function to call to search. - reclaim-function) ; The function to call to reclaim this pattern. - -(setf (documentation 'search-pattern-p 'function) - "Returns true if its argument is a Hemlock search-pattern object, - Nil otherwise.") - -(defun %print-search-pattern (object stream depth) - (let ((*print-level* (and *print-level* (- *print-level* depth))) - (*print-case* :downcase)) - (declare (special *print-level* *print-case*)) - (write-string "#<Hemlock " stream) - (princ (search-pattern-direction object) stream) - (write-char #\space stream) - (princ (search-pattern-kind object) stream) - (write-string " Search-Pattern for ") - (prin1 (search-pattern-pattern object) stream) - (write-char #\> stream) - (terpri stream))) - -(defvar *search-pattern-experts* (make-hash-table :test #'eq) - "Holds an eq hashtable which associates search kinds with the functions - that know how to make patterns of that kind.") -(defvar *search-pattern-documentation* () - "A list of all the kinds of search-pattern that are defined.") - -;;; define-search-kind -- Internal -;;; -;;; This macro is used to define a new kind of search pattern. Kind -;;; is the kind of search pattern to define. Lambda-list is the argument -;;; list for the expert-function to be built and forms it's body. -;;; The arguments passed are the direction, the pattern, and either -;;; an old search-pattern of the same type or nil. Documentation -;;; is put on the search-pattern-documentation property of the kind -;;; keyword. -;;; -(eval-when (compile eval) -(defmacro define-search-kind (kind lambda-list documentation &body forms) - (let ((dummy (gensym))) - `(progn - (push ,documentation *search-pattern-documentation*) - (defun ,dummy () - (setf (gethash ,kind *search-pattern-experts*) - #'(lambda ,lambda-list ,@forms))) - (,dummy)))) -); eval-when (compile eval) - -;;; new-search-pattern -- Public -;;; -;;; This function deallocates any old search-pattern and then dispatches -;;; to the correct expert. -;;; -(defun new-search-pattern (kind direction pattern &optional - result-search-pattern) - "Makes a new Hemlock search pattern of kind Kind to search direction - using Pattern. Direction is either :backward or :forward. - If supplied, result-search-pattern is a pattern to destroy to make - the new one. The variable *search-pattern-documentation* contains - documentation for each kind." - (unless (or (eq direction :forward) (eq direction :backward)) - (error "~S is not a legal search direction." direction)) - (when result-search-pattern - (funcall (search-pattern-reclaim-function result-search-pattern) - result-search-pattern) - (unless (eq kind (search-pattern-kind result-search-pattern)) - (setq result-search-pattern nil))) - (let ((expert (gethash kind *search-pattern-experts*))) - (unless expert - (error "~S is not a defined search pattern kind." kind)) - (funcall expert direction pattern result-search-pattern))) - -;;;; stuff to allocate and de-allocate simple-vectors search-char-code-limit -;;;; in length. - -(defvar *spare-search-vectors* ()) -(eval-when (compile eval) -(defmacro new-search-vector () - `(if *spare-search-vectors* - (pop *spare-search-vectors*) - (make-array search-char-code-limit))) - -(defmacro dispose-search-vector (vec) - `(push ,vec *spare-search-vectors*)) -); eval-when (compile eval) - -;;;; macros used by various search kinds: - -;;; search-once-forward-macro -- Internal -;;; -;;; Passes search-fun strings, starts and lengths to do a forward -;;; search. The other-args are passed through to the searching -;;; function after after everything else The search-fun is -;;; expected to return NIL if nothing is found, or it index where the -;;; match ocurred. Something non-nil is returned if something is -;;; found and line and start are set to where it was found. -;;; -(eval-when (compile eval) -(defmacro search-once-forward-macro (line start search-fun &rest other-args) - `(do* ((l ,line) - (chars (line-chars l) (line-chars l)) - (len (length chars) (length chars)) - (start-pos ,start 0) index) - (()) - (declare (simple-string chars) (fixnum index start-pos len)) - (setq index (,search-fun chars start-pos len ,@other-args)) - (when index - (setq ,start index ,line l) - (return t)) - (setq l (line-next l)) - (when (null l) (return nil)))) - - -;;; search-once-backward-macro -- Internal -;;; -;;; Like search-once-forward-macro, except it goes backwards. Length -;;; is not passed to the search function, since it won't need it. -;;; -(defmacro search-once-backward-macro (line start search-fun &rest other-args) - `(do* ((l ,line) - (chars (line-chars l) (line-chars l)) - (start-pos (1- ,start) (1- (length chars))) index) - (()) - (declare (simple-string chars) (fixnum index start-pos)) - (setq index (,search-fun chars start-pos ,@other-args)) - (when index - (setq ,start index ,line l) - (return t)) - (setq l (line-previous l)) - (when (null l) (return nil)))) -); eval-when (compile eval) - -;;;; String Searches. -;;; -;;; We use the Boyer-Moore algorithm for string searches. -;;; - -;;; sensitive-string-search-macro -- Internal -;;; -;;; This macro does a case-sensitive Boyer-Moore string search. -;;; -;;; Args: -;;; String - The string to search in. -;;; Start - The place to start searching at. -;;; Length - NIL if going backward, the length of String if going forward. -;;; Pattern - A simple-vector of characters. A simple-vector is used -;;; rather than a string because it is believed that simple-vector access -;;; will be faster in most implementations. -;;; Patlen - The length of Pattern. -;;; Last - (1- Patlen) -;;; Jumps - The jump vector as given by compute-boyer-moore-jumps -;;; +/- - The function to increment with, either + (forward) or - -;;; (backward) -;;; -/+ - Like +/-, only the other way around. -(eval-when (compile eval) -(defmacro sensitive-string-search-macro (string start length pattern patlen - last jumps +/- -/+) - `(do ((scan (,+/- ,start ,last)) - (patp ,last)) - (,(if length `(>= scan ,length) '(minusp scan))) - (declare (fixnum scan patp)) - (let ((char (schar ,string scan))) - (cond - ((char= char (svref ,pattern patp)) - (if (zerop patp) - (return scan) - (setq scan (,-/+ scan 1) patp (1- patp)))) - (t - ;; If mismatch consult jump table to find amount to skip. - (let ((jump (svref ,jumps (search-char-code char)))) - (declare (fixnum jump)) - (if (> jump (- ,patlen patp)) - (setq scan (,+/- scan jump)) - (setq scan (,+/- scan (- ,patlen patp))))) - (setq patp ,last)))))) - -;;; insensitive-string-search-macro -- Internal -;;; -;;; This macro is very similar to the case sensitive one, except that -;;; we do the search for a hashed string, and then when we find a match -;;; we compare the uppercased search string with the found string uppercased -;;; and only say we win when they match too. -;;; -(defmacro insensitive-string-search-macro (string start length pattern - folded-string patlen last - jumps +/- -/+) - `(do ((scan (,+/- ,start ,last)) - (patp ,last)) - (,(if length `(>= scan ,length) '(minusp scan))) - (declare (fixnum scan patp)) - (let ((hash (search-hash-code (schar ,string scan)))) - (declare (fixnum hash)) - (cond - ((= hash (the fixnum (svref ,pattern patp))) - (if (zerop patp) - (if (do ((i ,last (1- i))) - (()) - (when (char/= - (search-char-upcase (schar ,string (,+/- scan i))) - (schar ,folded-string i)) - (return nil)) - (when (zerop i) (return t))) - (return scan) - (setq scan (,+/- scan ,patlen) patp ,last)) - (setq scan (,-/+ scan 1) patp (1- patp)))) - (t - ;; If mismatch consult jump table to find amount to skip. - (let ((jump (svref ,jumps hash))) - (declare (fixnum jump)) - (if (> jump (- ,patlen patp)) - (setq scan (,+/- scan jump)) - (setq scan (,+/- scan (- ,patlen patp))))) - (setq patp ,last)))))) - -;;;; Searching for strings with newlines in them: -;;; -;;; Due to the buffer representation, search-strings with embedded -;;; newlines need to be special-cased. What we do is break -;;; the search string up into lines and then searching for a line with -;;; the correct prefix. This is actually a faster search. -;;; For this one we just have one big hairy macro conditionalized for -;;; both case-sensitivity and direction. Have fun!! - -;;; newline-search-macro -- Internal -;;; -;;; Do a search for a string containing newlines. Line is the line -;;; to start on, and Start is the position to start at. Pattern and -;;; optionally Pattern2, are simple-vectors of things that represent -;;; each line in the pattern, and are passed to Test-Fun. Pattern -;;; must contain simple-strings so we can take the length. Test-Fun is a -;;; thing to compare two strings and see if they are equal. Forward-p -;;; tells whether to go forward or backward. -;;; -(defmacro newline-search-macro (line start test-fun pattern forward-p - &optional pattern2) - `(let* ((patlen (length ,pattern)) - (first (svref ,pattern 0)) - (firstlen (length first)) - (l ,line) - (chars (line-chars l)) - (len (length chars)) - ,@(if pattern2 `((other (svref ,pattern2 0))))) - (declare (simple-string first chars) (fixnum firstlen patlen len)) - ,(if forward-p - ;; If doing a forward search, go to the next line if we could not - ;; match due to the start position. - `(when (< (- len ,start) firstlen) - (setq l (line-next l))) - ;; If doing a backward search, go to the previous line if the current - ;; line could not match the last line in the pattern, and then go - ;; back the 1- number of lines in the pattern to avoid a possible - ;; match across the starting point. - `(let ((1-len (1- patlen))) - (declare (fixnum 1-len)) - (when (< ,start (length (the simple-string - (svref ,pattern 1-len)))) - (setq l (line-previous l))) - (dotimes (i 1-len) - (when (null l) (return nil)) - (setq l (line-previous l))))) - (do* () - ((null l)) - (setq chars (line-chars l) len (length chars)) - ;; If the end of this line is the first line in the pattern then check - ;; to see if the other lines match. - (when (and (>= len firstlen) - (,test-fun chars first other - :start1 (- len firstlen) :end1 len - :end2 firstlen)) - (when - (do ((m (line-next l) (line-next m)) - (i 2 (1+ i)) - (next (svref ,pattern 1) (svref ,pattern i)) - ,@(if pattern2 - `((another (svref ,pattern2 1) - (svref ,pattern2 i)))) - len chars nextlen) - ((null m)) - (declare (simple-string next chars) (fixnum len nextlen i)) - (setq chars (line-chars m) nextlen (length next) - len (length chars)) - ;; When on last line of pattern, check if prefix of line. - (when (= i patlen) - (return (and (>= len nextlen) - (,test-fun chars next another :end1 nextlen - :end2 nextlen)))) - (unless (,test-fun chars next another :end1 len - :end2 nextlen) - (return nil))) - (setq ,line l ,start (- len firstlen)) - (return t))) - ;; If not, try the next line - (setq l ,(if forward-p '(line-next l) '(line-previous l)))))) - -;;;; String-comparison macros that are passed to newline-search-macro - -;;; case-sensitive-test-fun -- Internal -;;; -;;; Just thows away the extra arg and calls string=. -;;; -(defmacro case-sensitive-test-fun (string1 string2 ignore &rest keys) - `(string= ,string1 ,string2 ,@keys)) - -;;; case-insensitive-test-fun -- Internal -;;; -;;; First compare the characters hashed with hashed-string2 and then -;;; only if they agree do an actual compare with case-folding. -;;; -(defmacro case-insensitive-test-fun (string1 string2 hashed-string2 - &key end1 (start1 0) end2) - `(when (= (- ,end1 ,start1) ,end2) - (do ((i 0 (1+ i))) - ((= i ,end2) - (dotimes (i ,end2 t) - (when (char/= (search-char-upcase (schar ,string1 (+ ,start1 i))) - (schar ,string2 i)) - (return nil)))) - (when (/= (search-hash-code (schar ,string1 (+ ,start1 i))) - (svref ,hashed-string2 i)) - (return nil))))) -); eval-when (compile eval) - -;;; compute-boyer-moore-jumps -- Internal -;;; -;;; Compute return a jump-vector to do a Boyer-Moore search for -;;; the "string" of things in Vector. Access-fun is a function -;;; that aref's vector and returns a number. -;;; -(defun compute-boyer-moore-jumps (vec access-fun) - (declare (simple-vector vec)) - (let ((jumps (new-search-vector)) - (len (length vec))) - (declare (simple-vector jumps)) - (when (zerop len) (error "Zero length search string not allowed.")) - ;; The default jump is the length of the search string. - (dotimes (i search-char-code-limit) - (setf (aref jumps i) len)) - ;; For chars in the string the jump is the distance from the end. - (dotimes (i len) - (setf (aref jumps (funcall access-fun vec i)) (- len i 1))) - jumps)) - -;;;; Case insensitive searches - -;;; In order to avoid case folding, we do a case-insensitive hash of -;;; each character. We then search for string in this translated -;;; character set, and reject false successes by checking of the found -;;; string is string-equal the the original search string. -;;; - -(defstruct (string-insensitive-search-pattern - (:include search-pattern) - (:conc-name string-insensitive-) - (:print-function %print-search-pattern)) - jumps - hashed-string - folded-string) - -;;; Search-Hash-String -- Internal -;;; -;;; Return a simple-vector containing the search-hash-codes of the -;;; characters in String. -;;; -(defun search-hash-string (string) - (declare (simple-string string)) - (let* ((len (length string)) - (result (make-array len))) - (declare (fixnum len) (simple-vector result)) - (dotimes (i len result) - (setf (aref result i) (search-hash-code (schar string i)))))) - -;;; make-insensitive-newline-pattern -- Internal -;;; -;;; Make bash in fields in a string-insensitive-search-pattern to -;;; do a search for a string with newlines in it. -;;; -(defun make-insensitive-newline-pattern (pattern folded-string) - (declare (simple-string folded-string)) - (let* ((len (length folded-string)) - (num (1+ (count #\newline folded-string :end len))) - (hashed (make-array num)) - (folded (make-array num))) - (declare (simple-vector hashed folded) (fixnum len num)) - (do ((prev 0 nl) - (i 0 (1+ i)) - (nl (position #\newline folded-string :end len) - (position #\newline folded-string :start nl :end len))) - ((null nl) - (let ((piece (subseq folded-string prev len))) - (setf (aref folded i) piece) - (setf (aref hashed i) (search-hash-string piece)))) - (let ((piece (subseq folded-string prev nl))) - (setf (aref folded i) piece) - (setf (aref hashed i) (search-hash-string piece))) - (incf nl)) - (setf (string-insensitive-folded-string pattern) folded - (string-insensitive-hashed-string pattern) hashed))) - -(define-search-kind :string-insensitive (direction pattern old) - ":string-insensitive - Pattern is a string to do a case-insensitive - search for." - (unless old (setq old (make-string-insensitive-search-pattern))) - (setf (search-pattern-kind old) :string-insensitive - (search-pattern-direction old) direction - (search-pattern-pattern old) pattern) - (let* ((folded-string (string-upcase pattern))) - (declare (simple-string folded-string)) - (cond - ((find #\newline folded-string) - (make-insensitive-newline-pattern old folded-string) - (setf (search-pattern-search-function old) - (if (eq direction :forward) - #'insensitive-find-newline-once-forward-method - #'insensitive-find-newline-once-backward-method)) - (setf (search-pattern-reclaim-function old) #'identity)) - (t - (case direction - (:forward - (setf (search-pattern-search-function old) - #'insensitive-find-string-once-forward-method)) - (t - (setf (search-pattern-search-function old) - #'insensitive-find-string-once-backward-method) - (nreverse folded-string))) - (let ((hashed-string (search-hash-string folded-string))) - (setf (string-insensitive-hashed-string old) hashed-string - (string-insensitive-folded-string old) folded-string) - (setf (string-insensitive-jumps old) - (compute-boyer-moore-jumps hashed-string #'svref)) - (setf (search-pattern-reclaim-function old) - #'(lambda (p) - (dispose-search-vector (string-insensitive-jumps p)))))))) - old) - -(defun insensitive-find-string-once-forward-method (pattern line start) - (let* ((hashed-string (string-insensitive-hashed-string pattern)) - (folded-string (string-insensitive-folded-string pattern)) - (jumps (string-insensitive-jumps pattern)) - (patlen (length hashed-string)) - (last (1- patlen))) - (declare (simple-vector jumps hashed-string) (simple-string folded-string) - (fixnum patlen last)) - (when (search-once-forward-macro - line start insensitive-string-search-macro - hashed-string folded-string patlen last jumps + -) - (values line start patlen)))) - -(defun insensitive-find-string-once-backward-method (pattern line start) - (let* ((hashed-string (string-insensitive-hashed-string pattern)) - (folded-string (string-insensitive-folded-string pattern)) - (jumps (string-insensitive-jumps pattern)) - (patlen (length hashed-string)) - (last (1- patlen))) - (declare (simple-vector jumps hashed-string) (simple-string folded-string) - (fixnum patlen last)) - (when (search-once-backward-macro - line start insensitive-string-search-macro - nil hashed-string folded-string patlen last jumps - +) - (values line (- start last) patlen)))) - -(eval-when (compile eval) -(defmacro def-insensitive-newline-search-method (name direction) - `(defun ,name (pattern line start) - (let* ((hashed (string-insensitive-hashed-string pattern)) - (folded-string (string-insensitive-folded-string pattern)) - (patlen (length (the string (search-pattern-pattern pattern))))) - (declare (simple-vector hashed folded-string)) - (when (newline-search-macro line start case-insensitive-test-fun - folded-string ,direction hashed) - (values line start patlen))))) -); eval-when (compile eval) - -(def-insensitive-newline-search-method - insensitive-find-newline-once-forward-method t) -(def-insensitive-newline-search-method - insensitive-find-newline-once-backward-method nil) - -;;;; And Snore, case sensitive. -;;; -;;; This is horribly repetitive, but if I introduce another level of -;;; macroexpansion I will go Insaaaane.... -;;; -(defstruct (string-sensitive-search-pattern - (:include search-pattern) - (:conc-name string-sensitive-) - (:print-function %print-search-pattern)) - string - jumps) - -;;; make-sensitive-newline-pattern -- Internal -;;; -;;; The same, only more sensitive (it hurts when you do that...) -;;; -(defun make-sensitive-newline-pattern (pattern string) - (declare (simple-vector string)) - (let* ((string (coerce string 'simple-string)) - (len (length string)) - (num (1+ (count #\newline string :end len))) - (sliced (make-array num))) - (declare (simple-string string) (simple-vector sliced) (fixnum len num)) - (do ((prev 0 nl) - (i 0 (1+ i)) - (nl (position #\newline string :end len) - (position #\newline string :start nl :end len))) - ((null nl) - (setf (aref sliced i) (subseq string prev len))) - (setf (aref sliced i) (subseq string prev nl)) - (incf nl)) - (setf (string-sensitive-string pattern) sliced))) - -(define-search-kind :string-sensitive (direction pattern old) - ":string-sensitive - Pattern is a string to do a case-sensitive - search for." - (unless old (setq old (make-string-sensitive-search-pattern))) - (setf (search-pattern-kind old) :string-sensitive - (search-pattern-direction old) direction - (search-pattern-pattern old) pattern) - (let* ((string (coerce pattern 'simple-vector))) - (declare (simple-vector string)) - (cond - ((find #\newline string) - (make-sensitive-newline-pattern old string) - (setf (search-pattern-search-function old) - (if (eq direction :forward) - #'sensitive-find-newline-once-forward-method - #'sensitive-find-newline-once-backward-method)) - (setf (search-pattern-reclaim-function old) #'identity)) - (t - (case direction - (:forward - (setf (search-pattern-search-function old) - #'sensitive-find-string-once-forward-method)) - (t - (setf (search-pattern-search-function old) - #'sensitive-find-string-once-backward-method) - (nreverse string))) - (setf (string-sensitive-string old) string) - (setf (string-sensitive-jumps old) - (compute-boyer-moore-jumps - string #'(lambda (v i) (char-code (svref v i))))) - (setf (search-pattern-reclaim-function old) - #'(lambda (p) - (dispose-search-vector (string-sensitive-jumps p))))))) - old) - -(defun sensitive-find-string-once-forward-method (pattern line start) - (let* ((string (string-sensitive-string pattern)) - (jumps (string-sensitive-jumps pattern)) - (patlen (length string)) - (last (1- patlen))) - (declare (simple-vector jumps string) (fixnum patlen last)) - (when (search-once-forward-macro - line start sensitive-string-search-macro - string patlen last jumps + -) - (values line start patlen)))) - -(defun sensitive-find-string-once-backward-method (pattern line start) - (let* ((string (string-sensitive-string pattern)) - (jumps (string-sensitive-jumps pattern)) - (patlen (length string)) - (last (1- patlen))) - (declare (simple-vector jumps string) (fixnum patlen last)) - (when (search-once-backward-macro - line start sensitive-string-search-macro - nil string patlen last jumps - +) - (values line (- start last) patlen)))) - -(eval-when (compile eval) -(defmacro def-sensitive-newline-search-method (name direction) - `(defun ,name (pattern line start) - (let* ((string (string-sensitive-string pattern)) - (patlen (length (the string (search-pattern-pattern pattern))))) - (declare (simple-vector string)) - (when (newline-search-macro line start case-sensitive-test-fun - string ,direction) - (values line start patlen))))) -); eval-when (compile eval) - -(def-sensitive-newline-search-method - sensitive-find-newline-once-forward-method t) -(def-sensitive-newline-search-method - sensitive-find-newline-once-backward-method nil) - -(defun find-pattern (mark search-pattern) - "Find a match of Search-Pattern starting at Mark. Mark is moved to - point before the match and the number of characters matched is returned. - If there is no match for the pattern then Mark is not modified and NIL - is returned." - (close-line) - (multiple-value-bind (line start matched) - (funcall (search-pattern-search-function search-pattern) - search-pattern (mark-line mark) - (mark-charpos mark)) - (when matched - (move-to-position mark start line) - matched))) - -;;; replace-pattern -- Public -;;; -;;; -(defun replace-pattern (mark search-pattern replacement &optional n) - "Replaces N occurrences of the Search-Pattern with the Replacement string - in the text starting at the given Mark. If N is Nil, all occurrences - following the Mark are replaced." - (close-line) - (do* ((replacement (coerce replacement 'simple-string)) - (new (length (the simple-string replacement))) - (fun (search-pattern-search-function search-pattern)) - (forward-p (eq (search-pattern-direction search-pattern) :forward)) - (n (if n (1- n) -1) (1- n)) - (m (copy-mark mark :temporary)) line start matched) - (()) - (multiple-value-setq (line start matched) - (funcall fun search-pattern (mark-line m) (mark-charpos m))) - (unless matched (return m)) - (setf (mark-line m) line (mark-charpos m) start) - (delete-characters m matched) - (insert-string m replacement) - (when forward-p (character-offset m new)) - (when (zerop n) (return m)) - (close-line))) diff --git a/hemlock/search2.lisp b/hemlock/search2.lisp deleted file mode 100644 index bcd417180a4386d5e015e3ed55351d9b5dc0e856..0000000000000000000000000000000000000000 --- a/hemlock/search2.lisp +++ /dev/null @@ -1,204 +0,0 @@ -;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; More searching function for Hemlock. This file contains the stuff -;;; to implement the various kinds of character searches. -;;; -;;; Written by Rob MacLachlan -;;; - -(in-package "HEMLOCK-INTERNALS") - -;;;; Character and Not-Character search kinds: - -(eval-when (compile eval) -(defmacro forward-character-search-macro (string start length char test) - `(position ,char ,string :start ,start :end ,length :test ,test)) - -(defmacro backward-character-search-macro (string start char test) - `(position ,char ,string :end (1+ ,start) :test ,test :from-end t)) - -(defmacro define-character-search-method (name search macro test) - `(defun ,name (pattern line start) - (let ((char (search-pattern-pattern pattern))) - (when (,search line start ,macro char ,test) - (values line start 1))))) -); eval-when (compile eval) - -(define-character-search-method find-character-once-forward-method - search-once-forward-macro forward-character-search-macro #'char=) -(define-character-search-method find-not-character-once-forward-method - search-once-forward-macro forward-character-search-macro #'char/=) -(define-character-search-method find-character-once-backward-method - search-once-backward-macro backward-character-search-macro #'char=) -(define-character-search-method find-not-character-once-backward-method - search-once-backward-macro backward-character-search-macro #'char/=) - -(define-search-kind :character (direction pattern old) - ":character - Pattern is a character to search for." - (unless old (setq old (internal-make-search-pattern))) - (setf (search-pattern-kind old) :character - (search-pattern-direction old) direction - (search-pattern-pattern old) pattern - (search-pattern-reclaim-function old) #'identity - (search-pattern-search-function old) - (if (eq direction :forward) - #'find-character-once-forward-method - #'find-character-once-backward-method)) - old) - -(define-search-kind :not-character (direction pattern old) - ":not-character - Find the first character which is not Char= to Pattern." - (unless old (setq old (internal-make-search-pattern))) - (setf (search-pattern-kind old) :not-character - (search-pattern-direction old) direction - (search-pattern-pattern old) pattern - (search-pattern-reclaim-function old) #'identity - (search-pattern-search-function old) - (if (eq direction :forward) - #'find-not-character-once-forward-method - #'find-not-character-once-backward-method)) - old) - -;;;; Character set searching. -;;; -;;; These functions implement the :test, :test-not, :any and :not-any -;;; search-kinds. - -;;; The Character-Set abstraction is used to hide somewhat the fact that -;;; we are using %Sp-Find-Character-With-Attribute to implement the -;;; character set searches. - -(defvar *free-character-sets* () - "A list of unused character-set objects for use by the Hemlock searching - primitives.") - -;;; Create-Character-Set -- Internal -;;; -;;; Create-Character-Set returns a character-set which will search -;;; for no character. -;;; -(defun create-character-set () - (let ((set (or (pop *free-character-sets*) - (make-array 256 :element-type '(mod 256))))) - (declare (type (simple-array (mod 256)) set)) - (dotimes (i search-char-code-limit) - (setf (aref set i) 0)) - set)) - -;;; Add-Character-To-Set -- Internal -;;; -;;; Modify the character-set Set to succeed for Character. -;;; -(proclaim '(inline add-character-to-set)) -(defun add-character-to-set (character set) - (setf (aref (the (simple-array (mod 256)) set) - (search-char-code character)) - 1)) - -;;; Release-Character-Set -- Internal -;;; -;;; Release the storage for the character set Set. -;;; -(defun release-character-set (set) - (push set *free-character-sets*)) - -(eval-when (compile eval) -;;; Forward-Set-Search-Macro -- Internal -;;; -;;; Do a search for some character in Set in String starting at Start -;;; and ending at End. -;;; -(defmacro forward-set-search-macro (string start last set) - `(%sp-find-character-with-attribute ,string ,start ,last ,set 1)) - -;;; Backward-Set-Search-Macro -- Internal -;;; -;;; Like forward-set-search-macro, only :from-end, and start is -;;; implicitly 0. -;;; -(defmacro backward-set-search-macro (string last set) - `(%sp-reverse-find-character-with-attribute ,string 0 (1+ ,last) ,set 1)) -); eval-when (compile eval) - -(defstruct (set-search-pattern - (:include search-pattern) - (:print-function %print-search-pattern)) - set) - -(eval-when (compile eval) -(defmacro define-set-search-method (name search macro) - `(defun ,name (pattern line start) - (let ((set (set-search-pattern-set pattern))) - (when (,search line start ,macro set) - (values line start 1))))) -); eval-when (compile eval) - -(define-set-search-method find-set-once-forward-method - search-once-forward-macro forward-set-search-macro) - -(define-set-search-method find-set-once-backward-method - search-once-backward-macro backward-set-search-macro) - -(defun frob-character-set (pattern direction old kind) - (unless old (setq old (make-set-search-pattern))) - (setf (search-pattern-kind old) kind - (search-pattern-direction old) direction - (search-pattern-pattern old) pattern - (search-pattern-search-function old) - (if (eq direction :forward) - #'find-set-once-forward-method - #'find-set-once-backward-method) - (search-pattern-reclaim-function old) - #'(lambda (x) (release-character-set (set-search-pattern-set x)))) - old) - -(define-search-kind :test (direction pattern old) - ":test - Find the first character which satisfies the test function Pattern. - Pattern must be a function of its argument only." - (setq old (frob-character-set pattern direction old :test)) - (let ((set (create-character-set))) - (dotimes (i search-char-code-limit) - (when (funcall pattern (code-char i)) - (add-character-to-set (code-char i) set))) - (setf (set-search-pattern-set old) set)) - old) - -(define-search-kind :test-not (direction pattern old) - ":test-not - Find the first character which does not satisfy the - test function Pattern. Pattern must be a function of its argument only." - (setq old (frob-character-set pattern direction old :test-not)) - (let ((set (create-character-set))) - (dotimes (i search-char-code-limit) - (unless (funcall pattern (code-char i)) - (add-character-to-set (code-char i) set))) - (setf (set-search-pattern-set old) set)) - old) - -(define-search-kind :any (direction pattern old) - ":any - Find the first character which is the string Pattern." - (declare (string pattern)) - (setq old (frob-character-set pattern direction old :any)) - (let ((set (create-character-set))) - (dotimes (i (length pattern)) - (add-character-to-set (char pattern i) set)) - (setf (set-search-pattern-set old) set)) - old) - -(define-search-kind :not-any (direction pattern old) - ":not-any - Find the first character which is not in the string Pattern." - (declare (string pattern)) - (setq old (frob-character-set pattern direction old :not-any)) - (let ((set (create-character-set))) - (dotimes (i search-char-code-limit) - (unless (find (code-char i) pattern) - (add-character-to-set (code-char i) set))) - (setf (set-search-pattern-set old) set)) - old) diff --git a/hemlock/searchcoms.lisp b/hemlock/searchcoms.lisp deleted file mode 100644 index 448323ec2649200e6dd1ce85dcd0e3c538c0269f..0000000000000000000000000000000000000000 --- a/hemlock/searchcoms.lisp +++ /dev/null @@ -1,636 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains searching and replacing commands. -;;; - -(in-package "HEMLOCK") - - - -;;;; Some global state. - -(defvar *last-search-string* () "Last string searched for.") -(defvar *last-search-pattern* - (new-search-pattern :string-insensitive :forward "Foo") - "Search pattern we keep around so we don't cons them all the time.") - -(defhvar "String Search Ignore Case" - "When set, string searching commands use case insensitive." - :value t) - -(defun get-search-pattern (string direction) - (declare (simple-string string)) - (when (zerop (length string)) (editor-error)) - (setq *last-search-string* string) - (setq *last-search-pattern* - (new-search-pattern (if (value string-search-ignore-case) - :string-insensitive - :string-sensitive) - direction string *last-search-pattern*))) - - - -;;;; Vanilla searching. - -(defcommand "Forward Search" (p &optional string) - "Do a forward search for a string. - Prompt for the string and leave the point after where it is found." - "Searches for the specified String in the current buffer." - (declare (ignore p)) - (if (not string) - (setq string (prompt-for-string :prompt "Search: " - :default *last-search-string* - :help "String to search for"))) - (let* ((pattern (get-search-pattern string :forward)) - (point (current-point)) - (mark (copy-mark point)) - (won (find-pattern point pattern))) - (cond (won (character-offset point won) - (if (region-active-p) - (delete-mark mark) - (push-buffer-mark mark))) - (t (delete-mark mark) - (editor-error))))) - -(defcommand "Reverse Search" (p &optional string) - "Do a backward search for a string. - Prompt for the string and leave the point before where it is found." - "Searches backwards for the specified String in the current buffer." - (declare (ignore p)) - (if (not string) - (setq string (prompt-for-string :prompt "Reverse Search: " - :default *last-search-string* - :help "String to search for"))) - (let* ((pattern (get-search-pattern string :backward)) - (point (current-point)) - (mark (copy-mark point)) - (won (find-pattern point pattern))) - (cond (won (if (region-active-p) - (delete-mark mark) - (push-buffer-mark mark))) - (t (delete-mark mark) - (editor-error))))) - - - -;;;; Incremental searching. - -(defun i-search-pattern (string direction) - (setq *last-search-pattern* - (new-search-pattern (if (value string-search-ignore-case) - :string-insensitive - :string-sensitive) - direction string *last-search-pattern*))) - -;;; %I-SEARCH-ECHO-REFRESH refreshes the echo buffer for incremental -;;; search. -;;; -(defun %i-search-echo-refresh (string direction failure) - (when (interactive) - (clear-echo-area) - (format *echo-area-stream* - "~:[~;Failing ~]~:[Reverse I-Search~;I-Search~]: ~A" - failure (eq direction :forward) string))) - -(defcommand "Incremental Search" (p) - "Searches for input string as characters are provided. - These are the default I-Search command characters: ^Q quotes the - next character typed. Backspace cancels the last character typed. ^S - repeats forward, and ^R repeats backward. ^R or ^S with empty string - either changes the direction or yanks the previous search string. - Altmode exits the search unless the string is empty. Altmode with - an empty search string calls the non-incremental search command. - Other control characters cause exit and execution of the appropriate - command. If the search fails at some point, ^G and backspace may be - used to backup to a non-failing point; also, ^S and ^R may be used to - look the other way. ^G during a successful search aborts and returns - point to where it started." - "Search for input string as characters are typed in. - It sets up for the recursive searching and checks return values." - (declare (ignore p)) - (setf (last-command-type) nil) - (%i-search-echo-refresh "" :forward nil) - (let* ((point (current-point)) - (save-start (copy-mark point :temporary))) - (with-mark ((here point)) - (when (eq (catch 'exit-i-search - (%i-search "" point here :forward nil)) - :control-g) - (move-mark point save-start) - (invoke-hook abort-hook) - (editor-error)) - (if (region-active-p) - (delete-mark save-start) - (push-buffer-mark save-start))))) - - -(defcommand "Reverse Incremental Search" (p) - "Searches for input string as characters are provided. - These are the default I-Search command characters: ^Q quotes the - next character typed. Backspace cancels the last character typed. ^S - repeats forward, and ^R repeats backward. ^R or ^S with empty string - either changes the direction or yanks the previous search string. - Altmode exits the search unless the string is empty. Altmode with - an empty search string calls the non-incremental search command. - Other control characters cause exit and execution of the appropriate - command. If the search fails at some point, ^G and backspace may be - used to backup to a non-failing point; also, ^S and ^R may be used to - look the other way. ^G during a successful search aborts and returns - point to where it started." - "Search for input string as characters are typed in. - It sets up for the recursive searching and checks return values." - (declare (ignore p)) - (setf (last-command-type) nil) - (%i-search-echo-refresh "" :backward nil) - (let* ((point (current-point)) - (save-start (copy-mark point :temporary))) - (with-mark ((here point)) - (when (eq (catch 'exit-i-search - (%i-search "" point here :backward nil)) - :control-g) - (move-mark point save-start) - (invoke-hook abort-hook) - (editor-error)) - (if (region-active-p) - (delete-mark save-start) - (push-buffer-mark save-start))))) - -;;; %I-SEARCH recursively (with support functions) searches to provide -;;; incremental searching. There is a loop in case the recursion is ever -;;; unwound to some call. curr-point must be saved since point is clobbered -;;; with each recursive call, and the point must be moved back before a -;;; different letter may be typed at a given call. In the CASE at :cancel -;;; and :control-g, if the string is not null, an accurate pattern for this -;;; call must be provided when %I-SEARCH-CHAR-EVAL is called a second time -;;; since it is possible for ^S or ^R to be typed. -;;; -(defun %i-search (string point trailer direction failure) - (do* ((curr-point (copy-mark point :temporary)) - (curr-trailer (copy-mark trailer :temporary)) - (next-char (read-char *editor-input* nil) - (read-char *editor-input* nil))) - (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))) - -;;; %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes -;;; necessary actions. -;;; -(defun %i-search-char-eval (char string point trailer direction failure) - (declare (simple-string string)) - (cond ((standard-char-p char) - (%i-search-printed-char char string point trailer direction failure)) - ((or (logical-char= char :forward-search) - (logical-char= char :backward-search)) - (%i-search-control-s-or-r char string point trailer direction failure)) - ((logical-char= char :cancel) :return-cancel) - ((logical-char= char :abort) - (unless failure - (clear-echo-area) - (message "Search aborted.") - (throw 'exit-i-search :control-g)) - :control-g) - ((logical-char= char :quote) - (%i-search-printed-char (read-char *editor-input* nil) - string point trailer direction failure)) - ((and (zerop (length string)) (logical-char= char :exit)) - (if (eq direction :forward) - (forward-search-command nil) - (reverse-search-command nil)) - (throw 'exit-i-search nil)) - (t - (unless (logical-char= char :exit) - (unread-char char *editor-input*)) - (unless (zerop (length string)) - (setf *last-search-string* string)) - (throw 'exit-i-search nil)))) - -;;; %I-SEARCH-CONTROL-S-OR-R handles repetitions in the search. Note -;;; that there cannot be failure in the last COND branch: since the direction -;;; has just been changed, there cannot be a failure before trying a new -;;; direction. -;;; -(defun %i-search-control-s-or-r (char string point trailer direction failure) - (let ((forward-direction-p (eq direction :forward)) - (forward-character-p (logical-char= char :forward-search))) - (cond ((zerop (length string)) - (%i-search-empty-string point trailer direction forward-direction-p - forward-character-p)) - ((eq forward-direction-p forward-character-p) - (if failure - (%i-search string point trailer direction failure) - (%i-search-find-pattern string point (move-mark trailer point) - direction))) - (t - (let ((new-direction (if forward-character-p :forward :backward))) - (%i-search-echo-refresh string new-direction nil) - (i-search-pattern string new-direction) - (%i-search-find-pattern string point (move-mark trailer point) - new-direction)))))) - - -;;; %I-SEARCH-EMPTY-STRING handles the empty string case when a ^S -;;; or ^R is typed. If the direction and character typed do not agree, -;;; then merely switch directions. If there was a previous string, search -;;; for it, else flash at the guy. -;;; -(defun %i-search-empty-string (point trailer direction forward-direction-p - forward-character-p) - (cond ((eq forward-direction-p (not forward-character-p)) - (let ((direction (if forward-character-p :forward :backward))) - (%i-search-echo-refresh "" direction nil) - (%i-search "" point trailer direction nil))) - (*last-search-string* - (%i-search-echo-refresh *last-search-string* direction nil) - (i-search-pattern *last-search-string* direction) - (%i-search-find-pattern *last-search-string* point trailer direction)) - (t (beep)))) - - -;;; %I-SEARCH-PRINTED-CHAR handles the case of standard character input. -;;; If the direction is backwards, we have to be careful not to MARK-AFTER -;;; the end of the buffer or to include the next character at the beginning -;;; of the search. -;;; -(defun %i-search-printed-char (char string point trailer - direction failure) - (let ((tchar (text-character char))) - (unless tchar (editor-error "Not a text character -- ~S" char)) - (when (interactive) - (insert-character (buffer-point *echo-area-buffer*) tchar) - (force-output *echo-area-stream*)) - (let ((new-string (concatenate 'simple-string string (string tchar)))) - (i-search-pattern new-string direction) - (cond (failure (%i-search new-string point trailer direction failure)) - ((and (eq direction :backward) (next-character trailer)) - (%i-search-find-pattern new-string point (mark-after trailer) - direction)) - (t - (%i-search-find-pattern new-string point trailer direction)))))) - - -;;; %I-SEARCH-FIND-PATTERN takes a pattern for a string and direction -;;; and finds it, updating necessary pointers for the next call to %I-SEARCH. -;;; If the search failed, tell the user and do not move any pointers. -;;; -(defun %i-search-find-pattern (string point trailer direction) - (let ((found-offset (find-pattern trailer *last-search-pattern*))) - (cond (found-offset - (cond ((eq direction :forward) - (character-offset (move-mark point trailer) found-offset)) - (t - (move-mark point trailer) - (character-offset trailer found-offset))) - (%i-search string point trailer direction nil)) - (t - (%i-search-echo-refresh string direction t) - (if (interactive) - (beep) - (editor-error "I-Search failed.")) - (%i-search string point trailer direction t))))) - - - -;;;; Replacement commands: - -(defcommand "Replace String" (p &optional - (target (prompt-for-string - :prompt "Replace String: " - :help "Target string" - :default *last-search-string*)) - (replacement (prompt-for-string - :prompt "With: " - :help "Replacement string"))) - "Replaces the specified Target string with the specified Replacement - string in the current buffer for all occurrences after the point or within - the active region, depending on whether it is active." - "Replaces the specified Target string with the specified Replacement - string in the current buffer for all occurrences after the point or within - the active region, depending on whether it is active. The prefix argument - may limit the number of replacements." - (multiple-value-bind (ignore count) - (query-replace-function p target replacement - "Replace String" t) - (declare (ignore ignore)) - (message "~D Occurrences replaced." count))) - -(defcommand "Query Replace" (p &optional - (target (prompt-for-string - :prompt "Query Replace: " - :help "Target string" - :default *last-search-string*)) - (replacement (prompt-for-string - :prompt "With: " - :help "Replacement string"))) - "Replaces the Target string with the Replacement string if confirmation - from the keyboard is given. If the region is active, limit queries to - occurrences that occur within it, otherwise use point to end of buffer." - "Replaces the Target string with the Replacement string if confirmation - from the keyboard is given. If the region is active, limit queries to - occurrences that occur within it, otherwise use point to end of buffer. - A prefix argument may limit the number of queries." - (let ((mark (copy-mark (current-point)))) - (multiple-value-bind (ignore count) - (query-replace-function p target replacement - "Query Replace") - (declare (ignore ignore)) - (message "~D Occurrences replaced." count)) - (push-buffer-mark mark))) - - -(defhvar "Case Replace" - "If this is true then \"Query Replace\" will try to preserve case when - doing replacements." - :value t) - -(defstruct (replace-undo (:constructor make-replace-undo (mark region))) - mark - region) - -(setf (documentation 'replace-undo-mark 'function) - "Return the mark where a replacement was made.") -(setf (documentation 'replace-undo-region 'function) - "Return region deleted due to replacement.") - -(defvar *query-replace-undo-data* nil) - -;;; REPLACE-THAT-CASE replaces a string case-sensitively. Lower, Cap and Upper -;;; are the original, capitalized and uppercase replacement strings. Mark is a -;;; :left-inserting mark after the text to be replaced. Length is the length -;;; of the target string. If dumb, then do a simple replace. This pushes -;;; an undo information structure into *query-replace-undo-data* which -;;; QUERY-REPLACE-FUNCTION uses. -;;; -(defun replace-that-case (lower cap upper mark length dumb) - (character-offset mark (- length)) - (let ((insert (cond (dumb lower) - ((upper-case-p (next-character mark)) - (mark-after mark) - (prog1 (if (upper-case-p (next-character mark)) upper cap) - (mark-before mark))) - (t lower)))) - (with-mark ((undo-mark1 mark :left-inserting) - (undo-mark2 mark :left-inserting)) - (character-offset undo-mark2 length) - (push (make-replace-undo - ;; Save :right-inserting, so the INSERT-STRING at mark below - ;; doesn't move the copied mark the past replacement. - (copy-mark mark :right-inserting) - (delete-and-save-region (region undo-mark1 undo-mark2))) - *query-replace-undo-data*)) - (insert-string mark insert))) - -;;; QUERY-REPLACE-FUNCTION does the work for the main replacement commands: -;;; "Query Replace", "Replace String", "Group Query Replace", "Group Replace". -;;; Name is the name of the command for undoing purposes. If doing-all? is -;;; true, this replaces all ocurrences for the non-querying commands. This -;;; returns t if it completes successfully, and nil if it is aborted. As a -;;; second value, it returns the number of replacements. -;;; -;;; The undo method, before undo'ing anything, makes all marks :left-inserting. -;;; There's a problem when two replacements are immediately adjacent, such as -;;; foofoo -;;; replacing "foo" with "bar". If the marks were still :right-inserting as -;;; REPLACE-THAT-CASE makes them, then undo'ing the first replacement would -;;; bring the two marks together due to the DELETE-CHARACTERS. Then inserting -;;; the region would move the second replacement's mark to be before the first -;;; replacement. -;;; -(defun query-replace-function (count target replacement name - &optional (doing-all? nil)) - (declare (simple-string replacement)) - (let ((replacement-len (length replacement)) - (*query-replace-undo-data* nil)) - (when (and count (minusp count)) - (editor-error "Replacement count is negative.")) - (get-search-pattern target :forward) - (unwind-protect - (query-replace-loop (get-count-region) (or count -1) target replacement - replacement-len (current-point) doing-all?) - (let ((undo-data (nreverse *query-replace-undo-data*))) - (save-for-undo name - #'(lambda () - (dolist (ele undo-data) - (setf (mark-kind (replace-undo-mark ele)) :left-inserting)) - (dolist (ele undo-data) - (let ((mark (replace-undo-mark ele))) - (delete-characters mark replacement-len) - (ninsert-region mark (replace-undo-region ele))))) - #'(lambda () - (dolist (ele undo-data) - (delete-mark (replace-undo-mark ele))))))))) - -;;; QUERY-REPLACE-LOOP is the essence of QUERY-REPLACE-FUNCTION. The first -;;; value is whether we completed all replacements, nil if we aborted. The -;;; second value is how many replacements occurred. -;;; -(defun query-replace-loop (region count target replacement replacement-len - point doing-all?) - (with-mark ((last-found point) - ;; Copy REGION-END before moving point to REGION-START in case - ;; the end is point. Also, make it permanent in case we make - ;; replacements on the last line containing the end. - (stop-mark (region-end region) :left-inserting)) - (move-mark point (region-start region)) - (let ((length (length target)) - (cap (string-capitalize replacement)) - (upper (string-upcase replacement)) - (dumb (not (and (every #'(lambda (ch) (or (not (both-case-p ch)) - (lower-case-p ch))) - (the string replacement)) - (value case-replace))))) - (values - (loop - (let ((won (find-pattern point *last-search-pattern*))) - (when (or (null won) (zerop count) (mark> point stop-mark)) - (character-offset (move-mark point last-found) replacement-len) - (return t)) - (decf count) - (move-mark last-found point) - (character-offset point length) - (if doing-all? - (replace-that-case replacement cap upper point length dumb) - (command-case - (:prompt - "Query replace: " - :help "Type one of the following single-character commands:" - :change-window nil :bind ch) - (:yes "Replace this occurrence." - (replace-that-case replacement cap upper point length - dumb)) - (:no "Don't replace this occurrence, but continue.") - (:do-all "Replace this and all remaining occurrences." - (replace-that-case replacement cap upper point length - dumb) - (setq doing-all? t)) - (:do-once "Replace this occurrence, then exit." - (replace-that-case replacement cap upper point length - dumb) - (return nil)) - (:recursive-edit - "Go into a recursive edit at the current position." - (do-recursive-edit) - (get-search-pattern target :forward)) - (:exit "Exit immediately." - (return nil)) - (t (unread-char ch *editor-input*) - (return nil)))))) - (length (the list *query-replace-undo-data*)))))) - - - -;;;; Occurrence searching. - -(defcommand "List Matching Lines" (p &optional string) - "Prompts for a search string and lists all matching lines after the point or - within the current-region, depending on whether it is active or not. - With an argument, lists p lines before and after each matching line." - "Prompts for a search string and lists all matching lines after the point or - within the current-region, depending on whether it is active or not. - With an argument, lists p lines before and after each matching line." - (unless string - (setf string (prompt-for-string :prompt "List Matching: " - :default *last-search-string* - :help "String to search for"))) - (let ((pattern (get-search-pattern string :forward)) - (matching-lines nil) - (region (get-count-region))) - (with-mark ((mark (region-start region)) - (end-mark (region-end region))) - (loop - (when (or (null (find-pattern mark pattern)) (mark> mark end-mark)) - (return)) - (setf matching-lines - (nconc matching-lines (list-lines mark (or p 0)))) - (unless (line-offset mark 1 0) - (return)))) - (with-pop-up-display (s :height (length matching-lines)) - (dolist (line matching-lines) - (write-line line s))))) - -;;; LIST-LINES creates a lists of strings containing (num) lines before the -;;; line that the point is on, the line that the point is on, and (num) -;;; lines after the line that the point is on. If (num) > 0, a string of -;;; dashes will be added to make life easier for List Matching Lines. -;;; -(defun list-lines (mark num) - (if (<= num 0) - (list (line-string (mark-line mark))) - (with-mark ((mark mark) - (beg-mark mark)) - (unless (line-offset beg-mark (- num)) - (buffer-start beg-mark)) - (unless (line-offset mark num) - (buffer-end mark)) - (let ((lines (list "--------"))) - (loop - (push (line-string (mark-line mark)) lines) - (when (same-line-p mark beg-mark) - (return lines)) - (line-offset mark -1)))))) - -(defcommand "Delete Matching Lines" (p &optional string) - "Deletes all lines that match the search pattern using delete-region. If - the current region is active, limit the search to it. The argument is - ignored." - "Deletes all lines that match the search pattern using delete-region. If - the current region is active, limit the search to it. The argument is - ignored." - (declare (ignore p)) - (unless string - (setf string (prompt-for-string :prompt "Delete Matching: " - :default *last-search-string* - :help "String to search for"))) - (let* ((region (get-count-region)) - (pattern (get-search-pattern string :forward)) - (start-mark (region-start region)) - (end-mark (region-end region))) - (with-mark ((bol-mark start-mark :left-inserting) - (eol-mark start-mark :right-inserting)) - (loop - (unless (and (find-pattern bol-mark pattern) (mark< bol-mark end-mark)) - (return)) - (move-mark eol-mark bol-mark) - (line-start bol-mark) - (unless (line-offset eol-mark 1 0) - (buffer-end eol-mark)) - (delete-region (region bol-mark eol-mark)))))) - -(defcommand "Delete Non-Matching Lines" (p &optional string) - "Deletes all lines that do not match the search pattern using delete-region. - If the current-region is active, limit the search to it. The argument is - ignored." - "Deletes all lines that do not match the search pattern using delete-region. - If the current-region is active, limit the search to it. The argument is - ignored." - (declare (ignore p)) - (unless string - (setf string (prompt-for-string :prompt "Delete Non-Matching:" - :default *last-search-string* - :help "String to search for"))) - (let* ((region (get-count-region)) - (start-mark (region-start region)) - (stop-mark (region-end region)) - (pattern (get-search-pattern string :forward))) - (with-mark ((beg-mark start-mark :left-inserting) - (end-mark start-mark :right-inserting)) - (loop - (move-mark end-mark beg-mark) - (cond ((and (find-pattern end-mark pattern) (mark< end-mark stop-mark)) - (line-start end-mark) - (delete-region (region beg-mark end-mark)) - (unless (line-offset beg-mark 1 0) - (return))) - (t - (delete-region (region beg-mark stop-mark)) - (return))))))) - -(defcommand "Count Occurrences" (p &optional string) - "Prompts for a search string and counts occurrences of it after the point or - within the current-region, depending on whether it is active or not. The - argument is ignored." - "Prompts for a search string and counts occurrences of it after the point or - within the current-region, depending on whether it is active or not. The - argument is ignored." - (declare (ignore p)) - (unless string - (setf string (prompt-for-string - :prompt "Count Occurrences: " - :default *last-search-string* - :help "String to search for"))) - (message "~D occurrence~:P" - (count-occurrences-region (get-count-region) string))) - -(defun count-occurrences-region (region string) - (let ((pattern (get-search-pattern string :forward)) - (end-mark (region-end region))) - (let ((occurrences 0)) - (with-mark ((mark (region-start region))) - (loop - (let ((won (find-pattern mark pattern))) - (when (or (null won) (mark> mark end-mark)) - (return)) - (incf occurrences) - (character-offset mark won)))) - occurrences))) diff --git a/hemlock/shell.lisp b/hemlock/shell.lisp deleted file mode 100644 index 3d79ff505f6c4f291d256eaf92653140f90e10a9..0000000000000000000000000000000000000000 --- a/hemlock/shell.lisp +++ /dev/null @@ -1,329 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock command level support for processes. -;;; -;;; Written by Blaine Burks. -;;; - -(in-package "HEMLOCK") - - -(defun setup-process-buffer (buffer) - (let ((mark (copy-mark (buffer-point buffer) :right-inserting))) - (defhvar "Buffer Input Mark" - "The buffer input mark for this buffer." - :buffer buffer - :value mark) - (defhvar "Process Output Stream" - "The process structure for this buffer." - :buffer buffer - :value (make-hemlock-output-stream mark)) - (defhvar "Interactive History" - "A ring of the regions input to an interactive mode (Eval or Typescript)." - :buffer buffer - :value (make-ring (value interactive-history-length))) - (defhvar "Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0) - (defhvar "Searching Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0) - (unless (buffer-modeline-field-p buffer :process-status) - (setf (buffer-modeline-fields buffer) - (nconc (buffer-modeline-fields buffer) - (list (modeline-field :process-status))))))) - -(defmode "Process" :major-p nil :setup-function #'setup-process-buffer) - - -;;;; Support for handling input before the prompt in process buffers. - -(defun unwedge-process-buffer () - (buffer-end (current-point)) - (deliver-signal-to-process :SIGINT (value process)) - (editor-error "Aborted.")) - -(defhvar "Unwedge Interactive Input Fun" - "Function to call when input is confirmed, but the point is not past the - input mark." - :value #'unwedge-process-buffer - :mode "Process") - -(defhvar "Unwedge Interactive Input String" - "String to add to \"Point not past input mark. \" explaining what will - happen if the the user chooses to be unwedged." - :value "Interrupt and throw to end of buffer?" - :mode "Process") - - -;;;; Some Global Variables. - -(defhvar "Current Shell" - "The shell that \"Select Shell\" will zap you to.") - -(defhvar "Kill Process Confirm" - "When non-nil, ask the user whether he really wants to blow away the shell. ~ - Otherwise, just blow it away." - :value T) - -(defhvar "Shell Utility" - "The shell command uses this as the default command line." - :value "/bin/csh") - -(defhvar "Shell Utility Switches" - "This is list of strings that are the default command line arguments to the - utility in \"Shell Utility\"." - :value nil) - - - -;;;; The Shell and New Shell Commands. - -(defcommand "Shell" (p) - "If a shell buffer exists, pop to it. Otherwise creates a new one and pop to - it. With an argument, prompt for a command and buffer to execute it in." - "If a shell buffer exists, pop to it. Otherwise creates a new one and pop to - it. With an argument, prompt for a command and buffer to execute it in." - (let ((shell (value current-shell))) - (if shell (change-to-buffer shell) (make-new-shell p)))) - -(defcommand "New Shell" (p) - "Creates a new shell and puts you in it." - "Creates a new shell and puts you in it." - (make-new-shell p)) - -(defun make-new-shell (prompt-for-command-p - &optional (command-line (get-command-line) clp)) - (let* ((command (or (and clp command-line) - (if prompt-for-command-p - (prompt-for-string - :default command-line :trim t - :prompt "Command to execute: " - :help "Shell command line to execute.") - command-line))) - (buffer-name (if prompt-for-command-p - (prompt-for-string - :default - (concatenate 'simple-string command " process") - :trim t - :prompt `("Buffer in which to execute ~A? " - ,command) - :help "Where output from this process will appear.") - (new-shell-name))) - (buffer (make-buffer - buffer-name - :modes '("Fundamental" "Process") - :delete-hook - (list #'(lambda (buffer) - (when (eq (value current-shell) buffer) - (setf (value current-shell) nil)) - (kill-process (variable-value 'process - :buffer buffer))))))) - (unless buffer - (setf buffer (getstring buffer-name *buffer-names*)) - (buffer-end (buffer-point buffer))) - (defhvar "Process" - "The process for Shell and Process buffers." - :buffer buffer - :value (ext::run-program "/bin/sh" (list "-c" command) - :wait nil - :pty (variable-value 'process-output-stream - :buffer buffer) - :env (frob-environment-list - (car (buffer-windows buffer))) - :status-hook #'(lambda (process) - (declare (ignore process)) - (update-process-buffer buffer)) - :input t :output t)) - (update-process-buffer buffer) - (unless (value current-shell) - (setf (value current-shell) buffer)) - (change-to-buffer buffer))) - -;;; GET-COMMAND-LINE -- Internal. -;;; -;;; This just conses up a string to feed to the shell. -;;; -(defun get-command-line () - (concatenate 'simple-string (value shell-utility) " " - (value shell-utility-switches))) - -;;; FROB-ENVIRONMENT-LIST -- Internal. -;;; -;;; This sets some environment variables so the shell will be in the proper -;;; state when it comes up. -;;; -(defun frob-environment-list (window) - (list* (cons :termcap (concatenate 'simple-string - "emacs:co#" - (if window - (lisp::quick-integer-to-string - (window-width window)) - "") - ":tc=unkown:")) - (cons :emacs "t") (cons :term "emacs") - (remove-if #'(lambda (keyword) - (member keyword '(:termcap :emacs :term) - :test #'(lambda (cons keyword) - (eql (car cons) keyword)))) - ext:*environment-list*))) - -;;; NEW-SHELL-NAME -- Internal. -;;; -;;; This returns a unique buffer name for a shell by incrementing the value of -;;; *process-number* until "Process <*process-number*> is not already the name -;;; of a buffer. Perhaps this is being overly cautious, but I've seen some -;;; really stupid users. -;;; -(defvar *process-number* 0) -;;; -(defun new-shell-name () - (loop - (let ((buffer-name (format nil "Shell ~D" (incf *process-number*)))) - (unless (getstring buffer-name *buffer-names*) (return buffer-name))))) - - -;;;; Modeline support. - -(defun modeline-process-status (buffer window) - (declare (ignore window)) - (when (hemlock-bound-p 'process :buffer buffer) - (let ((process (variable-value 'process :buffer buffer))) - (ecase (ext:process-status process) - (:running "running") - (:stopped "stopped") - (:signaled "killed by signal ~D" (mach:unix-signal-name - (ext:process-exit-code process))) - (:exited (format nil "exited with status ~D" - (ext:process-exit-code process))))))) - - -(make-modeline-field :name :process-status - :function #'modeline-process-status) - -(defun update-process-buffer (buffer) - (when (buffer-modeline-field-p buffer :process-status) - (dolist (window (buffer-windows buffer)) - (update-modeline-field buffer window :process-status))) - (let ((process (variable-value 'process :buffer buffer))) - (unless (ext:process-alive-p process) - (ext:process-close process) - (setf (value current-shell) nil)))) - - -;;;; Supporting Commands. - -(defcommand "Confirm Process Input" (p) - "Evaluate Process Mode input between the point and last prompt." - "Evaluate Process Mode input between the point and last prompt." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (let* ((process (value process)) - (stream (ext:process-pty process))) - (case (ext:process-status process) - (:running) - (:stopped (editor-error "The process has been stopped.")) - (t (editor-error "The process is dead."))) - (let ((input-region (get-interactive-input))) - (write-line (region-to-string input-region) stream) - (force-output (ext:process-pty process)) - (insert-character (current-point) #\newline) - ;; Move "Buffer Input Mark" to end of buffer. - (move-mark (region-start input-region) (region-end input-region))))) - -(defcommand "Kill Main Process" (p) - "Kills the process in the current buffer." - "Kills the process in the current buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (when (or (not (value kill-process-confirm)) - (prompt-for-y-or-n :default nil - :prompt "Really blow away shell? " - :default nil - :default-string "no")) - (kill-process (value process)))) - -(defcommand "Stop Main Process" (p) - "Stops the process in the current buffer. With an argument use :SIGSTOP - instead of :SIGTSTP." - "Stops the process in the current buffer. With an argument use :SIGSTOP - instead of :SIGTSTP." - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-process (if p :SIGSTOP :SIGTSTP) (value process))) - -(defcommand "Continue Main Process" (p) - "Continues the process in the current buffer." - "Continues the process in the current buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-process :SIGCONT (value process))) - -(defun kill-process (process) - "Self-explanatory." - (deliver-signal-to-process :SIGKILL process)) - -(defun deliver-signal-to-process (signal process) - "Delivers a signal to a process." - (ext:process-kill process signal :process-group)) - -(defcommand "Send EOF to Process" (p) - "Sends a Ctrl-D to the process in the current buffer." - "Sends a Ctrl-D to the process in the current buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (let ((stream (ext:process-pty (value process)))) - (write-char (int-char 4) stream) - (force-output stream))) - -(defcommand "Interrupt Buffer Subprocess" (p) - "Stop the subprocess currently executing in this shell." - "Stop the subprocess currently executing in this shell." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (buffer-end (current-point)) - (buffer-end (value buffer-input-mark)) - (deliver-signal-to-subprocess :SIGINT (value process))) - -(defcommand "Kill Buffer Subprocess" (p) - "Kill the subprocess currently executing in this shell." - "Kill the subprocess currently executing in this shell." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-subprocess :SIGKILL (value process))) - -(defcommand "Quit Buffer Subprocess" (p) - "Quit the subprocess currently executing int his shell." - "Quit the subprocess currently executing int his shell." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-subprocess :SIGQUIT (value process))) - -(defcommand "Stop Buffer Subprocess" (p) - "Stop the subprocess currently executing in this shell." - "Stop the subprocess currently executing in this shell." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process))) - -(defun deliver-signal-to-subprocess (signal process) - "Delivers a signal to a subprocess of a shell." - (ext:process-kill process signal :pty-process-group)) diff --git a/hemlock/spell-aug.lisp b/hemlock/spell-aug.lisp deleted file mode 100644 index 32b5d19f14e785ff292ef345191fd0fe05fa5603..0000000000000000000000000000000000000000 --- a/hemlock/spell-aug.lisp +++ /dev/null @@ -1,235 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Spell -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; Designed by Bill Chiles and Rob Maclachlan -;;; -;;; This file contains the code to grow the spelling dictionary in system -;;; space by reading a text file of entries or adding one at a time. This -;;; code relies on implementation dependent code found in Spell-RT.Lisp. - - -(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) - -(export '(spell-add-entry spell-read-dictionary spell-remove-entry - spell-root-flags)) - - - -;;;; Converting Flags to Masks - -(defconstant flag-names-to-masks - `((#\V . ,V-mask) (#\N . ,N-mask) (#\X . ,X-mask) - (#\H . ,H-mask) (#\Y . ,Y-mask) (#\G . ,G-mask) - (#\J . ,J-mask) (#\D . ,D-mask) (#\T . ,T-mask) - (#\R . ,R-mask) (#\Z . ,Z-mask) (#\S . ,S-mask) - (#\P . ,P-mask) (#\M . ,M-mask))) - -(defvar *flag-masks* - (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0) - "This holds the masks for character flags, which is used when reading - a text file of dictionary words. Illegal character flags hold zero.") - -(eval-when (compile eval) -(defmacro flag-mask (char) - `(aref *flag-masks* (char-code ,char))) -) ;eval-when - -(dolist (e flag-names-to-masks) - (let ((char (car e)) - (mask (cdr e))) - (setf (flag-mask char) mask) - (setf (flag-mask (char-downcase char)) mask))) - - - -;;;; String and Hashing Macros - -(eval-when (compile eval) - -(defmacro string-table-replace (src-string dst-start length) - `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length))) - -;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for -;;; adding a new entry. If a location contains a zero, then it has never -;;; been used, and no entries have ever been "hashed past" it. If a location -;;; contains a -1, then it once contained an entry that has since been -;;; deleted. -;;; -(defmacro hash-entry (entry entry-len) - (let ((loop-loc (gensym)) (loc-contents (gensym)) - (hash (gensym)) (loc (gensym))) - `(let* ((,hash (string-hash ,entry ,entry-len)) - (,loc (rem ,hash (the fixnum *dictionary-size*))) - (,loc-contents (dictionary-ref ,loc))) - (declare (fixnum ,loc ,loc-contents)) - (if (or (zerop ,loc-contents) (= ,loc-contents -1)) - ,loc - (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash - ,loop-loc nil t))))) - -) ;eval-when - - - -;;;; Top Level Stuff - -(defun spell-read-dictionary (filename) - "Add entries to dictionary from lines in the file filename." - (with-open-file (s filename :direction :input) - (loop (multiple-value-bind (entry eofp) (read-line s nil nil) - (declare (simple-string entry)) - (unless entry (return)) - (spell-add-entry entry) - (if eofp (return)))))) - - -;;; This is used to break up an 18 bit string table index into two parts -;;; for storage in a word descriptor unit. See the documentation at the -;;; top of Spell-Correct.Lisp. -;;; -(defconstant whole-index-low-byte (byte 16 0)) - -(defun spell-add-entry (line &optional - (word-end (or (position #\/ line :test #'char=) - (length line)))) - "Line is of the form \"entry/flag1/flag2\" or \"entry\". It is parsed and - added to the spelling dictionary. Line is desstructively modified." - (declare (simple-string line) (fixnum word-end)) - (nstring-upcase line :end word-end) - (when (> word-end max-entry-length) - (return-from spell-add-entry nil)) - (let ((entry (lookup-entry line word-end))) - (when entry - (add-flags (+ entry 2) line word-end) - (return-from spell-add-entry nil))) - (let* ((hash-loc (hash-entry line word-end)) - (string-ptr *string-table-size*) - (desc-ptr *descriptors-size*) - (desc-ptr+1 (1+ desc-ptr)) - (desc-ptr+2 (1+ desc-ptr+1))) - (declare (fixnum string-ptr)) - (when (not hash-loc) (error "Dictionary Overflow!")) - (when (> 3 *free-descriptor-elements*) (grow-descriptors)) - (when (> word-end *free-string-table-bytes*) (grow-string-table)) - (decf *free-descriptor-elements* 3) - (incf *descriptors-size* 3) - (decf *free-string-table-bytes* word-end) - (incf *string-table-size* word-end) - (setf (dictionary-ref hash-loc) desc-ptr) - (setf (descriptor-ref desc-ptr) - (dpb (the fixnum (ldb new-hash-byte (string-hash line word-end))) - stored-hash-byte - word-end)) - (setf (descriptor-ref desc-ptr+1) - (ldb whole-index-low-byte string-ptr)) - (setf (descriptor-ref desc-ptr+2) - (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) - stored-index-high-byte - 0)) - (add-flags desc-ptr+2 line word-end) - (string-table-replace line string-ptr word-end)) - t) - -(defun add-flags (loc line word-end) - (declare (simple-string line) (fixnum word-end)) - (do ((flag (1+ word-end) (+ 2 flag)) - (line-end (length line))) - ((>= flag line-end)) - (declare (fixnum flag line-end)) - (let ((flag-mask (flag-mask (schar line flag)))) - (declare (fixnum flag-mask)) - (unless (zerop flag-mask) - (setf (descriptor-ref loc) - (logior flag-mask (descriptor-ref loc))))))) - -;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from -;;; the dictionary. First entry is looked up, and if it is found due to a -;;; flag, the flag is cleared in the descriptor table. If entry is a root -;;; word in the dictionary (that is, looked up without the use of a flag), -;;; then the root and all its derivitives are deleted by setting its -;;; dictionary location to -1. -;;; -(defun spell-remove-entry (entry) - "Removes entry from the dictionary, so it will be an unknown word. Entry - is a simple string and is destructively modified. If entry is a root - word, then all words derived with entry and its flags will also be deleted." - (declare (simple-string entry)) - (nstring-upcase entry) - (let ((entry-len (length entry))) - (declare (fixnum entry-len)) - (when (<= 2 entry-len max-entry-length) - (multiple-value-bind (index flagp) - (spell-try-word entry entry-len) - (when index - (if flagp - (setf (descriptor-ref (+ 2 index)) - (logandc2 (descriptor-ref (+ 2 index)) flagp)) - (let* ((hash (string-hash entry entry-len)) - (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) - stored-hash-byte - (the fixnum entry-len))) - (loc (rem hash (the fixnum *dictionary-size*))) - (loc-contents (dictionary-ref loc))) - (declare (fixnum hash hash-and-len loc)) - (cond ((zerop loc-contents) nil) - ((found-entry-p loc-contents entry entry-len hash-and-len) - (setf (dictionary-ref loc) -1)) - (t - (hash2-loop (loop-loc loc-contents) loc hash - nil - (when (found-entry-p loc-contents entry - entry-len hash-and-len) - (setf (dictionary-ref loop-loc) -1) - (return -1)))))))))))) - -(defun spell-root-flags (index) - "Return the flags associated with the root word corresponding to a - dictionary entry at index." - (let ((desc-word (descriptor-ref (+ 2 index))) - (result ())) - (declare (fixnum desc-word)) - (dolist (ele flag-names-to-masks result) - (unless (zerop (logand (the fixnum (cdr ele)) desc-word)) - (push (car ele) result))))) - - - -;;;; Growing Dictionary Structures - -;;; GROW-DESCRIPTORS grows the descriptors vector by 10%. -;;; -(defun grow-descriptors () - (let* ((old-size (+ (the fixnum *descriptors-size*) - (the fixnum *free-descriptor-elements*))) - (new-size (truncate (* old-size 1.1))) - (new-bytes (* new-size 2)) - (new-sap (allocate-bytes new-bytes))) - (declare (fixnum new-size old-size)) - (sap-replace new-sap *descriptors* 0 0 - (* 2 (the fixnum *descriptors-size*))) - (deallocate-bytes (system-address *descriptors*) (* 2 old-size)) - (setf *free-descriptor-elements* - (- new-size (the fixnum *descriptors-size*))) - (setf *descriptors* new-sap))) - -;;; GROW-STRING-TABLE grows the string table by 10%. -;;; -(defun grow-string-table () - (let* ((old-size (+ (the fixnum *string-table-size*) - (the fixnum *free-string-table-bytes*))) - (new-size (truncate (* old-size 1.1))) - (new-sap (allocate-bytes new-size))) - (declare (fixnum new-size old-size)) - (sap-replace new-sap *string-table* 0 0 *string-table-size*) - (setf *free-string-table-bytes* - (- new-size (the fixnum *string-table-size*))) - (deallocate-bytes (system-address *string-table*) old-size) - (setf *string-table* new-sap))) diff --git a/hemlock/spell-build.lisp b/hemlock/spell-build.lisp deleted file mode 100644 index b8fb29a446fdcffecd25e82b2c8b959600328d3e..0000000000000000000000000000000000000000 --- a/hemlock/spell-build.lisp +++ /dev/null @@ -1,242 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Spell -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; Designed by Bill Chiles and Rob Maclachlan -;;; - -;;; This file contains code to build a new binary dictionary file from -;;; text in system space. This code relies on implementation dependent -;;; code from spell-rt.lisp. Also, it is expected that spell-corr.lisp -;;; and spell-aug.lisp have been loaded. In order to compile this file, -;;; you must first compile spell-rt, spell-corr.lisp, and spell-aug.lisp. - -;;; The text file must be in the following format: -;;; entry1/flag1/flag2/flag3 -;;; entry2 -;;; entry3/flag1/flag2/flag3/flag4/flag5. -;;; The flags are single letter indicators of legal suffixes for the entry; -;;; the available flags and their correct use may be found at the beginning -;;; of spell-corr.lisp in the Hemlock sources. There must be exactly one -;;; entry per line, and each line must be flushleft. - -;;; The dictionary is built in system space as three distinct -;;; blocks of memory: the dictionary which is a hash table whose elements -;;; are one machine word or of type '(unsigned-byte 16); a descriptors -;;; vector which is described below; and a string table. After all the -;;; entries are read in from the text file, one large block of memory is -;;; validated, and the three structures are moved into it. Then the file -;;; is written. When the large block of memory is validated, enough -;;; memory is allocated to write the three vector such that they are page -;;; aligned. This is important for the speed it allows in growing the -;;; "dictionary" when augmenting it from a user's text file (see -;;; spell-aug.lisp). - - -(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) - - - -;;;; Constants - -;;; This is an upper bound estimate of the number of stored entries in the -;;; dictionary. It should not be more than 21,845 because the dictionary -;;; is a vector of type '(unsigned-byte 16), and the descriptors' vector -;;; for the entries uses three '(unsigned-byte 16) elements per descriptor -;;; unit. See the beginning of Spell-Correct.Lisp. -;;; -(defconstant max-entry-count-estimate 15600) - -(defconstant new-dictionary-size 20011) - -(defconstant new-descriptors-size (1+ (* 3 max-entry-count-estimate))) - -(defconstant max-string-table-length (* 10 max-entry-count-estimate)) - - - -;;;; Hashing - -;;; These hashing macros are different from the ones in Spell-Correct.Lisp -;;; simply because we are using separate space and global specials/constants. -;;; Of course, they should be identical, but it doesn't seem worth cluttering -;;; up Spell-Correct with macro generating macros for this file. - -(eval-when (compile eval) - -(defmacro new-hash2-increment (hash) - `(- new-dictionary-size - 2 - (the fixnum (rem ,hash (- new-dictionary-size 2))))) - -(defmacro new-hash2-loop (loc hash dictionary) - (let ((incr (gensym)) - (loop-loc (gensym))) - `(let* ((,incr (new-hash2-increment ,hash)) - (,loop-loc ,loc)) - (declare (fixnum ,incr ,loop-loc)) - (loop (setf ,loop-loc - (rem (+ ,loop-loc ,incr) new-dictionary-size)) - (when (zerop (the fixnum (aref ,dictionary ,loop-loc))) - (return ,loop-loc)) - (when (= ,loop-loc ,loc) (return nil)))))) - -(defmacro new-hash-entry (entry entry-len dictionary) - (let ((hash (gensym)) - (loc (gensym))) - `(let* ((,hash (string-hash ,entry ,entry-len)) - (,loc (rem ,hash new-dictionary-size))) - (declare (fixnum ,loc)) - (cond ((not (zerop (the fixnum (aref ,dictionary ,loc)))) - (incf *collision-count*) - (new-hash2-loop ,loc ,hash ,dictionary)) - (t ,loc))))) - -) ;eval-when - - - -;;;; Build-Dictionary - -;;; An interesting value when building an initial dictionary. -(defvar *collision-count* 0) - -(defvar *new-dictionary*) -(defvar *new-descriptors*) -(defvar *new-string-table*) - -(defun build-dictionary (input output &optional save-structures-p) - (let ((dictionary (make-array new-dictionary-size - :element-type '(unsigned-byte 16))) - (descriptors (make-array new-descriptors-size - :element-type '(unsigned-byte 16))) - (string-table (make-string max-string-table-length))) - (write-line "Reading dictionary ...") - (force-output) - (setf *collision-count* 0) - (multiple-value-bind (entry-count string-table-length) - (read-initial-dictionary input dictionary - descriptors string-table) - (write-line "Writing dictionary ...") - (force-output) - (write-dictionary output dictionary descriptors entry-count - string-table string-table-length) - (when save-structures-p - (setf *new-dictionary* dictionary) - (setf *new-descriptors* descriptors) - (setf *new-string-table* string-table)) - (format t "~D entries processed with ~D collisions." - entry-count *collision-count*)))) - -(defun read-initial-dictionary (f dictionary descriptors string-table) - (let* ((filename (pathname f)) - (s (open filename :direction :input :if-does-not-exist nil))) - (unless s (error "File ~S does not exist." f)) - (multiple-value-prog1 - (let ((descriptor-ptr 1) - (string-ptr 0) - (entry-count 0)) - (declare (fixnum descriptor-ptr string-ptr entry-count)) - (loop (multiple-value-bind (line eofp) (read-line s nil nil) - (declare (simple-string line)) - (unless line (return (values entry-count string-ptr))) - (incf entry-count) - (when (> entry-count max-entry-count-estimate) - (error "There are too many entries in text file!~%~ - Please change constants in spell-build.lisp, ~ - recompile the file, and reload it.~%~ - Be sure to understand the constraints of permissible ~ - values.")) - (let ((flags (or (position #\/ line :test #'char=) (length line)))) - (declare (fixnum flags)) - (cond ((> flags max-entry-length) - (format t "Entry ~s too long." (subseq line 0 flags)) - (force-output)) - (t (let ((new-string-ptr (+ string-ptr flags))) - (declare (fixnum new-string-ptr)) - (when (> new-string-ptr max-string-table-length) - (error "Spell string table overflow!~%~ - Please change constants in ~ - spell-build.lisp, recompile the file, ~ - and reload it.~%~ - Be sure to understand the constraints ~ - of permissible values.")) - (spell-place-entry line flags - dictionary descriptors string-table - descriptor-ptr string-ptr) - (incf descriptor-ptr 3) - (setf string-ptr new-string-ptr))))) - (when eofp (return (values entry-count string-ptr)))))) - (close s)))) - -(defun spell-place-entry (line word-end dictionary descriptors string-table - descriptor-ptr string-ptr) - (declare (simple-string line string-table) - (fixnum word-end descriptor-ptr string-ptr) - (type (array (unsigned-byte 16) 1) dictionary descriptors)) - (nstring-upcase line :end word-end) - (let* ((hash-loc (new-hash-entry line word-end dictionary)) - (descriptor-ptr+1 (1+ descriptor-ptr)) - (descriptor-ptr+2 (1+ descriptor-ptr+1))) - (unless hash-loc (error "Dictionary Overflow!")) - (setf (aref dictionary hash-loc) descriptor-ptr) - (setf (aref descriptors descriptor-ptr) - (dpb (the fixnum - (ldb new-hash-byte (string-hash line word-end))) - stored-hash-byte - word-end)) - (setf (aref descriptors descriptor-ptr+1) - (ldb whole-index-low-byte string-ptr)) - (setf (aref descriptors descriptor-ptr+2) - (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) - stored-index-high-byte - 0)) - (new-add-flags descriptors descriptor-ptr+2 line word-end) - (replace string-table line :start1 string-ptr :end2 word-end))) - -(defun new-add-flags (descriptors loc line word-end) - (declare (simple-string line) - (fixnum word-end) - (type (array (unsigned-byte 16) 1) descriptors)) - (do ((flag (1+ word-end) (+ 2 flag)) - (line-end (length line))) - ((>= flag line-end)) - (declare (fixnum flag line-end)) - (let ((flag-mask (flag-mask (schar line flag)))) - (declare (fixnum flag-mask)) - (if (zerop flag-mask) - (format t "Illegal flag ~S on word ~S." - (schar line flag) (subseq line 0 word-end)) - (setf (aref descriptors loc) - (logior flag-mask (aref descriptors loc))))))) - -(defun write-dictionary (f dictionary descriptors entry-count - string-table string-table-length) - (declare (type (array (unsigned-byte 16) 1) dictionary descriptors) - (simple-string string-table) - (fixnum string-table-length)) - (let ((filename (lisp::predict-name (namestring (pathname f)) nil))) - (with-open-file (s filename :direction :output - :element-type '(unsigned-byte 16) - :if-exists :overwrite - :if-does-not-exist :create) - (let ((descriptors-size (1+ (* 3 entry-count)))) - (write-byte magic-file-id s) - (write-byte new-dictionary-size s) - (write-byte descriptors-size s) - (write-byte (ldb whole-index-low-byte string-table-length) s) - (write-byte (ldb whole-index-high-byte string-table-length) s) - (dotimes (i new-dictionary-size) - (write-byte (aref dictionary i) s)) - (dotimes (i descriptors-size) - (write-byte (aref descriptors i) s)))) - (with-open-file (s f :direction :output :element-type 'string-char - :if-exists :append) - (write-string string-table s :end string-table-length)))) diff --git a/hemlock/spell-corr.lisp b/hemlock/spell-corr.lisp deleted file mode 100644 index 63f740588337af4a7f85f5e6a7f160c9381978b4..0000000000000000000000000000000000000000 --- a/hemlock/spell-corr.lisp +++ /dev/null @@ -1,804 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Spell -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; Designed by Bill Chiles and Rob Maclachlan -;;; - -;;; This is the file that deals with checking and correcting words -;;; using a dictionary read in from a binary file. It has been written -;;; from the basic ideas used in Ispell (on DEC-20's) which originated as -;;; Spell on the ITS machines at MIT. There are flags which have proper -;;; uses defined for them that indicate permissible suffixes to entries. -;;; This allows for about three times as many known words than are actually -;;; stored. When checking the spelling of a word, first it is looked up; -;;; if this fails, then possible roots are looked up, and if any has the -;;; appropriate suffix flag, then the word is considered to be correctly -;;; spelled. For an unknown word, the following rules define "close" words -;;; which are possible corrections: -;;; 1] two adjacent letters are transposed to form a correct spelling; -;;; 2] one letter is changed to form a correct spelling; -;;; 3] one letter is added to form a correct spelling; and/or -;;; 4] one letter is removed to form a correct spelling. -;;; There are two restrictions on the length of a word in regards to its -;;; worthiness of recognition: it must be at least more than two letters -;;; long, and if it has a suffix, then it must be at least four letters -;;; long. More will be said about this when the flags are discussed. -;;; This is implemented in as tense a fashion as possible, and it uses -;;; implementation dependent code from Spell-RT.Lisp to accomplish this. -;;; In general the file I/O and structure accesses encompass the system -;;; dependencies. - -;;; This next section will discuss the storage of the dictionary -;;; information. There are three data structures that "are" the -;;; dictionary: a hash table, descriptors table, and a string table. The -;;; hash table is a vector of type '(unsigned-byte 16), whose elements -;;; point into the descriptors table. This is a cyclic hash table to -;;; facilitate dumping it to a file. The descriptors table (also of type -;;; '(unsigned-byte 16)) dedicates three elements to each entry in the -;;; dictionary. Each group of three elements has the following organization -;;; imposed on them: -;;; ---------------------------------------------- -;;; | 15..5 hash code | 4..0 length | -;;; ---------------------------------------------- -;;; | 15..0 character index | -;;; ---------------------------------------------- -;;; | 15..14 character index | 13..0 flags | -;;; ---------------------------------------------- -;;; "Length" is the number of characters in the entry; "hash code" is some -;;; eleven bits from the hash code to allow for quicker lookup, "flags" -;;; indicate possible suffixes for the basic entry, and "character index" -;;; is the index of the start of the entry in the string table. -;;; This was originally adopted due to the Perq's word size (can you guess? -;;; 16 bits, that's right). Note the constraint that is placed on the number -;;; of the entries, 21845, because the hash table could not point to more -;;; descriptor units (16 bits of pointer divided by three). Since a value of -;;; zero as a hash table element indicates an empty location, the zeroth element -;;; of the descriptors table must be unused (it cannot be pointed to). - - -;;; The following is a short discussion with examples of the correct -;;; use of the suffix flags. Let # and @ be symbols that can stand for any -;;; single letter. Upper case letters are constants. "..." stands for any -;;; string of zero or more letters, but note that no word may exist in the -;;; dictionary which is not at least 2 letters long, so, for example, FLY -;;; may not be produced by placing the "Y" flag on "F". Also, no flag is -;;; effective unless the word that it creates is at least 4 letters long, -;;; so, for example, WED may not be produced by placing the "D" flag on -;;; "WE". These flags and examples are from the Ispell documentation with -;;; only slight modifications. Here are the correct uses of the flags: -;;; -;;; "V" flag: -;;; ...E => ...IVE as in create => creative -;;; if # .ne. E, then ...# => ...#IVE as in prevent => preventive -;;; -;;; "N" flag: -;;; ...E => ...ION as in create => creation -;;; ...Y => ...ICATION as in multiply => multiplication -;;; if # .ne. E or Y, then ...# => ...#EN as in fall => fallen -;;; -;;; "X" flag: -;;; ...E => ...IONS as in create => creations -;;; ...Y => ...ICATIONS as in multiply => multiplications -;;; if # .ne. E or Y, ...# => ...#ENS as in weak => weakens -;;; -;;; "H" flag: -;;; ...Y => ...IETH as in twenty => twentieth -;;; if # .ne. Y, then ...# => ...#TH as in hundred => hundredth -;;; -;;; "Y" FLAG: -;;; ... => ...LY as in quick => quickly -;;; -;;; "G" FLAG: -;;; ...E => ...ING as in file => filing -;;; if # .ne. E, then ...# => ...#ING as in cross => crossing -;;; -;;; "J" FLAG" -;;; ...E => ...INGS as in file => filings -;;; if # .ne. E, then ...# => ...#INGS as in cross => crossings -;;; -;;; "D" FLAG: -;;; ...E => ...ED as in create => created -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IED as in imply => implied -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#ED as in convey => conveyed -;;; if # .ne. E or Y, then ...# => ...#ED as in cross => crossed -;;; -;;; "T" FLAG: -;;; ...E => ...EST as in late => latest -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IEST as in dirty => dirtiest -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#EST as in gray => grayest -;;; if # .ne. E or Y, then ...# => ...#EST as in small => smallest -;;; -;;; "R" FLAG: -;;; ...E => ...ER as in skate => skater -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IER as in multiply => multiplier -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#ER as in convey => conveyer -;;; if # .ne. E or Y, then ...# => ...#ER as in build => builder -;;; - -;;; "Z FLAG: -;;; ...E => ...ERS as in skate => skaters -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IERS as in multiply => multipliers -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#ERS as in slay => slayers -;;; if # .ne. E or Y, then ...@# => ...@#ERS as in build => builders -;;; -;;; "S" FLAG: -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IES as in imply => implies -;;; if # .eq. S, X, Z, or H, -;;; then ...# => ...#ES as in fix => fixes -;;; if # .ne. S, X, Z, H, or Y, -;;; then ...# => ...#S as in bat => bats -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#S as in convey => conveys -;;; -;;; "P" FLAG: -;;; if # .ne. Y, or @ = A, E, I, O, or U, -;;; then ...@# => ...@#NESS as in late => lateness and -;;; gray => grayness -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@INESS as in cloudy => cloudiness -;;; -;;; "M" FLAG: -;;; ... => ...'S as in DOG => DOG'S - - - -(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) - -(export '(spell-try-word spell-root-word spell-collect-close-words - maybe-read-spell-dictionary correct-spelling max-entry-length)) - - - -;;;; Some Constants - -;;; The next number (using 6 bits) is 63, and that's pretty silly because -;;; "supercalafragalistic" is less than 31 characters long. -;;; -(defconstant max-entry-length 31 - "This the maximum number of characters an entry may have.") - -;;; These are the flags (described above), and an entry is allowed a -;;; certain suffix if the appropriate bit is on in the third element of -;;; its descriptor unit (described above). -;;; -(defconstant V-mask (ash 1 13)) -(defconstant N-mask (ash 1 12)) -(defconstant X-mask (ash 1 11)) -(defconstant H-mask (ash 1 10)) -(defconstant Y-mask (ash 1 9)) -(defconstant G-mask (ash 1 8)) -(defconstant J-mask (ash 1 7)) -(defconstant D-mask (ash 1 6)) -(defconstant T-mask (ash 1 5)) -(defconstant R-mask (ash 1 4)) -(defconstant Z-mask (ash 1 3)) -(defconstant S-mask (ash 1 2)) -(defconstant P-mask (ash 1 1)) -(defconstant M-mask 1) - - -;;; These are the eleven bits of a computed hash that are stored as part of -;;; an entries descriptor unit. The shifting constant is how much the -;;; eleven bits need to be shifted to the right, so they take up the upper -;;; eleven bits of one 16-bit element in a descriptor unit. -;;; -(defconstant new-hash-byte (byte 11 13)) -(defconstant stored-hash-byte (byte 11 5)) - - -;;; The next two constants are used to extract information from an entry's -;;; descriptor unit. The first is the two most significant bits of 18 -;;; bits that hold an index into the string table where the entry is -;;; located. If this is confusing, regard the diagram of the descriptor -;;; units above. -;;; -(defconstant whole-index-high-byte (byte 2 16)) -(defconstant stored-index-high-byte (byte 2 14)) -(defconstant stored-length-byte (byte 5 0)) - - - -;;;; Some Specials and Accesses - -;;; *spell-aeiou* will have bits on that represent the capital letters -;;; A, E, I, O, and U to be used to determine if some word roots are legal -;;; for looking up. -;;; -(defvar *aeiou* - (make-array 128 :element-type 'bit :initial-element 0)) - -(setf (aref *aeiou* (char-code #\A)) 1) -(setf (aref *aeiou* (char-code #\E)) 1) -(setf (aref *aeiou* (char-code #\I)) 1) -(setf (aref *aeiou* (char-code #\O)) 1) -(setf (aref *aeiou* (char-code #\U)) 1) - - -;;; *sxzh* will have bits on that represent the capital letters -;;; S, X, Z, and H to be used to determine if some word roots are legal for -;;; looking up. -;;; -(defvar *sxzh* - (make-array 128 :element-type 'bit :initial-element 0)) - -(setf (aref *sxzh* (char-code #\S)) 1) -(setf (aref *sxzh* (char-code #\X)) 1) -(setf (aref *sxzh* (char-code #\Z)) 1) -(setf (aref *sxzh* (char-code #\H)) 1) - - -;;; SET-MEMBER-P will be used with *aeiou* and *sxzh* to determine if a -;;; character is in the specified set. -;;; -(eval-when (compile eval) -(defmacro set-member-p (char set) - `(not (zerop (the fixnum (aref (the simple-bit-vector ,set) - (char-code ,char)))))) -) ;eval-when - - -(defvar *dictionary*) -(defvar *dictionary-size*) -(defvar *descriptors*) -(defvar *descriptors-size*) -(defvar *string-table*) -(defvar *string-table-size*) - - -(eval-when (compile eval) - -;;; DICTIONARY-REF and DESCRIPTOR-REF are references to implementation -;;; dependent structures. *dictionary* and *descriptors* are "system -;;; area pointers" as a result of the way the binary file is opened for -;;; fast access. -;;; -(defmacro dictionary-ref (idx) - `(sapref *dictionary* ,idx)) - -(defmacro descriptor-ref (idx) - `(sapref *descriptors* ,idx)) - - -;;; DESCRIPTOR-STRING-START access an entry's (indicated by idx) -;;; descriptor unit (described at the beginning of the file) and returns -;;; the start index of the entry in the string table. The second of three -;;; words in the descriptor holds the 16 least significant bits of 18, and -;;; the top two bits of the third word are the 2 most significant bits. -;;; These 18 bits are the index into the string table. -;;; -(defmacro descriptor-string-start (idx) - `(dpb (the fixnum (ldb stored-index-high-byte - (the fixnum (descriptor-ref (+ 2 ,idx))))) - whole-index-high-byte - (the fixnum (descriptor-ref (1+ ,idx))))) - -) ;eval-when - - - -;;;; Top level Checking/Correcting - -;;; CORRECT-SPELLING can be called from top level to check/correct a words -;;; spelling. It is not used for any other purpose. -;;; -(defun correct-spelling (word) - "Check/correct the spelling of word. Output is done to *standard-output*." - (setf word (coerce word 'simple-string)) - (let ((word (string-upcase (the simple-string word))) - (word-len (length (the simple-string word)))) - (declare (simple-string word) (fixnum word-len)) - (maybe-read-spell-dictionary) - (when (= word-len 1) - (error "Single character words are not in the dictionary.")) - (when (> word-len max-entry-length) - (error "~A is too long for the dictionary." word)) - (multiple-value-bind (idx used-flag-p) - (spell-try-word word word-len) - (if idx - (format t "Found it~:[~; because of ~A~]." used-flag-p - (spell-root-word idx)) - (let ((close-words (spell-collect-close-words word))) - (if close-words - (format *standard-output* - "The possible correct spelling~[~; is~:;s are~]:~ - ~:*~[~; ~{~A~}~;~{ ~A~^ and~}~:;~ - ~{~#[~; and~] ~A~^,~}~]." - (length close-words) - close-words) - (format *standard-output* "Word not found."))))))) - - -(defvar *dictionary-read-p* nil) - -;;; MAYBE-READ-SPELL-DICTIONARY -- Public -;;; -(defun maybe-read-spell-dictionary () - "Read the spelling dictionary if it has not be read already." - (unless *dictionary-read-p* (read-dictionary))) - - -(defun spell-root-word (index) - "Return the root word corresponding to a dictionary entry at index." - (let* ((start (descriptor-string-start index)) - (end (+ start (the fixnum (ldb stored-length-byte - (the fixnum (descriptor-ref index))))))) - (declare (fixnum start end)) - (subseq (the simple-string *string-table*) start end))) - - -(eval-when (compile eval) -(defmacro check-closeness (word word-len closeness-list) - `(if (spell-try-word ,word ,word-len) - (pushnew (subseq ,word 0 ,word-len) ,closeness-list :test #'string=))) -) ;eval-when - -(defconstant spell-alphabet - (list #\A #\B #\C #\D #\E #\F #\G #\H - #\I #\J #\K #\L #\M #\N #\O #\P - #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) - -;;; SPELL-COLLECT-CLOSE-WORDS Returns a list of all "close" correctly spelled -;;; words. The definition of "close" is at the beginning of the file, and -;;; there are four sections to this function which collect each of the four -;;; different kinds of close words. -;;; -(defun spell-collect-close-words (word) - "Returns a list of all \"close\" correctly spelled words. This has the - same contraints as SPELL-TRY-WORD, which you have probably already called - if you are calling this." - (declare (simple-string word)) - (let* ((word-len (length word)) - (word-len--1 (1- word-len)) - (word-len-+1 (1+ word-len)) - (result ()) - (correcting-buffer (make-string max-entry-length))) - (declare (simple-string correcting-buffer) - (fixnum word-len word-len--1 word-len-+1)) - (replace correcting-buffer word :end1 word-len :end2 word-len) - - ;; Misspelled because one letter is different. - (dotimes (i word-len) - (do ((save-char (schar correcting-buffer i)) - (alphabet spell-alphabet (cdr alphabet))) - ((null alphabet) - (setf (schar correcting-buffer i) save-char)) - (setf (schar correcting-buffer i) (car alphabet)) - (check-closeness correcting-buffer word-len result))) - - ;; Misspelled because two adjacent letters are transposed. - (dotimes (i word-len--1) - (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i))) - (check-closeness correcting-buffer word-len result) - (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i)))) - - ;; Misspelled because of extraneous letter. - (replace correcting-buffer word - :start2 1 :end1 word-len--1 :end2 word-len) - (check-closeness correcting-buffer word-len--1 result) - (dotimes (i word-len--1) - (setf (schar correcting-buffer i) (schar word i)) - (replace correcting-buffer word - :start1 (1+ i) :start2 (+ i 2) :end1 word-len--1 :end2 word-len) - (check-closeness correcting-buffer word-len--1 result)) - - ;; Misspelled because a letter is missing. - (replace correcting-buffer word - :start1 1 :end1 word-len-+1 :end2 word-len) - (dotimes (i word-len-+1) - (do ((alphabet spell-alphabet (cdr alphabet))) - ((null alphabet) - (rotatef (schar correcting-buffer i) - (schar correcting-buffer (1+ i)))) - (setf (schar correcting-buffer i) (car alphabet)) - (check-closeness correcting-buffer word-len-+1 result))) - result)) - -;;; SPELL-TRY-WORD The literal 4 is not a constant defined somewhere since it -;;; is part of the definition of the function of looking up words. -;;; TRY-WORD-ENDINGS relies on the guarantee that word-len is at least 4. -;;; -(defun spell-try-word (word word-len) - "See if the word or an appropriate root is in the spelling dicitionary. - Word-len must be inclusively in the range 2..max-entry-length." - (or (lookup-entry word word-len) - (if (>= (the fixnum word-len) 4) - (try-word-endings word word-len)))) - - - -;;;; Divining Correct Spelling - -(eval-when (compile eval) - -(defmacro setup-root-buffer (word buffer root-len) - `(replace ,buffer ,word :end1 ,root-len :end2 ,root-len)) - -(defmacro try-root (word root-len flag-mask) - (let ((result (gensym))) - `(let ((,result (lookup-entry ,word ,root-len))) - (if (and ,result (descriptor-flag ,result ,flag-mask)) - (return (values ,result ,flag-mask)))))) - -;;; TRY-MODIFIED-ROOT is used for root words that become truncated -;;; when suffixes are added (e.g., skate => skating). Char-idx is the last -;;; character in the root that has to typically be changed from a #\I to a -;;; #\Y or #\E. -;;; -(defmacro try-modified-root (word buffer root-len flag-mask char-idx new-char) - (let ((root-word (gensym))) - `(let ((,root-word (setup-root-buffer ,word ,buffer ,root-len))) - (setf (schar ,root-word ,char-idx) ,new-char) - (try-root ,root-word ,root-len ,flag-mask)))) - -) ;eval-when - - -(defvar *rooting-buffer* (make-string max-entry-length)) - -;;; TRY-WORD-ENDINGS takes a word that is at least of length 4 and -;;; returns multiple values on success (the index where the word's root's -;;; descriptor starts and :used-flag), otherwise nil. It looks at -;;; characters from the end to the beginning of the word to determine if it -;;; has any known suffixes. This is a VERY simple finite state machine -;;; where all of the suffixes are narrowed down to one possible one in at -;;; most two state changes. This is a PROG form for speed, and in some sense, -;;; readability. The states of the machine are the flag names that denote -;;; suffixes. The two points of branching to labels are the very beginning -;;; of the PROG and the S state. This is a fairly straight forward -;;; implementation of the flag rules presented at the beginning of this -;;; file, with char-idx checks, so we do not index the string below zero. - -(defun try-word-endings (word word-len) - (declare (simple-string word) - (fixnum word-len)) - (prog* ((char-idx (1- word-len)) - (char (schar word char-idx)) - (rooting-buffer *rooting-buffer*) - flag-mask) - (declare (simple-string rooting-buffer) - (fixnum char-idx)) - (case char - (#\S (go S)) ;This covers over half of the possible endings - ;by branching off the second to last character - ;to other flag states that have plural endings. - (#\R (setf flag-mask R-mask) ;"er" and "ier" - (go D-R-Z-FLAG)) - (#\T (go T-FLAG)) ;"est" and "iest" - (#\D (setf flag-mask D-mask) ;"ed" and "ied" - (go D-R-Z-FLAG)) - (#\H (go H-FLAG)) ;"th" and "ieth" - (#\N (setf flag-mask N-mask) ;"ion", "ication", and "en" - (go N-X-FLAG)) - (#\G (setf flag-mask G-mask) ;"ing" - (go G-J-FLAG)) - (#\Y (go Y-FLAG)) ;"ly" - (#\E (go V-FLAG))) ;"ive" - (return nil) - - S - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (if (char= char #\Y) - (if (set-member-p (schar word (1- char-idx)) *aeiou*) - (try-root word (1+ char-idx) S-mask) - (return nil)) - (if (not (set-member-p char *sxzh*)) - (try-root word (1+ char-idx) S-mask))) - (case char - (#\E (go S-FLAG)) ;"es" and "ies" - (#\R (setf flag-mask Z-mask) ;"ers" and "iers" - (go D-R-Z-FLAG)) - (#\G (setf flag-mask J-mask) ;"ings" - (go G-J-FLAG)) - (#\S (go P-FLAG)) ;"ness" and "iness" - (#\N (setf flag-mask X-mask) ;"ions", "ications", and "ens" - (go N-X-FLAG)) - (#\' (try-root word char-idx M-mask))) - (return nil) - - S-FLAG - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (if (set-member-p char *sxzh*) - (try-root word (1+ char-idx) S-mask)) - (if (and (char= char #\I) - (not (set-member-p (schar word (1- char-idx)) *aeiou*))) - (try-modified-root word rooting-buffer (1+ char-idx) - S-mask char-idx #\Y)) - (return nil) - - D-R-Z-FLAG - (if (char/= (schar word (1- char-idx)) #\E) (return nil)) - (try-root word char-idx flag-mask) - (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) - (setf char (schar word char-idx)) - (if (char= char #\Y) - (if (set-member-p (schar word (1- char-idx)) *aeiou*) - (try-root word (1+ char-idx) flag-mask) - (return nil)) - (if (char/= (schar word char-idx) #\E) - (try-root word (1+ char-idx) flag-mask))) - (if (and (char= char #\I) - (not (set-member-p (schar word (1- char-idx)) *aeiou*))) - (try-modified-root word rooting-buffer (1+ char-idx) - flag-mask char-idx #\Y)) - (return nil) - - P-FLAG - (if (or (char/= (schar word (1- char-idx)) #\E) - (char/= (schar word (- char-idx 2)) #\N)) - (return nil)) - (if (<= (setf char-idx (- char-idx 3)) 0) (return nil)) - (setf char (schar word char-idx)) - (if (char= char #\Y) - (if (set-member-p (schar word (1- char-idx)) *aeiou*) - (try-root word (1+ char-idx) P-mask) - (return nil))) - (try-root word (1+ char-idx) P-mask) - (if (and (char= char #\I) - (not (set-member-p (schar word (1- char-idx)) *aeiou*))) - (try-modified-root word rooting-buffer (1+ char-idx) - P-mask char-idx #\Y)) - (return nil) - - G-J-FLAG - (if (< char-idx 3) (return nil)) - (setf char-idx (- char-idx 2)) - (setf char (schar word char-idx)) - (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\N)) - (return nil)) - (if (char/= (schar word (1- char-idx)) #\E) - (try-root word char-idx flag-mask)) - (try-modified-root word rooting-buffer (1+ char-idx) - flag-mask char-idx #\E) - (return nil) - - N-X-FLAG - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (cond ((char= char #\E) - (setf char (schar word (1- char-idx))) - (if (and (char/= char #\Y) (char/= char #\E)) - (try-root word char-idx flag-mask)) - (return nil)) - ((char= char #\O) - (if (char= (schar word (1- char-idx)) #\I) - (try-modified-root word rooting-buffer char-idx - flag-mask (1- char-idx) #\E) - (return nil)) - (if (< char-idx 5) (return nil)) - (if (or (char/= (schar word (- char-idx 2)) #\T) - (char/= (schar word (- char-idx 3)) #\A) - (char/= (schar word (- char-idx 4)) #\C) - (char/= (schar word (- char-idx 5)) #\I)) - (return nil) - (setf char-idx (- char-idx 4))) - (try-modified-root word rooting-buffer char-idx - flag-mask (1- char-idx) #\Y)) - (t (return nil))) - - T-FLAG - (if (or (char/= (schar word (1- char-idx)) #\S) - (char/= (schar word (- char-idx 2)) #\E)) - (return nil) - (setf char-idx (1- char-idx))) - (try-root word char-idx T-mask) - (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) - (setf char (schar word char-idx)) - (if (char= char #\Y) - (if (set-member-p (schar word (1- char-idx)) *aeiou*) - (try-root word (1+ char-idx) T-mask) - (return nil)) - (if (char/= (schar word char-idx) #\E) - (try-root word (1+ char-idx) T-mask))) - (if (and (char= char #\I) - (not (set-member-p (schar word (1- char-idx)) *aeiou*))) - (try-modified-root word rooting-buffer (1+ char-idx) - T-mask char-idx #\Y)) - (return nil) - - H-FLAG - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (if (char/= char #\T) (return nil)) - (if (char/= (schar word (1- char-idx)) #\Y) - (try-root word char-idx H-mask)) - (if (and (char= (schar word (1- char-idx)) #\E) - (char= (schar word (- char-idx 2)) #\I)) - (try-modified-root word rooting-buffer (1- char-idx) - H-mask (- char-idx 2) #\Y)) - (return nil) - - Y-FLAG - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (if (char= char #\L) - (try-root word char-idx Y-mask)) - (return nil) - - V-FLAG - (setf char-idx (- char-idx 2)) - (setf char (schar word char-idx)) - (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\V)) - (return nil)) - (if (char/= (schar word (1- char-idx)) #\E) - (try-root word char-idx V-mask)) - (try-modified-root word rooting-buffer (1+ char-idx) - V-mask char-idx #\E) - (return nil))) - - - -;;; DESCRIPTOR-FLAG returns t or nil based on whether the flag is on. -;;; From the diagram at the beginning of the file, we see that the flags -;;; are stored two words off of the first word in the descriptor unit for -;;; an entry. -;;; -(defun descriptor-flag (descriptor-start flag-mask) - (not (zerop - (the fixnum - (logand - (the fixnum (descriptor-ref (+ 2 (the fixnum descriptor-start)))) - (the fixnum flag-mask)))))) - - -;;;; Looking up Trials - -(eval-when (compile eval) - -;;; SPELL-STRING= determines if string1 and string2 are the same. Before -;;; it is called it is known that they are both of (- end1 0) length, and -;;; string2 is in system space. This is used in FOUND-ENTRY-P. -;;; -(defmacro spell-string= (string1 string2 end1 start2) - (let ((idx1 (gensym)) - (idx2 (gensym))) - `(do ((,idx1 0 (1+ ,idx1)) - (,idx2 ,start2 (1+ ,idx2))) - ((= ,idx1 ,end1) t) - (declare (fixnum ,idx1 ,idx2)) - (unless (= (the fixnum (char-code (schar ,string1 ,idx1))) - (the fixnum (string-sapref ,string2 ,idx2))) - (return nil))))) - -;;; FOUND-ENTRY-P determines if entry is what is described at idx. -;;; Hash-and-length is 16 bits that look just like the first word of any -;;; entry's descriptor unit (see diagram at the beginning of the file). If -;;; the word stored at idx and entry have the same hash bits and length, -;;; then we compare characters to see if they are the same. -;;; -(defmacro found-entry-p (idx entry entry-len hash-and-length) - `(if (= (the fixnum (descriptor-ref ,idx)) - (the fixnum ,hash-and-length)) - (spell-string= ,entry *string-table* ,entry-len - (descriptor-string-start ,idx)))) - -(defmacro hash2-increment (hash) - `(- (the fixnum *dictionary-size*) - 2 - (the fixnum (rem ,hash (- (the fixnum *dictionary-size*) 2))))) - -(defmacro hash2-loop ((location-var contents-var) - loc hash zero-contents-form - &optional body-form (for-insertion-p nil)) - (let ((incr (gensym))) - `(let* ((,incr (hash2-increment ,hash)) - (,location-var ,loc) - ,contents-var) - (declare (fixnum ,location-var ,contents-var ,incr)) - (loop (setf ,location-var - (rem (+ ,location-var ,incr) (the fixnum *dictionary-size*))) - (setf ,contents-var (dictionary-ref ,location-var)) - (if (zerop ,contents-var) (return ,zero-contents-form)) - ,@(if for-insertion-p - `((if (= ,contents-var -1) (return ,zero-contents-form)))) - (if (= ,location-var ,loc) (return nil)) - ,@(if body-form `(,body-form)))))) - -) ;eval-when - - -;;; LOOKUP-ENTRY returns the index of the first element of entry's -;;; descriptor unit on success, otherwise nil. -;;; -(defun lookup-entry (entry &optional len) - (declare (simple-string entry)) - (let* ((entry-len (or len (length entry))) - (hash (string-hash entry entry-len)) - (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) - stored-hash-byte - (the fixnum entry-len))) - (loc (rem hash (the fixnum *dictionary-size*))) - (loc-contents (dictionary-ref loc))) - (declare (fixnum entry-len hash hash-and-len loc)) - (cond ((zerop loc-contents) nil) - ((found-entry-p loc-contents entry entry-len hash-and-len) - loc-contents) - (t - (hash2-loop (loop-loc loc-contents) loc hash - nil - (if (found-entry-p loc-contents entry entry-len hash-and-len) - (return loc-contents))))))) - -;;;; Binary File Reading - -(defparameter default-binary-dictionary - "/usr/misc/.lisp/lib/spell-dictionary.bin") - -;;; This is the first thing in a spell binary dictionary file to serve as a -;;; quick check of its proposed contents. This particular number is -;;; "BILLS" on a calculator held upside-down. -;;; -(defconstant magic-file-id 57718) - -;;; These constants are derived from the order things are written to the -;;; binary dictionary in Spell-Build.Lisp. -;;; -(defconstant magic-file-id-loc 0) -(defconstant dictionary-size-loc 1) -(defconstant descriptors-size-loc 2) -(defconstant string-table-size-low-byte-loc 3) -(defconstant string-table-size-high-byte-loc 4) -(defconstant file-header-bytes 10) - -;;; Initially, there are no free descriptor elements and string table bytes, -;;; but when these structures are grown, they are grown by more than that -;;; which is necessary. -;;; -(defvar *free-descriptor-elements* 0) -(defvar *free-string-table-bytes* 0) - -;;; READ-DICTIONARY opens the dictionary and sets up the global structures -;;; manifesting the spelling dictionary. When computing the start addresses -;;; of these structures, we multiply by two since their sizes are in 16bit -;;; lengths while the RT is 8bit-byte addressable. -;;; -(defun read-dictionary (&optional (f default-binary-dictionary)) - (when *dictionary-read-p* - (setf *dictionary-read-p* nil) - (deallocate-bytes (system-address *dictionary*) - (* 2 (the fixnum *dictionary-size*))) - (deallocate-bytes (system-address *descriptors*) - (* 2 (the fixnum - (+ (the fixnum *descriptors-size*) - (the fixnum *free-descriptor-elements*))))) - (deallocate-bytes (system-address *string-table*) - (+ (the fixnum *string-table-size*) - (the fixnum *free-string-table-bytes*)))) - (setf *free-descriptor-elements* 0) - (setf *free-string-table-bytes* 0) - (let* ((fd (open-dictionary f)) - (header-info (read-dictionary-structure fd file-header-bytes))) - (unless (= (sapref header-info magic-file-id-loc) magic-file-id) - (deallocate-bytes (system-address header-info) file-header-bytes) - (error "File is not a dictionary: ~S." f)) - (setf *dictionary-size* (sapref header-info dictionary-size-loc)) - (setf *descriptors-size* (sapref header-info descriptors-size-loc)) - (setf *string-table-size* (sapref header-info string-table-size-low-byte-loc)) - (setf (ldb (byte 12 16) (the fixnum *string-table-size*)) - (the fixnum (sapref header-info string-table-size-high-byte-loc))) - (deallocate-bytes (system-address header-info) file-header-bytes) - (setf *dictionary* - (read-dictionary-structure fd (* 2 (the fixnum *dictionary-size*)))) - (setf *descriptors* - (read-dictionary-structure fd (* 2 (the fixnum *descriptors-size*)))) - (setf *string-table* (read-dictionary-structure fd *string-table-size*)) - (setf *dictionary-read-p* t) - (close-dictionary fd))) diff --git a/hemlock/spell-rt.lisp b/hemlock/spell-rt.lisp deleted file mode 100644 index 6a066541bf1396c39e3d2990f1b34f698bfb23de..0000000000000000000000000000000000000000 --- a/hemlock/spell-rt.lisp +++ /dev/null @@ -1,93 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Spell -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; -;;; This file contains system dependent primitives for the spelling checking/ -;;; correcting code in Spell-Correct.Lisp, Spell-Augment.Lisp, and -;;; Spell-Build.Lisp. - -(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) - - -;;;; System Area Referencing and Setting - -(eval-when (compile eval) - -;;; MAKE-SAP returns pointers that *dictionary*, *descriptors*, and -;;; *string-table* are bound to. Address is in the system area. -;;; -(defmacro make-sap (address) - `(lisp::fixnum-to-sap ,address)) - -(defmacro system-address (sap) - `(lisp::sap-to-fixnum ,sap)) - - -(defmacro allocate-bytes (count) - `(make-sap (lisp::do-validate 0 ,count -1))) - -(defmacro deallocate-bytes (address byte-count) - `(mach::vm_deallocate lisp::*task-self* ,address ,byte-count)) - - -(defmacro sapref (sap offset) - `(%primitive 16bit-system-ref ,sap ,offset)) - -(defsetf sapref (sap offset) (value) - `(%primitive 16bit-system-set ,sap ,offset ,value)) - - -(defmacro sap-replace (dst-string src-string src-start dst-start dst-end) - `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end)) - -(defmacro string-sapref (sap index) - `(%primitive 8bit-system-ref ,sap ,index)) - - - -;;;; Primitive String Hashing - -;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes -;;; an end argument, so we do not have to use SXHASH. SXHASH would mean -;;; doing a SUBSEQ of entry. -;;; -(defmacro string-hash (string length) - `(%primitive sxhash-simple-substring ,string ,length)) - -) ;eval-when - - - -;;;; Binary Dictionary File I/O - -(defun open-dictionary (f) - (multiple-value-bind (filename existsp) - (lisp::predict-name f :for-input) - (unless existsp (error "Cannot find dictionary -- ~S." filename)) - (multiple-value-bind (fd err) - (mach:unix-open filename mach:o_rdonly 0) - (unless fd - (error "Opening ~S failed: ~A." filename err)) - (multiple-value-bind (winp dev-or-err) (mach:unix-fstat fd) - (unless winp (error "Opening ~S failed: ~A." filename dev-or-err)) - fd)))) - -(defun close-dictionary (fd) - (mach:unix-close fd)) - -(defun read-dictionary-structure (fd bytes) - (let* ((structure (allocate-bytes bytes))) - (multiple-value-bind (read-bytes err) - (mach:unix-read fd structure bytes) - (when (or (null read-bytes) (not (= bytes read-bytes))) - (deallocate-bytes (system-address structure) bytes) - (error "Reading dictionary structure failed: ~A." err)) - structure))) diff --git a/hemlock/spellcoms.lisp b/hemlock/spellcoms.lisp deleted file mode 100644 index 2bf7777571489320082a12fd5968361f206cab04..0000000000000000000000000000000000000000 --- a/hemlock/spellcoms.lisp +++ /dev/null @@ -1,811 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles and Rob Maclachlan. -;;; -;;; This file contains the code to implement commands using the spelling -;;; checking/correcting stuff in Spell-Corr.Lisp and the dictionary -;;; augmenting stuff in Spell-Augment.Lisp. - -(in-package 'hemlock) - - - -(defstruct (spell-info (:print-function print-spell-info) - (:constructor make-spell-info (pathname))) - pathname ;Dictionary file. - insertions) ;Incremental insertions for this dictionary. - -(defun print-spell-info (obj str n) - (declare (ignore n)) - (format str "#<Spell Info ~S>" (namestring (spell-info-pathname obj)))) - - -(defattribute "Spell Word Character" - "One if the character is one that is present in the spell dictionary, - zero otherwise.") - -(do-alpha-chars (c :both) - (setf (character-attribute :spell-word-character c) 1)) -(setf (character-attribute :spell-word-character #\') 1) - - -(defvar *spelling-corrections* (make-hash-table :test #'equal) - "Mapping from incorrect words to their corrections.") - -(defvar *ignored-misspellings* (make-hash-table :test #'equal) - "A hashtable with true values for words that will be quietly ignored when - they appear.") - -(defhvar "Spell Ignore Uppercase" - "If true, then \"Check Word Spelling\" and \"Correct Buffer Spelling\" will - ignore unknown words that are all uppercase. This is useful for - abbreviations and cryptic formatter directives." - :value nil) - - - -;;;; Basic Spelling Correction Command (Esc-$ in EMACS) - -(defcommand "Check Word Spelling" (p) - "Check the spelling of the previous word and offer possible corrections - if the word in unknown. To add words to the dictionary from a text file see - the command \"Augment Spelling Dictionary\"." - "Check the spelling of the previous word and offer possible correct - spellings if the word is known to be misspelled." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (let* ((region (spell-previous-word (current-point) nil)) - (word (if region - (region-to-string region) - (editor-error "No previous word."))) - (folded (string-upcase word))) - (message "Checking spelling of ~A." word) - (unless (check-out-word-spelling word folded) - (get-word-correction (region-start region) word folded)))) - - -;;;; Auto-Spell mode: - -(defhvar "Check Word Spelling Beep" - "If true, \"Auto Check Word Spelling\" will beep when an unknown word is - found." - :value t) - -(defhvar "Correct Unique Spelling Immediately" - "If true, \"Auto Check Word Spelling\" will immediately attempt to correct any - unknown word, automatically making the correction if there is only one - possible." - :value t) - - -(defhvar "Default User Spelling Dictionary" - "This is the pathname of a dictionary to read the first time \"Spell\" mode - is entered in a given editing session. When \"Set Buffer Spelling - Dictionary\" or the \"dictionary\" file option is used to specify a - dictionary, this default one is read also. It defaults to nil." - :value nil) - -(defvar *default-user-dictionary-read-p* nil) - -(defun maybe-read-default-user-spelling-dictionary () - (let ((default-dict (value default-user-spelling-dictionary))) - (when (and default-dict (not *default-user-dictionary-read-p*)) - (spell:maybe-read-spell-dictionary) - (spell:spell-read-dictionary (truename default-dict)) - (setf *default-user-dictionary-read-p* t)))) - - -(defmode "Spell" - :transparent-p t :precedence 1.0 :setup-function 'spell-mode-setup) - -(defun spell-mode-setup (buffer) - (defhvar "Buffer Misspelled Words" - "This variable holds a ring of marks pointing to misspelled words." - :buffer buffer :value (make-ring 10 #'delete-mark)) - (maybe-read-default-user-spelling-dictionary)) - -(defcommand "Auto Spell Mode" (p) - "Toggle \"Spell\" mode in the current buffer. When in \"Spell\" mode, - the spelling of each word is checked after it is typed." - "Toggle \"Spell\" mode in the current buffer." - (declare (ignore p)) - (setf (buffer-minor-mode (current-buffer) "Spell") - (not (buffer-minor-mode (current-buffer) "Spell")))) - - -(defcommand "Auto Check Word Spelling" (p) - "Check the spelling of the previous word and display a message in the echo - area if the word is not in the dictionary. To add words to the dictionary - from a text file see the command \"Augment Spelling Dictionary\". If a - replacement for an unknown word has previously been specified, then the - replacement will be made immediately. If \"Correct Unique Spelling - Immediately\" is true, then this command will immediately correct words - which have a unique correction. If there is no obvious correction, then we - place the word in a ring buffer for access by the \"Correct Last Misspelled - Word\" command. If \"Check Word Spelling Beep\" is true, then this command - beeps when an unknown word is found, in addition to displaying the message." - "Check the spelling of the previous word, making obvious corrections, or - queuing the word in buffer-misspelled-words if we are at a loss." - (declare (ignore p)) - (unless (eq (last-command-type) :spell-check) - (spell:maybe-read-spell-dictionary) - (let ((region (spell-previous-word (current-point) t))) - (when region - (let* ((word (nstring-upcase (region-to-string region))) - (len (length word))) - (declare (simple-string word)) - (when (and (<= 2 len spell:max-entry-length) - (not (spell:spell-try-word word len))) - (let ((found (gethash word *spelling-corrections*)) - (save (region-to-string region))) - (cond (found - (undoable-replace-word (region-start region) save found) - (message "Corrected ~S to ~S." save found) - (when (value check-word-spelling-beep) (beep))) - ((and (value spell-ignore-uppercase) - (every #'upper-case-p save)) - (unless (gethash word *ignored-misspellings*) - (setf (gethash word *ignored-misspellings*) t) - (message "Ignoring ~S." save))) - (t - (let ((close (spell:spell-collect-close-words word))) - (cond ((and close - (null (rest close)) - (value correct-unique-spelling-immediately)) - (let ((fix (first close))) - (undoable-replace-word (region-start region) - save fix) - (message "Corrected ~S to ~S." save fix))) - (t - (ring-push (copy-mark (region-end region) - :right-inserting) - (value buffer-misspelled-words)) - (let ((nclose - (do ((i 0 (1+ i)) - (words close (cdr words)) - (nwords () (cons (list i (car words)) - nwords))) - ((null words) (nreverse nwords))))) - (message - "Word ~S not found.~ - ~@[ Corrections:~:{ ~D=~A~}~]" - save nclose))))) - (when (value check-word-spelling-beep) (beep)))))))))) - (setf (last-command-type) :spell-check)) - -(defcommand "Correct Last Misspelled Word" (p) - "Fix a misspelling found by \"Auto Check Word Spelling\". This prompts for - a single character command to determine which action to take to correct the - problem." - "Prompt for a single character command to determine how to fix up a - misspelling detected by Check-Word-Spelling-Command." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (do ((info (value spell-information))) - ((sub-correct-last-misspelled-word info)))) - -(defun sub-correct-last-misspelled-word (info) - (let* ((missed (value buffer-misspelled-words)) - (region (cond ((zerop (ring-length missed)) - (editor-error "No recently misspelled word.")) - ((spell-previous-word (ring-ref missed 0) t)) - (t (editor-error "No recently misspelled word.")))) - (word (region-to-string region)) - (folded (string-upcase word)) - (point (current-point)) - (save (copy-mark point)) - (res t)) - (declare (simple-string word)) - (unwind-protect - (progn - (when (check-out-word-spelling word folded) - (delete-mark (ring-pop missed)) - (return-from sub-correct-last-misspelled-word t)) - (move-mark point (region-end region)) - (command-case (:prompt "Action: " :change-window nil - :help "Type a single character command to do something to the misspelled word.") - (#\C "Try to find a correction for this word." - (unless (get-word-correction (region-start region) word folded) - (reprompt))) - (#\I "Insert this word in the dictionary." - (spell:spell-add-entry folded) - (push folded (spell-info-insertions info)) - (message "~A inserted in the dictionary." word)) - (#\R "Prompt for a word to replace this word with." - (let ((s (prompt-for-string :prompt "Replace with: " - :default word - :help "Type a string to replace occurrences of this word with."))) - (delete-region region) - (insert-string point s) - (setf (gethash folded *spelling-corrections*) s))) - (:cancel "Ignore this word and go to the previous misspelled word." - (setq res nil)) - (:recursive-edit - "Go into a recursive edit and leave when it exits." - (do-recursive-edit)) - ((:exit #\Q) "Exit and forget about this word.") - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - "Choose this numbered word as the correct spelling." - (let ((num (digit-char-p *last-character-typed*)) - (close-words (spell:spell-collect-close-words folded))) - (cond ((> num (length close-words)) - (editor-error "Choice out of range.")) - (t (let ((s (nth num close-words))) - (setf (gethash folded *spelling-corrections*) s) - (undoable-replace-word (region-start region) - word s))))))) - (delete-mark (ring-pop missed)) - res) - (move-mark point save) - (delete-mark save)))) - -(defhvar "Spelling Un-Correct Prompt for Insert" - "When this is set, \"Undo Last Spelling Correction\" will prompt before - inserting the old word into the dictionary." - :value nil) - -(defcommand "Undo Last Spelling Correction" (p) - "Undo the last incremental spelling correction. - The \"correction\" is replaced with the old word, and the old word is - inserted in the dictionary. When \"Spelling Un-Correct Prompt for Insert\" - is set, the user is asked about inserting the old word. Any automatic - replacement for the old word is eliminated." - "Undo the last incremental spelling correction, nuking any undesirable - side-effects." - (declare (ignore p)) - (unless (hemlock-bound-p 'last-spelling-correction-mark) - (editor-error "No last spelling correction.")) - (let ((mark (value last-spelling-correction-mark)) - (words (value last-spelling-correction-words))) - (unless words - (editor-error "No last spelling correction.")) - (let* ((new (car words)) - (old (cdr words)) - (folded (string-upcase old))) - (declare (simple-string old new folded)) - (remhash folded *spelling-corrections*) - (delete-characters mark (length new)) - (insert-string mark old) - (setf (value last-spelling-correction-words) nil) - (when (or (not (value spelling-un-correct-prompt-for-insert)) - (prompt-for-y-or-n - :prompt (list "Insert ~A into spelling dictionary? " folded) - :default t - :default-string "Y")) - (push folded (spell-info-insertions (value spell-information))) - (spell:maybe-read-spell-dictionary) - (spell:spell-add-entry folded) - (message "Added ~S to spelling dictionary." old))))) - - -;;; Check-Out-Word-Spelling -- Internal -;;; -;;; Return Nil if Word is a candidate for correction, otherwise -;;; return T and message as to why it isn't. -;;; -(defun check-out-word-spelling (word folded) - (declare (simple-string word)) - (let ((len (length word))) - (cond ((= len 1) - (message "Single character words are not in the dictionary.") t) - ((> len spell:max-entry-length) - (message "~A is too long for the dictionary." word) t) - (t - (multiple-value-bind (idx flagp) (spell:spell-try-word folded len) - (when idx - (message "Found it~:[~; because of ~A~]." flagp - (spell:spell-root-word idx)) - t)))))) - -;;; Get-Word-Correction -- Internal -;;; -;;; Find all known close words to the either unknown or incorrectly -;;; spelled word we are checking. Word is the unmunged word, and Folded is -;;; the uppercased word. Mark is a mark which points to the beginning of -;;; the offending word. Return True if we successfully corrected the word. -;;; -(defun get-word-correction (mark word folded) - (let ((close-words (spell:spell-collect-close-words folded))) - (declare (list close-words)) - (if close-words - (with-pop-up-display (s :height 3) - (do ((i 0 (1+ i)) - (words close-words (cdr words))) - ((null words)) - (format s "~36R=~A " i (car words))) - (finish-output s) - (let* ((char (prompt-for-character :prompt "Correction choice: ")) - (num (digit-char-p char 36))) - (cond ((not num) (return-from get-word-correction nil)) - ((> num (length close-words)) - (editor-error "Choice out of range.")) - (t - (let ((s (nth num close-words))) - (setf (gethash folded *spelling-corrections*) s) - (undoable-replace-word mark word s))))) - (return-from get-word-correction t)) - (with-pop-up-display (s :height 1) - (write-line "No corrections found." s) - nil)))) - - -;;; Undoable-Replace-Word -- Internal -;;; -;;; Like Spell-Replace-Word, but makes annotations in buffer local variables -;;; so that "Undo Last Spelling Correction" can undo it. -;;; -(defun undoable-replace-word (mark old new) - (unless (hemlock-bound-p 'last-spelling-correction-mark) - (let ((buffer (current-buffer))) - (defhvar "Last Spelling Correction Mark" - "This variable holds a park pointing to the last spelling correction." - :buffer buffer :value (copy-mark (buffer-start-mark buffer))) - (defhvar "Last Spelling Correction Words" - "The replacement done for the last correction: (new . old)." - :buffer buffer :value nil))) - (move-mark (value last-spelling-correction-mark) mark) - (setf (value last-spelling-correction-words) (cons new old)) - (spell-replace-word mark old new)) - - -;;;; Buffer Correction - -(defvar *spell-word-characters* - (make-array char-code-limit :element-type 'bit :initial-element 0) - "Characters that are legal in a word for spelling checking purposes.") - -(do-alpha-chars (c :both) - (setf (sbit *spell-word-characters* (char-code c)) 1)) -(setf (sbit *spell-word-characters* (char-code #\')) 1) - - -(defcommand "Correct Buffer Spelling" (p) - "Correct spelling over whole buffer. A log of the found misspellings is - kept in the buffer \"Spell Corrections\". For each unknown word the - user may accept it, insert it in the dictionary, correct its spelling - with one of the offered possibilities, replace the word with a user - supplied word, or go into a recursive edit. Words may be added to the - dictionary in advance from a text file (see the command \"Augment - Spelling Dictionary\")." - "Correct spelling over whole buffer." - (declare (ignore p)) - (clrhash *ignored-misspellings*) - (let* ((buffer (current-buffer)) - (log (or (make-buffer "Spelling Corrections") - (getstring "Spelling Corrections" *buffer-names*))) - (point (buffer-end (buffer-point log))) - (*standard-output* (make-hemlock-output-stream point)) - (window (or (car (buffer-windows log)) (make-window point)))) - (format t "~&Starting spelling checking of buffer ~S.~2%" - (buffer-name buffer)) - (spell:maybe-read-spell-dictionary) - (correct-buffer-spelling buffer window) - (delete-window window) - (close *standard-output*))) - -;;; CORRECT-BUFFER-SPELLING scans through buffer a line at a time, grabbing the -;;; each line's string and breaking it up into words using the -;;; *spell-word-characters* mask. We try the spelling of each word, and if it -;;; is unknown, we call FIX-WORD and resynchronize when it returns. -;;; -(defun correct-buffer-spelling (buffer window) - (do ((line (mark-line (buffer-start-mark buffer)) (line-next line)) - (info (if (hemlock-bound-p 'spell-information :buffer buffer) - (variable-value 'spell-information :buffer buffer) - (value spell-information))) - (mask *spell-word-characters*) - (word (make-string spell:max-entry-length))) - ((null line)) - (declare (simple-bit-vector mask) (simple-string word)) - (block line - (let* ((string (line-string line)) - (length (length string))) - (declare (simple-string string)) - (do ((start 0 (or skip-apostrophes end)) - (skip-apostrophes nil nil) - end) - (nil) - ;; - ;; Find word start. - (loop - (when (= start length) (return-from line)) - (when (/= (bit mask (char-code (schar string start))) 0) (return)) - (incf start)) - ;; - ;; Find the end. - (setq end (1+ start)) - (loop - (when (= end length) (return)) - (when (zerop (bit mask (char-code (schar string end)))) (return)) - (incf end)) - (multiple-value-setq (end skip-apostrophes) - (correct-buffer-word-end string start end)) - ;; - ;; Check word. - (let ((word-len (- end start))) - (cond - ((= word-len 1)) - ((> word-len spell:max-entry-length) - (format t "Not checking ~S -- too long for dictionary.~2%" - word)) - (t - ;; - ;; Copy the word and uppercase it. - (do* ((i (1- end) (1- i)) - (j (1- word-len) (1- j))) - ((zerop j) - (setf (schar word 0) (char-upcase (schar string i)))) - (setf (schar word j) (char-upcase (schar string i)))) - (unless (spell:spell-try-word word word-len) - (move-to-position (current-point) start line) - (fix-word (subseq word 0 word-len) (subseq string start end) - window info) - (let ((point (current-point))) - (setq end (mark-charpos point) - line (mark-line point) - string (line-string line) - length (length string)))))))))))) - -;;; CORRECT-BUFFER-WORD-END takes a line string from CORRECT-BUFFER-SPELLING, a -;;; start, and a end. It places end to exclude from the word apostrophes used -;;; for quotation marks, possessives, and funny plurals (e.g., A's and AND's). -;;; Every word potentially can be followed by "'s", and any clown can use the -;;; `` '' Scribe ligature. This returns the value to use for end of the word -;;; and the value to use as the end when continuing to find the next word in -;;; string. -;;; -(defun correct-buffer-word-end (string start end) - (cond ((and (> (- end start) 2) - (char= (char-upcase (schar string (1- end))) #\S) - (char= (schar string (- end 2)) #\')) - ;; Use roots of possessives and funny plurals (e.g., A's and AND's). - (values (- end 2) end)) - (t - ;; Maybe backup over apostrophes used for quotation marks. - (do ((i (1- end) (1- i))) - ((= i start) (values end end)) - (when (char/= (schar string i) #\') - (return (values (1+ i) end))))))) - -;;; Fix-Word -- Internal -;;; -;;; Handles the case where the word has a known correction. If is does -;;; not then call Correct-Buffer-Word-Not-Found. In either case, the -;;; point is left at the place to resume checking. -;;; -(defun fix-word (word unfolded-word window info) - (declare (simple-string word unfolded-word)) - (let ((correction (gethash word *spelling-corrections*)) - (mark (current-point))) - (cond (correction - (format t "Replacing ~S with ~S.~%" unfolded-word correction) - (spell-replace-word mark unfolded-word correction)) - ((and (value spell-ignore-uppercase) - (every #'upper-case-p unfolded-word)) - (character-offset mark (length word)) - (unless (gethash word *ignored-misspellings*) - (setf (gethash word *ignored-misspellings*) t) - (format t "Ignoring ~S.~%" unfolded-word))) - (t - (correct-buffer-word-not-found word unfolded-word window info))))) - -(defun correct-buffer-word-not-found (word unfolded-word window info) - (declare (simple-string word unfolded-word)) - (let* ((close-words (spell:spell-collect-close-words word)) - (close-words-len (length (the list close-words))) - (mark (current-point)) - (wordlen (length word))) - (format t "Unknown word: ~A~%" word) - (cond (close-words - (format t "~[~;A~:;Some~]~:* possible correction~[~; is~:;s are~]: " - close-words-len) - (if (= close-words-len 1) - (write-line (car close-words)) - (let ((n 0)) - (dolist (w close-words (terpri)) - (format t "~36R=~A " n w) - (incf n))))) - (t - (write-line "No correction possibilities found."))) - (let ((point (buffer-point (window-buffer window)))) - (unless (displayed-p point window) - (center-window window point))) - (command-case - (:prompt "Action: " - :help "Type a single letter command, or help character for help." - :change-window nil) - (#\I "Insert unknown word into dictionary for future lookup." - (spell:spell-add-entry word) - (push word (spell-info-insertions info)) - (format t "~S added to dictionary.~2%" word)) - (#\C "Correct the unknown word with possible correct spellings." - (unless close-words - (write-line "There are no possible corrections.") - (reprompt)) - (let ((num (if (= close-words-len 1) 0 - (digit-char-p (prompt-for-character - :prompt "Correction choice: ") - 36)))) - (unless num (reprompt)) - (when (> num close-words-len) - (beep) - (write-line "Response out of range.") - (reprompt)) - (let ((choice (nth num close-words))) - (setf (gethash word *spelling-corrections*) choice) - (spell-replace-word mark unfolded-word choice))) - (terpri)) - (#\A "Accept the word as correct (that is, ignore it)." - (character-offset mark wordlen)) - (#\R "Replace the unknown word with a supplied replacement." - (let ((s (prompt-for-string - :prompt "Replacement Word: " - :default unfolded-word - :help "String to replace the unknown word with."))) - (setf (gethash word *spelling-corrections*) s) - (spell-replace-word mark unfolded-word s)) - (terpri)) - (:recursive-edit - "Go into a recursive edit and resume correction where the point is left." - (do-recursive-edit))))) - -;;; Spell-Replace-Word -- Internal -;;; -;;; Replaces Old with New, starting at Mark. The case of Old is used -;;; to derive the new case. -;;; -(defun spell-replace-word (mark old new) - (declare (simple-string old new)) - (let ((res (cond ((lower-case-p (schar old 0)) - (string-downcase new)) - ((lower-case-p (schar old 1)) - (let ((res (string-downcase new))) - (setf (char res 0) (char-upcase (char res 0))) - res)) - (t - (string-upcase new))))) - (with-mark ((m mark :left-inserting)) - (delete-characters m (length old)) - (insert-string m res)))) - - -;;;; User Spelling Dictionaries. - -(defvar *pathname-to-spell-info* (make-hash-table :test #'equal) - "This maps dictionary files to spelling information.") - -(defhvar "Spell Information" - "This is the information about a spelling dictionary and its incremental - insertions." - :value (make-spell-info nil)) - -(define-file-option "Dictionary" (buffer file) - (let* ((dict (merge-pathnames - file - (make-pathname :defaults (buffer-default-pathname buffer) - :type "dict"))) - (dictp (probe-file dict))) - (if dictp - (set-buffer-spelling-dictionary-command nil dictp buffer) - (loud-message "Couldn't find dictionary ~A." (namestring dict))))) - -;;; SAVE-DICTIONARY-ON-WRITE is on the "Write File Hook" in buffers with -;;; the "dictionary" file option. -;;; -(defun save-dictionary-on-write (buffer) - (when (hemlock-bound-p 'spell-information :buffer buffer) - (save-spelling-insertions - (variable-value 'spell-information :buffer buffer)))) - - -(defcommand "Save Incremental Spelling Insertions" (p) - "Append incremental spelling dictionary insertions to a file. The file - is prompted for unless \"Set Buffer Spelling Dictionary\" has been - executed in the buffer." - "Append incremental spelling dictionary insertions to a file." - (declare (ignore p)) - (let* ((info (value spell-information)) - (file (or (spell-info-pathname info) - (value default-user-spelling-dictionary) - (prompt-for-file - :prompt "Dictionary File: " - :default (dictionary-name-default) - :must-exist nil - :help - "Name of the dictionary file to append dictionary insertions to.")))) - (save-spelling-insertions info file) - (let* ((ginfo (variable-value 'spell-information :global)) - (insertions (spell-info-insertions ginfo))) - (when (and insertions - (prompt-for-y-or-n - :prompt - `("Global spelling insertions exist.~%~ - Save these to ~A also? " - ,(namestring file) - :default t - :default-string "Y")) - (save-spelling-insertions ginfo file)))))) - -(defun save-spelling-insertions (info &optional - (name (spell-info-pathname info))) - (when (spell-info-insertions info) - (with-open-file (stream name - :direction :output :element-type 'string-char - :if-exists :append :if-does-not-exist :create) - (dolist (w (spell-info-insertions info)) - (write-line w stream))) - (setf (spell-info-insertions info) ()) - (message "Incremental spelling insertions for ~A written." - (namestring name)))) - -(defcommand "Set Buffer Spelling Dictionary" (p &optional file buffer) - "Prompts for the dictionary file to associate with the current buffer. - If this 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 \"Save Incremental Spelling Insertions\"." - "Sets the buffer's spelling dictionary and reads it if necessary." - (declare (ignore p)) - (maybe-read-default-user-spelling-dictionary) - (let* ((file (truename (or file - (prompt-for-file - :prompt "Dictionary File: " - :default (dictionary-name-default) - :help - "Name of the dictionary file to add into the current dictionary.")))) - (file-name (namestring file)) - (spell-info-p (gethash file-name *pathname-to-spell-info*)) - (spell-info (or spell-info-p (make-spell-info file))) - (buffer (or buffer (current-buffer)))) - (defhvar "Spell Information" - "This is the information about a spelling dictionary and its incremental - insertions." - :value spell-info :buffer buffer) - (add-hook write-file-hook 'save-dictionary-on-write) - (unless spell-info-p - (setf (gethash file-name *pathname-to-spell-info*) spell-info) - (read-spelling-dictionary-command nil file)))) - -(defcommand "Read Spelling Dictionary" (p &optional file) - "Adds entries to the dictionary from a file in the following format: - - entry1/flag1/flag2/flag3 - entry2 - entry3/flag1/flag2/flag3/flag4/flag5. - - The flags are single letter indicators of legal suffixes for the entry; - the available flags and their correct use may be found at the beginning - of spell-correct.lisp in the Hemlock sources. There must be exactly one - entry per line, and each line must be flushleft." - "Add entries to the dictionary from a text file in a specified format." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (spell:spell-read-dictionary - (or file - (prompt-for-file - :prompt "Dictionary File: " - :default (dictionary-name-default) - :help - "Name of the dictionary file to add into the current dictionary.")))) - -(defun dictionary-name-default () - (make-pathname :defaults (buffer-default-pathname (current-buffer)) - :type "dict")) - -(defcommand "Add Word to Spelling Dictionary" (p) - "Add the previous word to the spelling dictionary." - "Add the previous word to the spelling dictionary." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (let ((word (region-to-string (spell-previous-word (current-point) nil)))) - ;; - ;; SPELL:SPELL-ADD-ENTRY destructively uppercases word. - (when (spell:spell-add-entry word) - (message "Word ~(~S~) added to the spelling dictionary." word) - (push word (spell-info-insertions (value spell-information)))))) - -(defcommand "Remove Word from Spelling Dictionary" (p) - "Prompts for word to remove from the spelling dictionary." - "Prompts for word to remove from the spelling dictionary." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (let* ((word (prompt-for-string - :prompt "Word to remove from spelling dictionary: " - :trim t)) - (upword (string-upcase word))) - (declare (simple-string word)) - (multiple-value-bind (index flagp) - (spell:spell-try-word upword (length word)) - (unless index - (editor-error "~A not in dictionary." upword)) - (if flagp - (remove-spelling-word upword) - (let ((flags (spell:spell-root-flags index))) - (when (or (not flags) - (prompt-for-y-or-n - :prompt - `("Deleting ~A also removes words formed from this root and these flags: ~% ~ - ~S.~%~ - Delete word anyway? " - ,word ,flags) - :default t - :default-string "Y")) - (remove-spelling-word upword))))))) - -;;; REMOVE-SPELLING-WORD removes the uppercase word word from the spelling -;;; dictionary and from the spelling informations incremental insertions list. -;;; -(defun remove-spelling-word (word) - (let ((info (value spell-information))) - (spell:spell-remove-entry word) - (setf (spell-info-insertions info) - (delete word (spell-info-insertions info) :test #'string=)))) - -(defcommand "List Incremental Spelling Insertions" (p) - "Display the incremental spelling insertions for the current buffer's - associated spelling dictionary file." - "Display the incremental spelling insertions for the current buffer's - associated spelling dictionary file." - (declare (ignore p)) - (let* ((info (value spell-information)) - (file (spell-info-pathname info)) - (insertions (spell-info-insertions info))) - (declare (list insertions)) - (with-pop-up-display (s :height (1+ (length insertions))) - (if file - (format s "Incremental spelling insertions for dictionary ~A:~%" - (namestring file)) - (write-line "Global incremental spelling insertions:" s)) - (dolist (w insertions) - (write-line w s))))) - - - -;;;; Utilities for above stuff. - -;;; SPELL-PREVIOUS-WORD returns as a region the current or previous word, using -;;; the spell word definition. If there is no such word, return nil. If end-p -;;; is non-nil, then mark ends the word even if there is a non-delimiter -;;; character after it. -;;; -;;; Actually, if mark is between the first character of a word and a -;;; non-spell-word characer, it is considered to be in that word even though -;;; that word is after the mark. This is because Hemlock's cursor is always -;;; displayed over the next character, so users tend to think of a cursor -;;; displayed on the first character of a word as being in that word instead of -;;; before it. -;;; -(defun spell-previous-word (mark end-p) - (with-mark ((point mark) - (mark mark)) - (cond ((or end-p - (zerop (character-attribute :spell-word-character - (next-character point)))) - (unless (reverse-find-attribute mark :spell-word-character) - (return-from spell-previous-word nil)) - (move-mark point mark) - (reverse-find-attribute point :spell-word-character #'zerop)) - (t - (find-attribute mark :spell-word-character #'zerop) - (reverse-find-attribute point :spell-word-character #'zerop))) - (cond ((and (> (- (mark-charpos mark) (mark-charpos point)) 2) - (char= (char-upcase (previous-character mark)) #\S) - (char= (prog1 (previous-character (mark-before mark)) - (mark-after mark)) - #\')) - ;; Use roots of possessives and funny plurals (e.g., A's and AND's). - (character-offset mark -2)) - (t - ;; Maybe backup over apostrophes used for quotation marks. - (loop - (when (mark= point mark) (return-from spell-previous-word nil)) - (when (char/= (previous-character mark) #\') (return)) - (mark-before mark)))) - (region point mark))) diff --git a/hemlock/srccom.lisp b/hemlock/srccom.lisp deleted file mode 100644 index 246b68ae1ad0e70b7e0d49f52d98e77c73fd281e..0000000000000000000000000000000000000000 --- a/hemlock/srccom.lisp +++ /dev/null @@ -1,481 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Source comparison stuff for Hemlock. -;;; -;;; Written by Skef Wholey and Bill Chiles. -;;; - -(in-package "HEMLOCK") - -(defhvar "Source Compare Ignore Extra Newlines" - "If T, Source Compare and Source Merge will treat all groups of newlines - as if they were a single newline. The default is T." - :value t) - -(defhvar "Source Compare Ignore Case" - "If T, Source Compare and Source Merge will treat all letters as if they - were of the same case. The default is Nil." - :value nil) - -(defhvar "Source Compare Ignore Indentation" - "This determines whether comparisons ignore initial whitespace on a line or - use the whole line." - :value nil) - -(defhvar "Source Compare Number of Lines" - "This variable controls the number of lines Source Compare and Source Merge - will compare when resyncronizing after a difference has been encountered. - The default is 3." - :value 3) - -(defhvar "Source Compare Default Destination" - "This is a sticky-default buffer name to offer when comparison commands prompt - for a results buffer." - :value "Differences") - - -(defcommand "Buffer Changes" (p) - "Generate a comparison of the current buffer with its file on disk." - "Generate a comparison of the current buffer with its file on disk." - (declare (ignore p)) - (let ((buffer (current-buffer))) - (unless (buffer-pathname buffer) - (editor-error "No pathname associated with buffer.")) - (let ((other-buffer (or (getstring "Buffer Changes File" *buffer-names*) - (make-buffer "Buffer Changes File"))) - (result-buffer (or (getstring "Buffer Changes Result" *buffer-names*) - (make-buffer "Buffer Changes Result")))) - (visit-file-command nil (buffer-pathname buffer) other-buffer) - (delete-region (buffer-region result-buffer)) - (compare-buffers-command nil buffer other-buffer result-buffer) - (delete-buffer other-buffer)))) - -;;; "Compare Buffers" creates two temporary buffers when there is a prefix. -;;; These get deleted when we're done. Buffer-a and Buffer-b are used for -;;; names is banners in either case. -;;; -(defcommand "Compare Buffers" (p &optional buffer-a buffer-b dest-buffer) - "Performs a source comparison on two specified buffers. If the prefix - argument is supplied, only compare the regions in the buffer." - "Performs a source comparison on two specified buffers, Buffer-A and - Buffer-B, putting the result of the comparison into the Dest-Buffer. - If the prefix argument is supplied, only compare the regions in the - buffer." - (srccom-choose-comparison-functions) - (multiple-value-bind (buffer-a buffer-b dest-point - delete-buffer-a delete-buffer-b) - (get-srccom-buffers "Compare buffer: " buffer-a buffer-b - dest-buffer p) - (with-output-to-mark (log dest-point) - (format log "Comparison of ~A and ~A.~%~%" - (buffer-name buffer-a) (buffer-name buffer-b)) - (with-mark ((mark-a (buffer-start-mark (or delete-buffer-a buffer-a))) - (mark-b (buffer-start-mark (or delete-buffer-b buffer-b)))) - (loop - (multiple-value-bind (diff-a diff-b) - (srccom-find-difference mark-a mark-b) - (when (null diff-a) (return nil)) - (format log "**** Buffer ~A:~%" (buffer-name buffer-a)) - (insert-region dest-point diff-a) - (format log "**** Buffer ~A:~%" (buffer-name buffer-b)) - (insert-region dest-point diff-b) - (format log "***************~%~%") - (move-mark mark-a (region-end diff-a)) - (move-mark mark-b (region-end diff-b)) - (unless (line-offset mark-a 1) (return)) - (unless (line-offset mark-b 1) (return))))) - (format log "Done.~%")) - (when delete-buffer-a - (delete-buffer delete-buffer-a) - (delete-buffer delete-buffer-b)))) - - -;;; "Merge Buffers" creates two temporary buffers when there is a prefix. -;;; These get deleted when we're done. Buffer-a and Buffer-b are used for -;;; names is banners in either case. -;;; -(defcommand "Merge Buffers" (p &optional buffer-a buffer-b dest-buffer) - "Performs a source merge on two specified buffers. If the prefix - argument is supplied, only compare the regions in the buffer." - "Performs a source merge on two specified buffers, Buffer-A and Buffer-B, - putting the resulting text into the Dest-Buffer. If the prefix argument - is supplied, only compare the regions in the buffer." - (srccom-choose-comparison-functions) - (multiple-value-bind (buffer-a buffer-b dest-point - delete-buffer-a delete-buffer-b) - (get-srccom-buffers "Merge buffer: " buffer-a buffer-b - dest-buffer p) - (with-output-to-mark (stream dest-point) - (let ((region-a (buffer-region (or delete-buffer-a buffer-a)))) - (with-mark ((temp-a (region-start region-a) :right-inserting) - (temp-b dest-point :right-inserting) - (mark-a (region-start region-a)) - (mark-b (region-start - (buffer-region (or delete-buffer-b buffer-b))))) - (clear-echo-area) - (loop - (multiple-value-bind (diff-a diff-b) - (srccom-find-difference mark-a mark-b) - (when (null diff-a) - (insert-region dest-point (region temp-a (region-end region-a))) - (return nil)) - ;; Copy the part that's the same. - (insert-region dest-point (region temp-a (region-start diff-a))) - ;; Put both versions in the buffer, and prompt for which one to use. - (move-mark temp-a dest-point) - (format stream "~%**** Buffer ~A (1):~%" (buffer-name buffer-a)) - (insert-region dest-point diff-a) - (move-mark temp-b dest-point) - (format stream "~%**** Buffer ~A (2):~%" (buffer-name buffer-b)) - (insert-region dest-point diff-b) - (command-case - (:prompt "Merge Buffers: " - :help "Type one of these characters to say how to merge:") - (#\1 "Use the text from buffer 1." - (delete-region (region temp-b dest-point)) - (delete-characters temp-a) - (delete-region - (region temp-a - (line-start temp-b - (line-next (mark-line temp-a)))))) - (#\2 "Use the text from buffer 2." - (delete-region (region temp-a temp-b)) - (delete-characters temp-b) - (delete-region - (region temp-b - (line-start temp-a - (line-next (mark-line temp-b)))))) - (#\B "Insert both versions with **** MERGE LOSSAGE **** around them." - (insert-string temp-a " - **** MERGE LOSSAGE ****") - (insert-string dest-point " - **** END OF MERGE LOSSAGE ****")) - (#\A "Align window at start of difference display." - (line-start - (move-mark - (window-display-start - (car (buffer-windows (line-buffer (mark-line temp-a))))) - temp-a)) - (reprompt)) - (:recursive-edit "Enter a recursive edit." - (with-mark ((save dest-point)) - (do-recursive-edit) - (move-mark dest-point save)) - (reprompt))) - (redisplay) - (move-mark mark-a (region-end diff-a)) - (move-mark mark-b (region-end diff-b)) - (move-mark temp-a mark-a) - (unless (line-offset mark-a 1) (return)) - (unless (line-offset mark-b 1) (return)))))) - (message "Done.")) - (when delete-buffer-a - (delete-buffer delete-buffer-a) - (delete-buffer delete-buffer-b)))) - -(defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p) - (unless buffer-a - (setf buffer-a (prompt-for-buffer :prompt first-prompt - :must-exist t - :default (current-buffer)))) - (unless buffer-b - (setf buffer-b (prompt-for-buffer :prompt "With buffer: " - :must-exist t - :default (previous-buffer)))) - (unless dest-buffer - (setf dest-buffer - (prompt-for-buffer :prompt "Putting results in buffer: " - :must-exist nil - :default-string - (value source-compare-default-destination)))) - (if (stringp dest-buffer) - (setf dest-buffer (make-buffer dest-buffer)) - (buffer-end (buffer-point dest-buffer))) - (setf (value source-compare-default-destination) (buffer-name dest-buffer)) - (change-to-buffer dest-buffer) - (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym))))) - (alt-buffer-b (if alt-buffer-a - (make-buffer (prin1-to-string (gensym)))))) - (when alt-buffer-a - (ninsert-region (buffer-point alt-buffer-a) - (copy-region (if (mark< (buffer-point buffer-a) - (buffer-mark buffer-a)) - (region (buffer-point buffer-a) - (buffer-mark buffer-a)) - (region (buffer-mark buffer-a) - (buffer-point buffer-a))))) - (ninsert-region (buffer-point alt-buffer-b) - (copy-region (if (mark< (buffer-point buffer-b) - (buffer-mark buffer-b)) - (region (buffer-point buffer-b) - (buffer-mark buffer-b)) - (region (buffer-mark buffer-b) - (buffer-point buffer-b)))))) - (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b))) -#| -(defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p) - (unless buffer-a - (setf buffer-a (prompt-for-buffer :prompt first-prompt - :must-exist t - :default (current-buffer)))) - (unless buffer-b - (setf buffer-b (prompt-for-buffer :prompt "With buffer: " - :must-exist t - :default (previous-buffer)))) - (unless dest-buffer - (let* ((name (value source-compare-default-destination)) - (temp-default (getstring name *buffer-names*)) - (default (or temp-default (make-buffer name)))) - (setf dest-buffer (prompt-for-buffer :prompt "Putting results in buffer: " - :must-exist nil - :default default)) - ;; Delete the default buffer if it did already exist and was not chosen. - (unless (or (eq dest-buffer default) temp-default) - (delete-buffer default)))) - (if (stringp dest-buffer) - (setf dest-buffer (make-buffer dest-buffer)) - (buffer-end (buffer-point dest-buffer))) - (setf (value source-compare-default-destination) (buffer-name dest-buffer)) - (change-to-buffer dest-buffer) - (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym))))) - (alt-buffer-b (if alt-buffer-a - (make-buffer (prin1-to-string (gensym)))))) - (when alt-buffer-a - (ninsert-region (buffer-point alt-buffer-a) - (copy-region (if (mark< (buffer-point buffer-a) - (buffer-mark buffer-a)) - (region (buffer-point buffer-a) - (buffer-mark buffer-a)) - (region (buffer-mark buffer-a) - (buffer-point buffer-a))))) - (ninsert-region (buffer-point alt-buffer-b) - (copy-region (if (mark< (buffer-point buffer-b) - (buffer-mark buffer-b)) - (region (buffer-point buffer-b) - (buffer-mark buffer-b)) - (region (buffer-mark buffer-b) - (buffer-point buffer-b)))))) - (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b))) -|# - - -;;;; Functions that find the differences between two buffers. - -(defun srccom-find-difference (mark-a mark-b) - "Returns as multiple values two regions of text that are different in the - lines following Mark-A and Mark-B. If no difference is encountered, Nil - is returned." - (multiple-value-bind (diff-a diff-b) - (srccom-different-lines mark-a mark-b) - (when diff-a - (multiple-value-bind (same-a same-b) - (srccom-similar-lines diff-a diff-b) - (values (region diff-a same-a) - (region diff-b same-b)))))) - -;;; These are set by SRCCOM-CHOOSE-COMPARISON-FUNCTIONS depending on something. -;;; -(defvar *srccom-line=* nil) -(defvar *srccom-line-next* nil) - -(defun srccom-different-lines (mark-a mark-b) - "Returns as multiple values two marks pointing to the first different lines - found after Mark-A and Mark-B. Nil is returned if no different lines are - found." - (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a)) - (mark-a (copy-mark mark-a)) - (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b)) - (mark-b (copy-mark mark-b))) - (()) - (cond ((null line-a) - (return (if line-b - (values mark-a mark-b)))) - ((null line-b) - (return (values mark-a mark-b)))) - (line-start mark-a line-a) - (line-start mark-b line-b) - (unless (funcall *srccom-line=* line-a line-b) - (return (values mark-a mark-b))))) - -(defun srccom-similar-lines (mark-a mark-b) - "Returns as multiple values two marks pointing to the first similar lines - found after Mark-A and Mark-B." - (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a)) - (cmark-a (copy-mark mark-a)) - (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b)) - (cmark-b (copy-mark mark-b)) - (temp) - (window-size (value source-compare-number-of-lines))) - (()) - ;; If we hit the end of one buffer, then the difference extends to the end - ;; of both buffers. - (if (or (null line-a) (null line-b)) - (return - (values - (buffer-end-mark (line-buffer (mark-line mark-a))) - (buffer-end-mark (line-buffer (mark-line mark-b)))))) - (line-start cmark-a line-a) - (line-start cmark-b line-b) - ;; Three cases: - ;; 1] Difference will be same length in A and B. If so, Line-A = Line-B. - ;; 2] Difference will be longer in A. If so, Line-A = something in B. - ;; 3] Difference will be longer in B. If so, Line-B = something in A. - (cond ((and (funcall *srccom-line=* line-a line-b) - (srccom-check-window line-a line-b window-size)) - (return (values cmark-a cmark-b))) - ((and (setq temp (srccom-line-in line-a mark-b cmark-b)) - (srccom-check-window line-a temp window-size)) - (return (values cmark-a (line-start cmark-b temp)))) - ((and (setq temp (srccom-line-in line-b mark-a cmark-a)) - (srccom-check-window temp line-b window-size)) - (return (values (line-start cmark-a temp) cmark-b)))))) - -(defun srccom-line-in (line start end) - "Checks to see if there is a Line Srccom-Line= to the given Line in the - region delimited by the Start and End marks. Returns that line if so, or - Nil if there is none." - (do ((current (mark-line start) (funcall *srccom-line-next* current)) - (terminus (funcall *srccom-line-next* (mark-line end)))) - ((eq current terminus) nil) - (if (funcall *srccom-line=* line current) - (return current)))) - -(defun srccom-check-window (line-a line-b count) - "Verifies that the Count lines following Line-A and Line-B are Srccom-Line=. - If so, returns T. Otherwise returns Nil." - (do ((line-a line-a (funcall *srccom-line-next* line-a)) - (line-b line-b (funcall *srccom-line-next* line-b)) - (index 0 (1+ index))) - ((= index count) t) - (if (not (funcall *srccom-line=* line-a line-b)) - (return nil)))) - - - -;;;; Functions that control the comparison of text. - -;;; SRCCOM-CHOOSE-COMPARISON-FUNCTIONS -- Internal. -;;; -;;; This initializes utility functions for comparison commands based on Hemlock -;;; variables. -;;; -(defun srccom-choose-comparison-functions () - (setf *srccom-line=* - (if (value source-compare-ignore-case) - (if (value source-compare-ignore-indentation) - #'srccom-ignore-case-and-indentation-line= - #'srccom-case-insensitive-line=) - (if (value source-compare-ignore-indentation) - #'srccom-ignore-indentation-case-sensitive-line= - #'srccom-case-sensitive-line=))) - (setf *srccom-line-next* - (if (value source-compare-ignore-extra-newlines) - #'srccom-line-next-ignoring-extra-newlines - #'line-next))) -#| -(defun srccom-choose-comparison-functions () - "This function should be called by a ``top level'' source compare utility - to initialize the lower-level functions that compare text." - (setf *srccom-line=* - (if (value source-compare-ignore-case) - #'srccom-case-insensitive-line= - #'srccom-case-sensitive-line=)) - (setf *srccom-line-next* - (if (value source-compare-ignore-extra-newlines) - #'srccom-line-next-ignoring-extra-newlines - #'line-next))) -|# - -;;; SRCCOM-LINE-NEXT-IGNORING-EXTRA-NEWLINES -- Internal. -;;; -;;; This is the value of *srccom-line-next* when "Source Compare Ignore Extra -;;; Newlines" is non-nil. -;;; -(defun srccom-line-next-ignoring-extra-newlines (line) - (if (null line) nil - (do ((line (line-next line) (line-next line))) - ((or (null line) (not (blank-line-p line))) line)))) - -;;; SRCCOM-IGNORE-CASE-AND-INDENTATION-LINE= -- Internal. -;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal. -;;; SRCCOM-IGNORE-INDENTATION-CASE-SENSITIVE-LINE= -- Internal. -;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal. -;;; -;;; These are the value of *srccom-line-=* depending on the orthogonal values -;;; of "Source Compare Ignore Case" and "Source Compare Ignore Indentation". -;;; -(macrolet ((def-line= (name test &optional ignore-indentation) - `(defun ,name (line-a line-b) - (or (eq line-a line-b) ; if they're both NIL - (and line-a - line-b - (let* ((chars-a (line-string line-a)) - (len-a (length chars-a)) - (chars-b (line-string line-b)) - (len-b (length chars-b))) - (declare (simple-string chars-a chars-b)) - (cond - ((and (= len-a len-b) - (,test chars-a chars-b))) - ,@(if ignore-indentation - `((t - (flet ((frob (chars len) - (dotimes (i len nil) - (let ((char (schar chars i))) - (unless - (or (char= char #\space) - (char= char #\tab)) - (return i)))))) - (let ((i (frob chars-a len-a)) - (j (frob chars-b len-b))) - (if (and i j) - (,test chars-a chars-b - :start1 i :end1 len-a - :start2 j :end2 len-b) - ))))))))))))) - - (def-line= srccom-ignore-case-and-indentation-line= string-equal t) - - (def-line= srccom-case-insensitive-line= string-equal) - - (def-line= srccom-ignore-indentation-case-sensitive-line= string= t) - - (def-line= srccom-case-sensitive-line= string=)) - -#| -;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal. -;;; -;;; Returns t if line-a and line-b contain STRING-EQUAL text. -;;; -(defun srccom-case-insensitive-line= (line-a line-b) - (or (eq line-a line-b) ; if they're both NIL - (and line-a - line-b - (let ((chars-a (line-string line-a)) - (chars-b (line-string line-b))) - (declare (simple-string chars-a chars-b)) - (and (= (length chars-a) (length chars-b)) - (string-equal chars-a chars-b)))))) - -;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal. -;;; -;;; Returns t if line-a and line-b contain STRING= text. -;;; -(defun srccom-case-sensitive-line= (line-a line-b) - (or (eq line-a line-b) ; if they're both NIL - (and line-a - line-b - (let ((chars-a (line-string line-a)) - (chars-b (line-string line-b))) - (declare (simple-string chars-a chars-b)) - (and (= (length chars-a) (length chars-b)) - (string= chars-a chars-b)))))) -|# diff --git a/hemlock/streams.lisp b/hemlock/streams.lisp deleted file mode 100644 index dfdae2b4fba3bdf85ac13ce853e651253bd0e812..0000000000000000000000000000000000000000 --- a/hemlock/streams.lisp +++ /dev/null @@ -1,316 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains definitions of various types of streams used -;;; in Hemlock. They are implementation dependant, but should be -;;; portable to all implementations based on Spice Lisp with little -;;; difficulty. -;;; -;;; Written by Skef Wholey and Rob MacLachlan. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(make-hemlock-output-stream - hemlock-region-stream hemlock-region-stream-p - hemlock-output-stream make-hemlock-region-stream - hemlock-output-stream-p make-kbdmac-stream - modify-kbdmac-stream)) - -(defstruct (hemlock-output-stream - (:include stream - (:misc #'hemlock-output-misc)) - (:print-function %print-hemlock-output-stream) - (:constructor internal-make-hemlock-output-stream ())) - ;; - ;; The mark we insert at. - mark) - -(defun %print-hemlock-output-stream (s stream d) - (declare (ignore d s)) - (write-string "#<Hemlock output stream>" stream)) - -(defun make-hemlock-output-stream (mark &optional (buffered :line)) - "Returns an output stream whose output will be inserted at the Mark. - Buffered, which indicates to what extent the stream may be buffered - is one of the following: - :None -- The screen is brought up to date after each stream operation. - :Line -- The screen is brought up to date when a newline is written. - :Full -- The screen is not updated except explicitly via Force-Output." - (modify-hemlock-output-stream (internal-make-hemlock-output-stream) mark - buffered)) - - -(defun modify-hemlock-output-stream (stream mark buffered) - (unless (and (markp mark) - (memq (mark-kind mark) '(:right-inserting :left-inserting))) - (error "~S is not a permanent mark." mark)) - (setf (hemlock-output-stream-mark stream) mark) - (case buffered - (:none - (setf (lisp::stream-out stream) #'hemlock-output-unbuffered-out - (lisp::stream-sout stream) #'hemlock-output-unbuffered-sout)) - (:line - (setf (lisp::stream-out stream) #'hemlock-output-line-buffered-out - (lisp::stream-sout stream) #'hemlock-output-line-buffered-sout)) - (:full - (setf (lisp::stream-out stream) #'hemlock-output-buffered-out - (lisp::stream-sout stream) #'hemlock-output-buffered-sout)) - (t - (error "~S is a losing value for Buffered." buffered))) - stream) - -(defmacro with-left-inserting-mark ((var form) &body forms) - (let ((change (gensym))) - `(let* ((,var ,form) - (,change (eq (mark-kind ,var) :right-inserting))) - (unwind-protect - (progn - (when ,change - (setf (mark-kind ,var) :left-inserting)) - ,@forms) - (when ,change - (setf (mark-kind ,var) :right-inserting)))))) - -(defun hemlock-output-unbuffered-out (stream character) - (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) - (insert-character mark character) - (redisplay-windows-from-mark mark))) - -(defun hemlock-output-unbuffered-sout (stream string start end) - (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) - (insert-string mark string start end) - (redisplay-windows-from-mark mark))) - -(defun hemlock-output-buffered-out (stream character) - (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) - (insert-character mark character))) - -(defun hemlock-output-buffered-sout (stream string start end) - (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) - (insert-string mark string start end))) - -(defun hemlock-output-line-buffered-out (stream character) - (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) - (insert-character mark character) - (when (char= character #\newline) - (redisplay-windows-from-mark mark)))) - -(defun hemlock-output-line-buffered-sout (stream string start end) - (declare (simple-string string)) - (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) - (insert-string mark string start end) - (when (find #\newline string :start start :end end) - (redisplay-windows-from-mark mark)))) - -(defun hemlock-output-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - (:charpos (mark-charpos (hemlock-output-stream-mark stream))) - (:line-length - (let* ((buffer (line-buffer (mark-line (hemlock-output-stream-mark stream))))) - (when buffer - (do ((w (buffer-windows buffer) (cdr w)) - (min most-positive-fixnum (min (window-width (car w)) min))) - ((null w) - (if (/= min most-positive-fixnum) min)))))) - ((:finish-output :force-output) - (redisplay-windows-from-mark (hemlock-output-stream-mark stream))) - (:close (setf (hemlock-output-stream-mark stream) nil)) - (:element-type 'string-char))) - -(defstruct (hemlock-region-stream - (:include stream - (:in #'region-in) - (:misc #'region-misc) - (:in-buffer (make-string lisp::in-buffer-length))) - (:print-function %print-region-stream) - (:constructor internal-make-hemlock-region-stream (region mark))) - ;; - ;; The region we read from. - region - ;; - ;; The mark pointing to the next character to read. - mark) - -(defun %print-region-stream (s stream d) - (declare (ignore s d)) - (write-string "#<Hemlock region stream>" stream)) - -(defun make-hemlock-region-stream (region) - "Returns an input stream that will return successive characters from the - given Region when asked for input." - (internal-make-hemlock-region-stream - region (copy-mark (region-start region) :right-inserting))) - -(defun modify-hemlock-region-stream (stream region) - (setf (hemlock-region-stream-region stream) region - (lisp::stream-in-index stream) lisp::in-buffer-length) - (let* ((mark (hemlock-region-stream-mark stream)) - (start (region-start region)) - (start-line (mark-line start))) - ;; Make sure it's dead. - (delete-mark mark) - (setf (mark-line mark) start-line (mark-charpos mark) (mark-charpos start)) - (push mark (line-marks start-line))) - stream) - -(defun region-readline (stream eof-errorp eof-value) - (close-line) - (let ((mark (hemlock-region-stream-mark stream)) - (end (region-end (hemlock-region-stream-region stream)))) - (cond ((mark>= mark end) - (if eof-errorp - (error "~A hit end of file." stream) - (values eof-value nil))) - ((eq (mark-line mark) (mark-line end)) - (let* ((limit (mark-charpos end)) - (charpos (mark-charpos mark)) - (dst-end (- limit charpos)) - (result (make-string dst-end))) - (declare (simple-string result)) - (%sp-byte-blt (line-chars (mark-line mark)) charpos - result 0 dst-end) - (setf (mark-charpos mark) limit) - (values result t))) - ((= (mark-charpos mark) 0) - (let* ((line (mark-line mark)) - (next (line-next line))) - (always-change-line mark next) - (values (line-chars line) nil))) - (t - (let* ((line (mark-line mark)) - (chars (line-chars line)) - (next (line-next line)) - (charpos (mark-charpos mark)) - (dst-end (- (length chars) charpos)) - (result (make-string dst-end))) - (declare (simple-string chars result)) - (%sp-byte-blt chars charpos result 0 dst-end) - (setf (mark-charpos mark) 0) - (always-change-line mark next) - (values result nil)))))) - -(defun region-in (stream eof-errorp eof-value) - (close-line) - (let* ((mark (hemlock-region-stream-mark stream)) - (charpos (mark-charpos mark)) - (line (mark-line mark)) - (chars (line-chars line)) - (length (length chars)) - (last (region-end (hemlock-region-stream-region stream))) - (last-line (mark-line last)) - (buffer (lisp::stream-in-buffer stream)) start len) - (declare (fixnum length charpos last-charpos start len) - (simple-string chars)) - (cond - ((eq line last-line) - (let ((last-charpos (mark-charpos last))) - (setq len (- last-charpos charpos)) - (cond - ((>= charpos last-charpos) - (if eof-errorp - (error "~A hit end of file." stream) - (return-from region-in eof-value))) - ((> len lisp::in-buffer-length) - (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length) - (setq start 0 len lisp::in-buffer-length)) - (t - (setq start (- lisp::in-buffer-length len)) - (%sp-byte-blt chars charpos buffer start lisp::in-buffer-length))))) - ((line> line last-line) - (if eof-errorp - (error "~a hit end of file." stream) - (return-from region-in eof-value))) - (t - (setq len (- length charpos)) - (cond - ((< len lisp::in-buffer-length) - (let ((end (1- lisp::in-buffer-length))) - (setq start (- lisp::in-buffer-length len 1)) - (%sp-byte-blt chars charpos buffer start end) - (setf (schar buffer end) #\newline)) - (incf len)) - (t - (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length) - (setq start 0 len lisp::in-buffer-length))))) - (setf (lisp::stream-in-index stream) (1+ start)) - (character-offset mark len) - (schar buffer start))) - -(defun region-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - (:listen (mark< (hemlock-region-stream-mark stream) - (region-end (hemlock-region-stream-region stream)))) - (:read-line (region-readline stream arg1 arg2)) - (:clear-input (move-mark - (hemlock-region-stream-mark stream) - (region-end (hemlock-region-stream-region stream)))) - (:close - (delete-mark (hemlock-region-stream-mark stream)) - (setf (hemlock-region-stream-region stream) nil)) - (:element-type 'string-char))) - -;;;; Stuff to support keyboard macros. - -;;; Note that the buffers in these streams must be general vectors, because -;;; the characters may have bits. - -(defstruct (kbdmac-stream - (:include stream - (:in #'kbdmac-in) - (:listen #'kbdmac-listen) - (:misc #'kbdmac-misc)) - (:constructor make-kbdmac-stream ())) - ;; - ;; The simple-vector that holds the characters. - buffer - ;; - ;; Index of the next character. - index) - -;;; Kbdmac-In -- Internal -;;; -;;; This is the input method for a kbdmac stream. It just grabs a character -;;; and returns it, bumping the index. -;;; -(defun kbdmac-in (stream eof-errorp eof-value) - (declare (ignore eof-errorp eof-value)) - (let ((index (kbdmac-stream-index stream))) - (prog1 (setq *last-character-typed* - (svref (kbdmac-stream-buffer stream) index)) - (setf (kbdmac-stream-index stream) (1+ index))))) - -;;; Kbdmac-Misc -- Internal -;;; -;;; This is the misc method for kbdmac streams. Since any character -;;; that might have been read is included in the simulated input, listen -;;; will always return T. -;;; -(defun kbdmac-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - (:unread - (if (plusp (kbdmac-stream-index stream)) - (decf (kbdmac-stream-index stream)) - (error "Nothing to unread."))) - (:listen t) - (:element-type 'string-char)) - t) - -;;; Modify-Kbdmac-Stream -- Internal -;;; -;;; Bash the kbdmac-stream Stream so that it will return the Input. -;;; -(defun modify-kbdmac-stream (stream input) - (setf (kbdmac-stream-index stream) 0) - (setf (kbdmac-stream-buffer stream) input) - stream) diff --git a/hemlock/struct-ed.lisp b/hemlock/struct-ed.lisp deleted file mode 100644 index 8522c2fc0e10f02b91f70f9a1575199882e18620..0000000000000000000000000000000000000000 --- a/hemlock/struct-ed.lisp +++ /dev/null @@ -1,39 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Structures used by constucts in the HEMLOCK package. -;;; - -(in-package "HEMLOCK") - -;;; The server-info structure holds information about the connection to a -;;; particular eval server. For now, we don't separate the background I/O and -;;; random compiler output. The Notifications port and Terminal_IO will be the -;;; same identical object. This separation in the interface may be just -;;; gratuitous pseudo-generality, but it doesn't hurt. -;;; -(defstruct (server-info - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Server-Info for ~A>" (server-info-name s))))) - name ; String name of this server. - port ; Port we send requests to. - ; NullPort if no connection. - notifications ; List of notification objects for operations - ; which have not yet completed. - ts-info ; Ts-Info structure of typescript we use in - ; "background" buffer. - buffer ; Buffer "background" typescript is in. - slave-ts ; Ts-Info used in "Slave Lisp" buffer - ; (formerly the "Lisp Listener" buffer). - slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*. - errors ; List of structures describing reported errors. - error-mark) ; Pointer after last error edited. diff --git a/hemlock/struct.lisp b/hemlock/struct.lisp deleted file mode 100644 index c9e51959f13a9cdbdef99b3a755b874bc920a65b..0000000000000000000000000000000000000000 --- a/hemlock/struct.lisp +++ /dev/null @@ -1,611 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Structures and assorted macros for Hemlock. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(mark mark-line mark-charpos markp region region-start region-end - regionp buffer bufferp buffer-modes buffer-point buffer-writable - buffer-delete-hook buffer-windows buffer-variables buffer-write-date - region regionp region-start region-end window windowp window-height - window-width window-display-start window-display-end window-point - commandp command command-function command-documentation - modeline-field modeline-field-p)) - - -;;;; Marks. - -(defstruct (mark (:print-function %print-hmark) - (:predicate markp) - (:copier nil) - (:constructor internal-make-mark (line charpos %kind))) - "A Hemlock mark object. See Hemlock Command Implementor's Manual for details." - line ; pointer to line - charpos ; character position - %kind) ; type of mark - -(setf (documentation 'markp 'function) - "Returns true if its argument is a Hemlock mark object, false otherwise.") -(setf (documentation 'mark-line 'function) - "Returns line that a Hemlock mark points to.") -(setf (documentation 'mark-charpos 'function) - "Returns the character position of a Hemlock mark. - A mark's character position is the index within the line of the character - following the mark.") - -(defstruct (font-mark (:print-function - (lambda (s stream d) - (declare (ignore d)) - (write-string "#<Hemlock Font-Mark \"" stream) - (%print-before-mark s stream) - (write-string "/\\" stream) - (%print-after-mark s stream) - (write-string "\">" stream))) - (:include mark) - (:copier nil) - (:constructor internal-make-font-mark - (line charpos %kind font))) - font) - -(defmacro fast-font-mark-p (s) - `(eq (svref ,s 0) 'font-mark)) - - - -;;;; Regions, buffers, modeline fields. - -;;; The region object: -;;; -(defstruct (region (:print-function %print-hregion) - (:predicate regionp) - (:copier nil) - (:constructor internal-make-region (start end))) - "A Hemlock region object. See Hemlock Command Implementor's Manual for details." - start ; starting mark - end) ; ending mark - -(setf (documentation 'regionp 'function) - "Returns true if its argument is a Hemlock region object, Nil otherwise.") -(setf (documentation 'region-end 'function) - "Returns the mark that is the end of a Hemlock region.") -(setf (documentation 'region-start 'function) - "Returns the mark that is the start of a Hemlock region.") - - -;;; The buffer object: -;;; -(defstruct (buffer (:constructor internal-make-buffer) - (:print-function %print-hbuffer) - (:copier nil) - (:predicate bufferp)) - "A Hemlock buffer object. See Hemlock Command Implementor's Manual for details." - %name ; name of the buffer (a string) - %region ; the buffer's region - %pathname ; associated pathname - modes ; list of buffer's mode names - mode-objects ; list of buffer's mode objects - bindings ; buffer's command table - point ; current position in buffer - (%writable t) ; t => can alter buffer's region - (modified-tick -2) ; The last time the buffer was modified. - (unmodified-tick -1) ; The last time the buffer was unmodified - windows ; List of all windows into this buffer. - var-values ; the buffer's local variables - variables ; string-table of local variables - write-date ; File-Write-Date for pathname. - display-start ; Window display start when switching to buf. - %modeline-fields ; List of modeline-field-info's. - (delete-hook nil)) ; List of functions to call upon deletion. - -(setf (documentation 'buffer-modes 'function) - "Return the list of the names of the modes active in a given buffer.") -(setf (documentation 'buffer-point 'function) - "Return the mark that is the current focus of attention in a buffer.") -(setf (documentation 'buffer-windows 'function) - "Return the list of windows that are displaying a given buffer.") -(setf (documentation 'buffer-variables 'function) - "Return the string-table of the variables local to the specifed buffer.") -(setf (documentation 'buffer-write-date 'function) - "Return in universal time format the write date for the file associated - with the buffer. If the pathname is set, then this should probably - be as well. Should be NIL if the date is unknown or there is no file.") -(setf (documentation 'buffer-delete-hook 'function) - "This is the list of buffer specific functions that Hemlock invokes when - deleting this buffer.") - - -;;; Modeline fields. -;;; -(defstruct (modeline-field (:print-function print-modeline-field) - (:constructor %make-modeline-field - (%name %function %width))) - "This is one item displayed in a Hemlock window's modeline." - %name ; EQL name of this field. - %function ; Function that returns a string for this field. - %width) ; Width to display this field in. - -(setf (documentation 'modeline-field-p 'function) - "Returns true if its argument is a modeline field object, nil otherwise.") - -(defstruct (modeline-field-info (:print-function print-modeline-field-info) - (:conc-name ml-field-info-) - (:constructor make-ml-field-info (field))) - field - (start nil) - (end nil)) - - - -;;;; The mode object. - -(defstruct (mode-object (:predicate modep) - (:copier nil) - (:print-function %print-hemlock-mode)) - name ; name of this mode - setup-function ; setup function for this mode - cleanup-function ; Cleanup function for this mode - bindings ; The mode's command table. - transparent-p ; Are key-bindings transparent? - hook-name ; The name of the mode hook. - major-p ; Is this a major mode? - precedence ; The precedence for a minor mode. - character-attributes ; Mode local character attributes - variables ; String-table of mode variables - var-values ; Alist for saving mode variables - documentation) ; Introductory comments for mode describing commands. - -(defun %print-hemlock-mode (object stream depth) - (declare (ignore depth)) - (write-string "#<Hemlock Mode \"" stream) - (write-string (mode-object-name object) stream) - (write-string "\">" stream)) - - - -;;;; Variables. - -;;; This holds information about Hemlock variables, and the system stores -;;; these structures on the property list of the variable's symbolic -;;; representation under the 'hemlock-variable-value property. -;;; -(defstruct (variable-object - (:print-function - (lambda (object stream depth) - (declare (ignore depth)) - (format stream "#<Hemlock Variable-Object ~S>" - (variable-object-name object)))) - (:copier nil) - (:constructor make-variable-object (documentation name))) - value ; The value of this variable. - hooks ; The hook list for this variable. - down ; The variable-object for the previous value. - documentation ; The documentation. - name) ; The string name. - - - -;;;; Windows, dis-lines, and font-changes. - -;;; The window object: -;;; -(defstruct (window (:constructor internal-make-window) - (:predicate windowp) - (:copier nil) - (:print-function %print-hwindow)) - "This structure implements a Hemlock window." - tick ; The last time this window was updated. - %buffer ; buffer displayed in this window. - height ; Height of window in lines. - width ; Width of the window in characters. - old-start ; The charpos of the first char displayed. - first-line ; The head of the list of dis-lines. - last-line ; The last dis-line displayed. - first-changed ; The first changed dis-line on last update. - last-changed ; The last changed dis-line. - spare-lines ; The head of the list of unused dis-lines - (old-lines 0) ; Slot used by display to keep state info - hunk ; The device hunk that displays this window. - display-start ; first character position displayed - display-end ; last character displayed - point ; Where the cursor is in this window. - modeline-dis-line ; Dis-line for modeline display. - modeline-buffer ; Complete string of all modeline data. - modeline-buffer-len) ; Valid chars in modeline-buffer. - -(setf (documentation 'windowp 'function) - "Returns true if its argument is a Hemlock window object, Nil otherwise.") -(setf (documentation 'window-height 'function) - "Return the height of a Hemlock window in character positions.") -(setf (documentation 'window-width 'function) - "Return the width of a Hemlock window in character positions.") -(setf (documentation 'window-display-start 'function) - "Return the mark which points before the first character displayed in - the supplied window.") -(setf (documentation 'window-display-end 'function) - "Return the mark which points after the last character displayed in - the supplied window.") -(setf (documentation 'window-point 'function) - "Return the mark that points to where the cursor is displayed in this - window. When the window is made current, the Buffer-Point of this - window's buffer is moved to this position. While the window is - current, redisplay makes this mark point to the same position as the - Buffer-Point of its buffer.") - -(defstruct (dis-line (:copier nil) - (:constructor nil)) - chars ; The line-image to be displayed. - (length 0 :type fixnum) ; Length of line-image. - font-changes) ; Font-Change structures for changes in this line. - -(defstruct (window-dis-line (:copier nil) - (:include dis-line) - (:constructor make-window-dis-line (chars)) - (:conc-name dis-line-)) - old-chars ; Line-Chars of line displayed. - line ; Line displayed. - (flags 0 :type fixnum) ; Bit flags indicate line status. - (delta 0 :type fixnum) ; # lines moved from previous position. - (position 0 :type fixnum) ; Line # to be displayed on. - (end 0 :type fixnum)) ; Index after last logical character displayed. - -(defstruct (font-change (:copier nil) - (:constructor make-font-change (next))) - x ; X position that change takes effect. - font ; Index into font-map of font to use. - next ; The next Font-Change on this dis-line. - mark) ; Font-Mark responsible for this change. - - - -;;;; Font family. - -(defstruct font-family - map ; Font-map for hunk. - height ; Height of char box includung VSP. - width ; Width of font. - baseline ; Pixels from top of char box added to Y. - cursor-width ; Pixel width of cursor. - cursor-height ; Pixel height of cursor. - cursor-x-offset ; Added to pos of UL corner of char box to get - cursor-y-offset) ; UL corner of cursor blotch. - - - -;;;; Attribute descriptors. - -(defstruct (attribute-descriptor - (:copier nil) - (:print-function %print-attribute-descriptor)) - "This structure is used internally in Hemlock to describe a character - attribute." - name - keyword - documentation - vector - hooks - end-value) - - - -;;;; Commands. - -(defstruct (command (:constructor internal-make-command - (%name documentation function)) - (:copier nil) - (:predicate commandp) - (:print-function %print-hcommand)) - %name ;The name of the command - documentation ;Command documentation string or function - function ;The function which implements the command - %bindings) ;Places where command is bound - -(setf (documentation 'commandp 'function) - "Returns true if its argument is a Hemlock command object, Nil otherwise.") -(setf (documentation 'command-documentation 'function) - "Return the documentation for a Hemlock command, given the command-object. - Command documentation may be either a string or a function. This may - be set with Setf.") - - - -;;;; Random typeout streams. - -;;; These streams write to random typeout buffers for WITH-POP-UP-DISPLAY. -;;; -(defstruct (random-typeout-stream (:include stream) - (:print-function print-random-typeout-stream) - (:constructor - make-random-typeout-stream (mark))) - mark ; The buffer point of the associated buffer. - window ; The hemlock window all this shit is in. - more-mark ; The mark that is not displayed when we need to more. - no-prompt ; T when we want to exit, still collecting output. - (first-more-p t)) ; T until the first time we more. Nil after. - -(defun print-random-typeout-stream (object stream ignore) - (declare (ignore ignore)) - (format stream "#<Hemlock Random-Typeout-Stream ~S>" - (buffer-name - (line-buffer (mark-line (random-typeout-stream-mark object)))))) - - - -;;;; Redisplay devices. - -;;; Devices contain monitor specific redisplay methods referenced by -;;; redisplay independent code. -;;; -(defstruct (device (:print-function print-device) - (:constructor %make-device)) - name ; simple-string such as "concept" or "lnz". - init ; fun to call whenever going into the editor. - ; args: device - exit ; fun to call whenever leaving the editor. - ; args: device - smart-redisplay ; fun to redisplay a window on this device. - ; args: window &optional recenterp - dumb-redisplay ; fun to redisplay a window on this device. - ; args: window &optional recenterp - after-redisplay ; args: device - ; fun to call at the end of redisplay entry points. - clear ; fun to clear the entire display. - ; args: device - note-read-wait ; fun to somehow note on display that input is expected. - ; args: on-or-off - put-cursor ; fun to put the cursor at (x,y) or (column,line). - ; args: hunk &optional x y - show-mark ; fun to display the screens cursor at a certain mark. - ; args: window x y time - next-window ; funs to return the next and previous window - previous-window ; of some window. - ; args: window - make-window ; fun to make a window on the screen. - ; args: device start-mark - ; &optional modeline-string modeline-function - delete-window ; fun to remove a window from the screen. - ; args: window - random-typeout-setup ; fun to prepare for random typeout. - ; args: device n - random-typeout-cleanup; fun to clean up after random typeout. - ; args: device degree - random-typeout-line-more ; fun to keep line-buffered streams up to date. - random-typeout-full-more ; fun to do full-buffered more-prompting. - ; args: # of newlines in the object just inserted - ; in the buffer. - force-output ; if non-nil, fun to force any output possibly buffered. - finish-output ; if non-nil, fun to force output and hand until done. - ; args: device window - beep ; fun to beep or flash the screen. - bottom-window-base ; bottom text line of bottom window. - hunks) ; list of hunks on the screen. - -(defun print-device (obj str n) - (declare (ignore n)) - (format str "#<Hemlock Device ~S>" (device-name obj))) - - -(defstruct (bitmap-device #|(:print-function print-device)|# - (:include device)) - display) ; CLX display object. - - -(defstruct (tty-device #|(:print-function print-device)|# - (:constructor %make-tty-device) - (:include device)) - dumbp ; t if it does not have line insertion and deletion. - lines ; number of lines on device. - columns ; number of columns per line. - display-string ; fun to display a string of characters at (x,y). - ; args: hunk x y string &optional start end - standout-init ; fun to put terminal in standout mode. - ; args: hunk - standout-end ; fun to take terminal out of standout mode. - ; args: hunk - clear-lines ; fun to clear n lines starting at (x,y). - ; args: hunk x y n - clear-to-eol ; fun to clear to the end of a line from (x,y). - ; args: hunk x y - clear-to-eow ; fun to clear to the end of a window from (x,y). - ; args: hunk x y - open-line ; fun to open a line moving lines below it down. - ; args: hunk x y &optional n - delete-line ; fun to delete a line moving lines below it up. - ; args: hunk x y &optional n - insert-string ; fun to insert a string in the middle of a line. - ; args: hunk x y string &optional start end - delete-char ; fun to delete a character from the middle of a line. - ; args: hunk x y &optional n - (cursor-x 0) ; column the cursor is in. - (cursor-y 0) ; line the cursor is on. - standout-init-string ; string to put terminal in standout mode. - standout-end-string ; string to take terminal out of standout mode. - clear-to-eol-string ; string to cause device to clear to eol at (x,y). - clear-string ; string to cause device to clear entire screen. - open-line-string ; string to cause device to open a blank line. - delete-line-string ; string to cause device to delete a line, moving - ; lines below it up. - insert-init-string ; string to put terminal in insert mode. - insert-char-init-string ; string to prepare terminal for insert-mode character. - insert-char-end-string ; string to affect terminal after insert-mode character. - insert-end-string ; string to take terminal out of insert mode. - delete-init-string ; string to put terminal in delete mode. - delete-char-string ; string to delete a character. - delete-end-string ; string to take terminal out of delete mode. - init-string ; device init string. - cm-end-string ; takes device out of cursor motion mode. - (cm-x-add-char nil) ; char-code to unconditionally add to x coordinate. - (cm-y-add-char nil) ; char-code to unconditionally add to y coordinate. - (cm-x-condx-char nil) ; char-code threshold for adding to x coordinate. - (cm-y-condx-char nil) ; char-code threshold for adding to y coordinate. - (cm-x-condx-add-char nil) ; char-code to conditionally add to x coordinate. - (cm-y-condx-add-char nil) ; char-code to conditionally add to y coordinate. - cm-string1 ; initial substring of cursor motion string. - cm-string2 ; substring of cursor motion string between coordinates. - cm-string3 ; substring of cursor motion string after coordinates. - cm-one-origin ; non-nil if need to add one to coordinates. - cm-reversep ; non-nil if need to reverse coordinates. - (cm-x-pad nil) ; nil, 0, 2, or 3 for places to pad. - ; 0 sends digit-chars. - (cm-y-pad nil) ; nil, 0, 2, or 3 for places to pad. - ; 0 sends digit-chars. - screen-image) ; vector device-lines long of strings - ; device-columns long. - - - -;;;; Device screen hunks. - -;;; Device-hunks are used to claim a piece of the screen and for ordering -;;; pieces of the screen. Window motion primitives and splitting/merging -;;; primitives use hunks. Hunks are somewhat of an interface between the -;;; portable and non-portable parts of screen management, between what the -;;; user sees on the screen and how Hemlock internals deal with window -;;; sequencing and creation. Note: the echo area hunk is not hooked into -;;; the ring of other hunks via the next and previous fields. -;;; -(defstruct (device-hunk (:print-function %print-device-hunk)) - "This structure is used internally by Hemlock's screen management system." - window ; Window displayed in this hunk. - position ; Bottom Y position of hunk. - height ; Height of hunk in pixels or lines. - next ; Next and previous hunks. - previous - device) ; Display device hunk is on. - -(defun %print-device-hunk (object stream depth) - (declare (ignore depth)) - (format stream "#<Hemlock Device-Hunk ~D+~D~@[, ~S~]>" - (device-hunk-position object) - (device-hunk-height object) - (let* ((window (device-hunk-window object)) - (buffer (if window (window-buffer window)))) - (if buffer (buffer-name buffer))))) - - -;;; Bitmap hunks. -;;; -;;; The lock field is no longer used. If events could be handled while we -;;; were in the middle of something with the hunk, then this could be set -;;; for exclusion purposes. -;;; -(defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|# - (:include device-hunk)) - width ; Pixel width. - char-height ; Height of text body in characters. - char-width ; Width in characters. - xwindow ; X window for this hunk. - gcontext ; X gcontext for xwindow. - start ; Head of dis-line list (no dummy). - end ; Exclusive end, i.e. nil if nil-terminated. - modeline-dis-line ; Dis-line for modeline, or NIL if none. - modeline-pos ; Position of modeline in pixels. - (lock t) ; Something going on, set trashed if we're changed. - trashed ; Something bad happened, recompute image. - font-family ; Font-family used in this window. - input-handler ; Gets hunk, char, x, y when char read. - changed-handler ; Gets hunk when size changed. - (thumb-bar-p nil)) ; True if we draw a thumb bar in the top border. - - -;;; Terminal hunks. -;;; -(defstruct (tty-hunk #|(:print-function %print-device-hunk)|# - (:include device-hunk)) - text-position ; Bottom Y position of text in hunk. - text-height) ; Number of lines of text. - - - -;;;; Some defsetfs: - -(defsetf buffer-writable %set-buffer-writable - "Sets whether the buffer is writable and invokes the Buffer Writable Hook.") -(defsetf buffer-name %set-buffer-name - "Sets the name of a specified buffer, invoking the Buffer Name Hook.") -(defsetf buffer-modified %set-buffer-modified - "Make a buffer modified or unmodified.") -(defsetf buffer-pathname %set-buffer-pathname - "Sets the pathname of a buffer, invoking the Buffer Pathname Hook.") - -(defsetf getstring %set-string-table - "Sets the value for a string-table entry, making a new one if necessary.") - -(defsetf window-buffer %set-window-buffer - "Change the buffer a window is mapped to.") - -(lisp::define-setf-method value (var) - "Set the value of a Hemlock variable, calling any hooks." - (let ((svar (gensym))) - (values - () - () - (list svar) - `(%set-value ',var ,svar) - `(value ,var)))) - -(defsetf variable-value (name &optional (kind :current) where) (new-value) - "Set the value of a Hemlock variable, calling any hooks." - `(%set-variable-value ,name ,kind ,where ,new-value)) - -(defsetf variable-hooks (name &optional (kind :current) where) (new-value) - "Set the list of hook functions for a Hemlock variable." - `(%set-variable-hooks ,name ,kind ,where ,new-value)) - -(defsetf variable-documentation (name &optional (kind :current) where) (new-value) - "Set a Hemlock variable's documentation." - `(%set-variable-documentation ,name ,kind ,where ,new-value)) - -(defsetf buffer-minor-mode %set-buffer-minor-mode - "Turn a buffer minor mode on or off.") -(defsetf buffer-major-mode %set-buffer-major-mode - "Set a buffer's major mode.") -(defsetf previous-character %set-previous-character - "Sets the character to the left of the given Mark.") -(defsetf next-character %set-next-character - "Sets the characters to the right of the given Mark.") -(defsetf character-attribute %set-character-attribute - "Set the value for a character attribute.") -(defsetf character-attribute-hooks %set-character-attribute-hooks - "Set the hook list for a Hemlock character attribute.") -(defsetf ring-ref %set-ring-ref "Set an element in a ring.") -(defsetf current-window %set-current-window "Set the current window.") -(defsetf current-buffer %set-current-buffer - "Set the current buffer, doing necessary stuff.") -(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.") -(defsetf buffer-region %set-buffer-region "Set a buffer's region.") -(defsetf command-name %set-command-name - "Change a Hemlock command's name.") -(defsetf line-string %set-line-string - "Replace the contents of a line.") -(defsetf last-command-type %set-last-command-type - "Set the Last-Command-Type for use by the next command.") -(defsetf prefix-argument %set-prefix-argument - "Set the prefix argument for the next command.") -(defsetf logical-char= %set-logical-char= - "Change what Logical-Char= returns for the specified arguments.") -(defsetf window-font %set-window-font - "Change the font-object associated with a font-number in a window.") -(defsetf default-font %set-default-font - "Change the font-object associated with a font-number in new windows.") - -(defsetf buffer-modeline-fields %set-buffer-modeline-fields - "Sets the buffer's list of modeline fields causing all windows into buffer - to be updated for the next redisplay.") -(defsetf modeline-field-name %set-modeline-field-name - "Sets a modeline-field's name. If one already exists with that name, an - error is signaled.") -(defsetf modeline-field-width %set-modeline-field-width - "Sets a modeline-field's width and updates all the fields for all windows - in any buffer whose fields list contains the field.") -(defsetf modeline-field-function %set-modeline-field-function - "Sets a modeline-field's function and updates this field for all windows in - any buffer whose fields list contains the field.") diff --git a/hemlock/syntax.lisp b/hemlock/syntax.lisp deleted file mode 100644 index 08a6b1f122e81280ab4b48fc3d056f41f44d1a1b..0000000000000000000000000000000000000000 --- a/hemlock/syntax.lisp +++ /dev/null @@ -1,565 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Hemlock syntax table routines. -;;; -;;; Written by Rob MacLachlan. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(character-attribute-name - defattribute character-attribute-documentation character-attribute - character-attribute-hooks character-attribute-p shadow-attribute - unshadow-attribute find-attribute reverse-find-attribute)) - -;;;; Character attribute caching. -;;; -;;; In order to permit the %SP-Find-Character-With-Attribute sub-primitive -;;; to be used for a fast implementation of find-attribute and -;;; reverse-find-attribute, there must be some way of translating -;;; attribute/test-function pairs into a attribute vector and a mask. -;;; What we do is maintain a eq-hash-cache of attribute/test-function -;;; pairs. If the desired pair is not in the cache then we reclaim an old -;;; attribute bit in the bucket we hashed to and stuff it by calling the -;;; test function on the value of the attribute for all characters. - -(defvar *character-attribute-cache* () - "This is the cache used to translate attribute/test-function pairs to - attribute-vector/mask pairs for find-attribute and reverse-find-attribute.") - -(eval-when (compile eval) -(defconstant character-attribute-cache-size 13 - "The number of buckets in the *character-attribute-cache*.") -(defconstant character-attribute-bucket-size 3 - "The number of bits to use in each bucket of the - *character-attribute-cache*.") -); eval-when (compile eval) - -;;; In addition, since a common pattern in code which uses find-attribute -;;; is to repeatedly call it with the same function and attribute, we -;;; remember the last attribute/test-function pair that was used, and check -;;; if it is the same pair beforehand, thus often avoiding the hastable lookup. -;;; -(defvar *last-find-attribute-attribute* () - "The attribute which we last did a find-attribute on.") -(defvar *last-find-attribute-function* () - "The last test-function used for find-attribute.") -(defvar *last-find-attribute-vector* () - "The %SP-Find-Character-With-Attribute vector corresponding to the last - attribute/function pair used for find-attribute.") -(defvar *last-find-attribute-mask* () - "The the mask to use with *last-find-attribute-vector* to do a search - for the last attribute/test-function pair.") -(defvar *last-find-attribute-end-wins* () - "The the value of End-Wins for the last attribute/test-function pair.") - - -(defvar *character-attributes* (make-hash-table :test #'eq) - "A hash table which translates character attributes to their values.") -(defvar *last-character-attribute-requested* nil - "The last character attribute which was asked for, Do Not Bind.") -(defvar *value-of-last-character-attribute-requested* nil - "The value of the most recent character attribute, Do Not Bind.") - -(proclaim '(special *character-attribute-names*)) - - -;;; Each bucket contains a list of character-attribute-bucket-size -;;; bit-descriptors. -;;; -(defstruct (bit-descriptor) - function ; The test on the attribute. - attribute ; The attribute this is a test of. - (mask 0 :type fixnum) ; The mask for the corresponding bit. - vector ; The vector the bit is in. - end-wins) ; Is this test true of buffer ends? - -;;; -;;; In a descriptor for an unused bit, the function is nil, preventing a -;;; hit. Whenever we change the value of an attribute for some character, -;;; we need to flush the cache of any entries for that attribute. Currently -;;; we do this by mapping down the list of all bit descriptors. Note that -;;; we don't have to worry about GC, since this is just a hint. -;;; -(defvar *all-bit-descriptors* () "The list of all the bit descriptors.") - -(eval-when (compile eval) -(defmacro allocate-bit (vec bit-num) - `(progn - (when (= ,bit-num 8) - (setq ,bit-num 0 ,vec (make-array 256 :element-type '(mod 256)))) - (car (push (make-bit-descriptor - :vector ,vec - :mask (ash 1 (prog1 ,bit-num (incf ,bit-num)))) - *all-bit-descriptors*))))) -;;; -(defun %init-syntax-table () - (let ((tab (make-array character-attribute-cache-size)) - (bit-num 8) vec) - (setq *character-attribute-cache* tab) - (dotimes (c character-attribute-cache-size) - (setf (svref tab c) - (do ((i 0 (1+ i)) - (res ())) - ((= i character-attribute-bucket-size) res) - (push (allocate-bit vec bit-num) res)))))) - -(eval-when (compile eval) -(defmacro hash-it (attribute function) - `(abs (rem (logxor (ash (lisp::%sp-make-fixnum ,attribute) -3) - (lisp::%sp-make-fixnum ,function)) - character-attribute-cache-size))) - -;;; CACHED-ATTRIBUTE-LOOKUP -- Internal -;;; -;;; Sets Vector and Mask such that they can be used as arguments -;;; to %sp-find-character-with-attribute to effect a search with attribute -;;; Attribute and test Function. If the function and attribute -;;; are the same as the last ones then we just set them to that, otherwise -;;; we do the hash-cache lookup and update the *last-find-attribute-<mumble>* -;;; -(defmacro cached-attribute-lookup (attribute function vector mask end-wins) - `(if (and (eq ,function *last-find-attribute-function*) - (eq ,attribute *last-find-attribute-attribute*)) - (setq ,vector *last-find-attribute-vector* - ,mask *last-find-attribute-mask* - ,end-wins *last-find-attribute-end-wins*) - (let ((bit (svref *character-attribute-cache* - (hash-it ,attribute ,function)))) - ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins) - (new-cache-attribute ,attribute ,function)) - `(let ((b (car bit))) - (cond - ((and (eq (bit-descriptor-function b) - ,function) - (eq (bit-descriptor-attribute b) - ,attribute)) - (setq ,vector (bit-descriptor-vector b) - ,mask (bit-descriptor-mask b) - ,end-wins (bit-descriptor-end-wins b))) - (t - (setq bit (cdr bit)) ,res)))) - (count 0 (1+ count))) - ((= count character-attribute-bucket-size) res)) - (setq *last-find-attribute-attribute* ,attribute - *last-find-attribute-function* ,function - *last-find-attribute-vector* ,vector - *last-find-attribute-mask* ,mask - *last-find-attribute-end-wins* ,end-wins)))) -); eval-when (compile eval) - -;;; NEW-CACHE-ATTRIBUTE -- Internal -;;; -;;; Pick out an old attribute to punt out of the cache and put in the -;;; new one. We pick a bit off of the end of the bucket and pull it around -;;; to the beginning to get a degree of LRU'ness. -;;; -(defun new-cache-attribute (attribute function) - (let* ((hash (hash-it attribute function)) - (values (gethash attribute *character-attributes*)) - (bucket (svref *character-attribute-cache* hash)) - (bit (nthcdr (- character-attribute-bucket-size 2) bucket)) - (end-wins (funcall function (attribute-descriptor-end-value values)))) - (unless values - (error "~S is not a defined character attribute." attribute)) - (shiftf bit (cdr bit) nil) - (setf (svref *character-attribute-cache* hash) bit - (cdr bit) bucket bit (car bit)) - (setf (bit-descriptor-attribute bit) attribute - (bit-descriptor-function bit) function - (bit-descriptor-end-wins bit) end-wins) - (setq values (attribute-descriptor-vector values)) - (do ((mask (bit-descriptor-mask bit)) - (fun (bit-descriptor-function bit)) - (vec (bit-descriptor-vector bit)) - (i 0 (1+ i))) - ((= i syntax-char-code-limit) (values vec mask end-wins)) - (declare (type (simple-array (mod 256)) vec)) - (if (funcall fun (aref (the simple-array values) i)) - (setf (aref vec i) (logior (aref vec i) mask)) - (setf (aref vec i) (logandc2 (aref vec i) mask)))))) - -(defun %print-attribute-descriptor (object stream depth) - (declare (ignore depth)) - (format stream "#<Hemlock Attribute-Descriptor ~S>" - (attribute-descriptor-name object))) - -;;; DEFATTRIBUTE -- Public -;;; -;;; Make a new vector of some type and enter it in the table. -;;; -(defun defattribute (name documentation &optional (type '(mod 2)) - (initial-value 0)) - "Define a new Hemlock character attribute with named Name with - the supplied Documentation, Type and Initial-Value. Type - defaults to (mod 2) and Initial-Value defaults to 0." - (setq name (coerce name 'simple-string)) - (let* ((attribute (string-to-keyword name)) - (new (make-attribute-descriptor - :vector (make-array syntax-char-code-limit - :element-type type - :initial-element initial-value) - :name name - :keyword attribute - :documentation documentation - :end-value initial-value))) - (when (gethash attribute *character-attributes*) - (warn "Character Attribute ~S is being redefined." name)) - (setf (getstring name *character-attribute-names*) attribute) - (setf (gethash attribute *character-attributes*) new)) - name) - -;;; WITH-ATTRIBUTE -- Internal -;;; -;;; Bind obj to the attribute descriptor corresponding to symbol, -;;; giving error if it is not a defined attribute. -;;; -(eval-when (compile eval) -(defmacro with-attribute (symbol &body forms) - `(let ((obj (gethash ,symbol *character-attributes*))) - (unless obj - (error "~S is not a defined character attribute." ,symbol)) - ,@forms)) -); eval-when (compile eval) - -(defun character-attribute-name (attribute) - "Return the string-name of the character-attribute Attribute." - (with-attribute attribute - (attribute-descriptor-name obj))) - -(defun character-attribute-documentation (attribute) - "Return the documentation for the character-attribute Attribute." - (with-attribute attribute - (attribute-descriptor-documentation obj))) - -(defun character-attribute-hooks (attribute) - "Return the hook-list for the character-attribute Attribute. This can - be set with Setf." - (with-attribute attribute - (attribute-descriptor-hooks obj))) - -(defun %set-character-attribute-hooks (attribute new-value) - (with-attribute attribute - (setf (attribute-descriptor-hooks obj) new-value))) - -(proclaim '(special *last-character-attribute-requested* - *value-of-last-character-attribute-requested*)) - -;;; CHARACTER-ATTRIBUTE -- Public -;;; -;;; Return the value of a character attribute for some character. -;;; -(proclaim '(inline character-attribute)) -(defun character-attribute (attribute character) - "Return the value of the the character-attribute Attribute for Character. - If Character is Nil then return the end-value." - (if (and (eq attribute *last-character-attribute-requested*) character) - (aref (the simple-array *value-of-last-character-attribute-requested*) - (syntax-char-code character)) - (sub-character-attribute attribute character))) -;;; -(defun sub-character-attribute (attribute character) - (with-attribute attribute - (setq *last-character-attribute-requested* attribute) - (setq *value-of-last-character-attribute-requested* - (attribute-descriptor-vector obj)) - (if character - (aref (the simple-array *value-of-last-character-attribute-requested*) - (syntax-char-code character)) - (attribute-descriptor-end-value obj)))) - -;;; CHARACTER-ATTRIBUTE-P -;;; -;;; Look up attribute in table. -;;; -(defun character-attribute-p (symbol) - "Return true if Symbol is the symbol-name of a character-attribute, Nil - otherwise." - (not (null (gethash symbol *character-attributes*)))) - - -;;; %SET-CHARACTER-ATTRIBUTE -- Internal -;;; -;;; Set the value of a character attribute. -;;; -(defun %set-character-attribute (attribute character new-value) - (with-attribute attribute - (invoke-hook ed::character-attribute-hook attribute character new-value) - (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value) - (cond - ;; - ;; Setting the value for a real character. - (character - (let ((value (attribute-descriptor-vector obj)) - (code (syntax-char-code character))) - (declare (type (simple-array *) value)) - (dolist (bit *all-bit-descriptors*) - (when (eq (bit-descriptor-attribute bit) attribute) - (let ((vec (bit-descriptor-vector bit))) - (declare (type (simple-array (mod 256)) vec)) - (setf (aref vec code) - (if (funcall (bit-descriptor-function bit) new-value) - (logior (bit-descriptor-mask bit) (aref vec code)) - (logandc1 (bit-descriptor-mask bit) (aref vec code))))))) - (setf (aref value code) new-value))) - ;; - ;; Setting the magical end-value. - (t - (setf (attribute-descriptor-end-value obj) new-value) - (dolist (bit *all-bit-descriptors*) - (when (eq (bit-descriptor-attribute bit) attribute) - (setf (bit-descriptor-end-wins bit) - (funcall (bit-descriptor-function bit) new-value)))) - new-value)))) - -(eval-when (compile eval) -;;; swap-one-attribute -- Internal -;;; -;;; Install the mode-local values described by Vals for Attribute, whose -;;; representation vector is Value. -;;; - (defmacro swap-one-attribute (attribute value vals hooks) - `(progn - ;; Fix up any cached attribute vectors. - (dolist (bit *all-bit-descriptors*) - (when (eq ,attribute (bit-descriptor-attribute bit)) - (let ((fun (bit-descriptor-function bit)) - (vec (bit-descriptor-vector bit)) - (mask (bit-descriptor-mask bit))) - (declare (type (simple-array (mod 256)) vec) - (fixnum mask)) - (dolist (char ,vals) - (setf (aref vec (car char)) - (if (funcall fun (cdr char)) - (logior mask (aref vec (car char))) - (logandc1 mask (aref vec (car char))))))))) - ;; Invoke the attribute-hook. - (dolist (hook ,hooks) - (dolist (char ,vals) - (funcall hook ,attribute (code-char (car char)) (cdr char)))) - ;; Fix up the value vector. - (dolist (char ,vals) - (rotatef (aref ,value (car char)) (cdr char))))) -); eval-when (compile eval) - - -;;; SWAP-CHAR-ATTRIBUTES -- Internal -;;; -;;; Swap the current values of character attributes and the ones -;;;specified by "mode". This is used in Set-Major-Mode. -;;; -(defun swap-char-attributes (mode) - (dolist (attribute (mode-object-character-attributes mode)) - (let* ((obj (car attribute)) - (sym (attribute-descriptor-keyword obj)) - (value (attribute-descriptor-vector obj)) - (hooks (attribute-descriptor-hooks obj))) - (declare (simple-array value)) - (swap-one-attribute sym value (cdr attribute) hooks)))) - - - -(proclaim '(special *mode-names* *current-buffer*)) - -;;; SHADOW-ATTRIBUTE -- Public -;;; -;;; Stick mode character attribute information in the mode object. -;;; -(defun shadow-attribute (attribute character value mode) - "Make a mode specific character attribute value. The value of - Attribute for Character when we are in Mode will be Value." - (let ((desc (gethash attribute *character-attributes*)) - (obj (getstring mode *mode-names*))) - (unless desc - (error "~S is not a defined Character Attribute." attribute)) - (unless obj (error "~S is not a defined Mode." mode)) - (let* ((current (assq desc (mode-object-character-attributes obj))) - (code (syntax-char-code character)) - (hooks (attribute-descriptor-hooks desc)) - (vec (attribute-descriptor-vector desc)) - (cons (cons code value))) - (declare (simple-array vec)) - (if current - (let ((old (assq code (cdr current)))) - (if old - (setf (cdr old) value cons old) - (push cons (cdr current)))) - (push (list desc cons) - (mode-object-character-attributes obj))) - (when (memq obj (buffer-mode-objects *current-buffer*)) - (let ((vals (list cons))) - (swap-one-attribute attribute vec vals hooks))) - (invoke-hook ed::shadow-attribute-hook attribute character value mode))) - attribute) - -;;; UNSHADOW-ATTRIBUTE -- Public -;;; -;;; Nuke a mode character attribute. -;;; -(defun unshadow-attribute (attribute character mode) - "Make the value of Attribte for Character no longer shadowed in Mode." - (let ((desc (gethash attribute *character-attributes*)) - (obj (getstring mode *mode-names*))) - (unless desc - (error "~S is not a defined Character Attribute." attribute)) - (unless obj - (error "~S is not a defined Mode." mode)) - (invoke-hook ed::shadow-attribute-hook mode attribute character) - (let* ((value (attribute-descriptor-vector desc)) - (hooks (attribute-descriptor-hooks desc)) - (current (assq desc (mode-object-character-attributes obj))) - (char (assq (syntax-char-code character) (cdr current)))) - (declare (simple-array value)) - (unless char - (error "Character Attribute ~S is not defined for character ~S ~ - in Mode ~S." attribute character mode)) - (when (memq obj (buffer-mode-objects *current-buffer*)) - (let ((vals (list char))) - (swap-one-attribute attribute value vals hooks))) - (setf (cdr current) (delete char (the list (cdr current)))))) - attribute) - - -;;; NOT-ZEROP, the default test function for find-attribute etc. -;;; -(defun not-zerop (n) - (not (zerop n))) - -;;; find-attribute -- Public -;;; -;;; Do hairy cache lookup to find a find-character-with-attribute style -;;; vector that we can use to do the search. -;;; -(eval-when (compile eval) -(defmacro normal-find-attribute (line start result vector mask) - `(let ((chars (line-chars ,line))) - (setq ,result (%sp-find-character-with-attribute - chars ,start (strlen chars) ,vector ,mask)))) -;;; -(defmacro cache-find-attribute (start result vector mask) - `(let ((gap (- right-open-pos left-open-pos))) - (declare (fixnum gap)) - (cond - ((>= ,start left-open-pos) - (setq ,result - (%sp-find-character-with-attribute - open-chars (+ ,start gap) line-cache-length ,vector ,mask)) - (when ,result (decf ,result gap))) - ((setq ,result (%sp-find-character-with-attribute - open-chars ,start left-open-pos ,vector ,mask))) - (t - (setq ,result - (%sp-find-character-with-attribute - open-chars right-open-pos line-cache-length ,vector ,mask)) - (when ,result (decf ,result gap)))))) -); eval-when (compile eval) -;;; -(defun find-attribute (mark attribute &optional (test #'not-zerop)) - "Find the next character whose attribute value satisfies test." - (let ((charpos (mark-charpos mark)) - (line (mark-line mark)) vector mask end-wins) - (declare (type (simple-array (mod 256)) vector) (fixnum mask)) - (cached-attribute-lookup attribute test vector mask end-wins) - (cond - ((cond - ((eq line open-line) - (when (cache-find-attribute charpos charpos vector mask) - (setf (mark-charpos mark) charpos) mark)) - (t - (when (normal-find-attribute line charpos charpos vector mask) - (setf (mark-charpos mark) charpos) mark)))) - ;; Newlines win and there is one. - ((and (not (zerop (logand mask (aref vector (char-code #\newline))))) - (line-next line)) - (move-to-position mark (line-length line) line)) - ;; We can ignore newlines. - (t - (do (prev) - (()) - (setq prev line line (line-next line)) - (cond - ((null line) - (if end-wins - (return (line-end mark prev)) - (return nil))) - ((eq line open-line) - (when (cache-find-attribute 0 charpos vector mask) - (return (move-to-position mark charpos line)))) - (t - (when (normal-find-attribute line 0 charpos vector mask) - (return (move-to-position mark charpos line)))))))))) - - -;;; REVERSE-FIND-ATTRIBUTE -- Public -;;; -;;; Line find-attribute, only goes backwards. -;;; -(eval-when (compile eval) -(defmacro rev-normal-find-attribute (line start result vector mask) - `(let ((chars (line-chars ,line))) - (setq ,result (%sp-reverse-find-character-with-attribute - chars 0 ,(or start '(strlen chars)) ,vector ,mask)))) -;;; -(defmacro rev-cache-find-attribute (start result vector mask) - `(let ((gap (- right-open-pos left-open-pos))) - (declare (fixnum gap)) - (cond - ,@(when start - `(((<= ,start left-open-pos) - (setq ,result - (%sp-reverse-find-character-with-attribute - open-chars 0 ,start ,vector ,mask))))) - ((setq ,result (%sp-reverse-find-character-with-attribute - open-chars right-open-pos - ,(if start `(+ ,start gap) 'line-cache-length) - ,vector ,mask)) - (decf ,result gap)) - (t - (setq ,result - (%sp-reverse-find-character-with-attribute - open-chars 0 left-open-pos ,vector ,mask)))))) - -); eval-when (compile eval) -;;; -(defun reverse-find-attribute (mark attribute &optional (test #'not-zerop)) - "Find the previous character whose attribute value satisfies test." - (let* ((charpos (mark-charpos mark)) - (line (mark-line mark)) vector mask end-wins) - (declare (type (simple-array (mod 256)) vector) - (fixnum charpos)) - (cached-attribute-lookup attribute test vector mask end-wins) - (cond - ((cond - ((eq line open-line) - (when (rev-cache-find-attribute charpos charpos vector mask) - (setf (mark-charpos mark) (1+ charpos)) mark)) - (t - (when (rev-normal-find-attribute line charpos charpos vector mask) - (setf (mark-charpos mark) (1+ charpos)) mark)))) - ;; Newlines win and there is one. - ((and (line-previous line) - (not (zerop (logand mask (aref vector (char-code #\newline)))))) - (move-to-position mark 0 line)) - (t - (do (next) - (()) - (setq next line line (line-previous line)) - (cond - ((null line) - (if end-wins - (return (line-start mark next)) - (return nil))) - ((eq line open-line) - (when (rev-cache-find-attribute nil charpos vector mask) - (return (move-to-position mark (1+ charpos) line)))) - (t - (when (rev-normal-find-attribute line nil charpos vector mask) - (return (move-to-position mark (1+ charpos) line)))))))))) diff --git a/hemlock/table.lisp b/hemlock/table.lisp deleted file mode 100644 index f046f15abad5c30f4b142ceaeebb94fd2b6d64b8..0000000000000000000000000000000000000000 --- a/hemlock/table.lisp +++ /dev/null @@ -1,744 +0,0 @@ -;;; -*- Log: hemlock.log; Package: HEMLOCK-INTERNALS -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU). -;;; ********************************************************************** -;;; -;;; Reluctantly written by Christopher Hoover -;;; Supporting cast includes Rob and Bill. -;;; -;;; This file defines a data structure, analogous to a Common Lisp -;;; hashtable, which translates strings to values and facilitates -;;; recognition and completion of these strings. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(string-table string-table-p make-string-table - string-table-separator getstring - find-ambiguous complete-string find-containing - delete-string clrstring do-strings)) - - -;;;; Implementation Details - -;;; String tables are a data structure somewhat analogous to Common Lisp -;;; hashtables. String tables are case-insensitive. Functions are -;;; provided to quickly look up strings, insert strings, disambiguate or -;;; complete strings, and to provide a variety of ``help'' when -;;; disambiguating or completing strings. -;;; -;;; String tables are represented as a series of word tables which form -;;; a tree. Four structures are used to implement this data structure. -;;; The first is a STRING-TABLE. This structure has severals slots one -;;; of which, FIRST-WORD-TABLE, points to the first word table. This -;;; first word table is also the root of tree. The STRING-TABLE -;;; structure also contains slots to keep track of the number of nodes, -;;; the string table separator (which is used to distinguish word or -;;; field boundaries), and a pointer to an array of VALUE-NODE's. -;;; -;;; A WORD-TABLE is simply an array of pointers to WORD-ENTRY's. This -;;; array is kept sorted by the FOLDED slot in each WORD-ENTRY so that a -;;; binary search can be used. Each WORD-ENTRY contains a case-folded -;;; string and a pointer to the next WORD-TABLE in the tree. By -;;; traversing the tree made up by these structures, searching and -;;; completion can easily be done. -;;; -;;; Another structure, a VALUE-NODE, is used to hold each entry in the -;;; string table and contains both a copy of the original string and a -;;; case-folded version of the original string along with the value. -;;; All of these value nodes are stored in a array (pointed at by the -;;; VALUE-NODES slot of the STRING-TABLE structure) and sorted by the -;;; FOLDED slot in the VALUE-NODE structure so that a binary search may -;;; be used to quickly find existing strings. -;;; - - -;;;; Structure Definitions - -(defparameter initial-string-table-size 20 - "Initial size of string table array for value nodes.") -(defparameter initial-word-table-size 10 - "Inital size of each word table array for each tree node.") - -(defstruct (string-table - (:constructor %make-string-table (separator)) - (:print-function print-string-table)) - "This structure is used to implement the Hemlock string-table type." - ;; Character used to - (separator #\Space :type string-char) ; character used for word separator - (num-nodes 0 :type fixnum) ; number of nodes in string table - (value-nodes (make-array initial-string-table-size)) ; value node array - (first-word-table (make-word-table))) ; pointer to first WORD-TABLE - -(defun print-string-table (table stream depth) - (declare (ignore table depth)) - (format stream "#<String Table>")) - -(defun make-string-table (&key (separator #\Space) initial-contents) - "Creates and returns a Hemlock string-table. If Intitial-Contents is - supplied in the form of an A-list of string-value pairs, these pairs - will be used to initialize the table. If Separator, which must be a - string-char, is specified then it will be used to distinguish word - boundaries." - (let ((table (%make-string-table separator))) - (dolist (x initial-contents) - (setf (getstring (car x) table) (cdr x))) - table)) - - -(defstruct (word-table - (:print-function print-word-table)) - "This structure is a word-table which is part of a Hemlock string-table." - (num-words 0 :type fixnum) ; Number of words - (words (make-array initial-word-table-size))) ; Array of WORD-ENTRY's - -(defun print-word-table (table stream depth) - (declare (ignore table depth)) - (format stream "#<Word Table>")) - - -(defstruct (word-entry - (:constructor make-word-entry (folded)) - (:print-function print-word-entry)) - "This structure is an entry in a word table which is part of a Hemlock - string-table." - next-table ; Pointer to next WORD-TABLE - folded ; Downcased word - value-node) ; Pointer to value node or NIL - -(defun print-word-entry (entry stream depth) - (declare (ignore depth)) - (format stream "#<Word Table Entry: \"~A\">" (word-entry-folded entry))) - - -(defstruct (value-node - (:constructor make-value-node (proper folded value)) - (:print-function print-value-node)) - "This structure is a node containing a value in a Hemlock string-table." - folded ; Downcased copy of string - proper ; Proper copy of string entry - value) ; Value of entry - -(defun print-value-node (node stream depth) - (declare (ignore depth)) - (format stream "<Value Node \"~A\">" (value-node-proper node))) - - -;;;; Bi-SvPosition, String-Compare, String-Compare* - -;;; Much like the CL function POSITION; however, this is a fast binary -;;; search for simple vectors. Vector must be a simple vector and Test -;;; must be a function which returns either :equal, :less, or :greater. -;;; (The vector must be sorted from lowest index to highest index by the -;;; Test function.) Two values are returned: the first is the position -;;; Item was found or if it was not found, where it should be inserted; -;;; the second is a boolean flag indicating whether or not Item was -;;; found. -;;; -(defun bi-svposition (item vector test &key (start 0) end key) - (declare (simple-vector vector) (fixnum start)) - (let ((low start) - (high (if end end (length vector))) - (mid 0)) - (declare (fixnum low high mid)) - (loop - (when (< high low) (return (values low nil))) - (setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low)) - (let* ((array-item (svref vector mid)) - (test-item (if key (funcall key array-item) array-item))) - (ecase (funcall test item test-item) - (:equal (return (values mid t))) - (:less (setf high (1- mid))) - (:greater (setf low (1+ mid)))))))) - -;;; A simple-string comparison appropriate for use with BI-SVPOSITION. -;;; -(defun string-compare (s1 s2 &key (start1 0) end1 (start2 0) end2) - (declare (simple-string s1 s2) (fixnum start1 start2)) - (let* ((end1 (or end1 (length s1))) - (end2 (or end2 (length s2))) - (pos1 (string/= s1 s2 - :start1 start1 :end1 end1 :start2 start2 :end2 end2))) - (if (null pos1) - :equal - (let ((pos2 (+ (the fixnum pos1) (- start2 start1)))) - (declare (fixnum pos2)) - (cond ((= pos1 (the fixnum end1)) :less) - ((= pos2 (the fixnum end2)) :greater) - ((char< (schar s1 (the fixnum pos1)) (schar s2 pos2)) :less) - (t :greater)))))) - -;;; Macro to return a closure to call STRING-COMPARE with the given -;;; keys. -;;; -(defmacro string-compare* (&rest keys) - `#'(lambda (x y) (string-compare x y ,@keys))) - - -;;;; Insert-Element, Nconcf - -(eval-when (compile eval) - -;;; Insert-Element is a macro which encapsulates the hairiness of -;;; inserting an element into a simple vector. Vector should be a -;;; simple vector with Num elements (which may be less than or equal to -;;; the length of the vector) and Element is the element to insert at -;;; Pos. The optional argument Grow-Factor may be specified to control -;;; the new size of the array if a new vector is necessary. The result -;;; of INSERT-ELEMENT must be used as a new vector may be created. -;;; (Note that the arguments should probably be lexicals since some of -;;; them are evaluated more than once.) -;;; -(defmacro insert-element (vector pos element num &optional (grow-factor 2)) - `(let ((new-num (1+ ,num)) - (max (length ,vector))) - (declare (fixnum new-num max)) - (cond ((= ,num max) - ;; grow the vector - (let ((new (make-array (truncate (* max ,grow-factor))))) - (declare (simple-vector new)) - ;; Blt the new buggers into place leaving a space for - ;; the new element - (replace new ,vector :end1 ,pos :end2 ,pos) - (replace new ,vector :start1 (1+ ,pos) :end1 new-num - :start2 ,pos :end2 ,num) - (setf (svref new ,pos) ,element) - new)) - (t - ;; move the buggers down a slot - (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos) - (setf (svref ,vector ,pos) ,element) - ,vector))))) - -(define-modify-macro nconcf (&rest args) nconc) - -) ; eval-when - - -;;;; With-Folded-String, Do-Words - -;;; With-Folded-String is a macro which deals with strings from the -;;; user. First, if the original string is not a simple string then it -;;; is coerced to one. Next, the string is trimmed using the separator -;;; character and all separators between words are collapsed to a single -;;; separator. The word boundaries are pushed on to a list so that the -;;; Do-Words macro can be called anywhere within the dynamic extent of a -;;; With-Folded-String to ``do'' over the words. - -(defvar *string-buffer-size* 128) -(defvar *string-buffer* (make-string *string-buffer-size*)) -(proclaim '(simple-string *string-buffer*)) - -(defvar *separator-positions* nil) - -(eval-when (compile eval) - -(defmacro do-words ((start-var end-var) &body (body decls)) - (let ((sep-pos (gensym))) - `(dolist (,sep-pos *separator-positions*) - (let ((,start-var (car ,sep-pos)) - (,end-var (cdr ,sep-pos))) - ,@decls - ,@body)))) - -(defmacro with-folded-string ((str-var len-var orig-str separator) - &body (body decls)) - `(let ((,str-var *string-buffer*)) - (declare (simple-string ,str-var)) - ;; make the string simple if it isn't already - (unless (simple-string-p ,orig-str) - (setq ,orig-str (coerce ,orig-str 'simple-string))) - ;; munge it into *string-buffer* and do the body - (let ((,len-var (with-folded-munge-string ,orig-str ,separator))) - ,@decls - ,@body))) - -) ; eval-when - -(defun with-folded-munge-string (str separator) - (declare (simple-string str) (string-char separator)) - (let ((str-len (length str)) - (sep-pos nil) - (buf-pos 0)) - ;; Make sure we have enough room to blt the string into place. - (when (> str-len *string-buffer-size*) - (setq *string-buffer-size* (* str-len 2)) - (setq *string-buffer* (make-string *string-buffer-size*))) - ;; Bash the spaces out of the string remembering where the words are. - (let ((start-pos (position separator str :test-not #'char=))) - (when start-pos - (loop - (let* ((end-pos (position separator str - :start start-pos :test #'char=)) - (next-start-pos (and end-pos (position separator str - :start end-pos - :test-not #'char=))) - (word-len (- (or end-pos str-len) start-pos)) - (new-buf-pos (+ buf-pos word-len))) - (replace *string-buffer* str - :start1 buf-pos :start2 start-pos :end2 end-pos) - (push (cons buf-pos new-buf-pos) sep-pos) - (setf buf-pos new-buf-pos) - (when (or (null end-pos) (null next-start-pos)) - (return)) - (setf start-pos next-start-pos) - (setf (schar *string-buffer* buf-pos) separator) - (incf buf-pos))))) - (nstring-downcase *string-buffer* :end buf-pos) - (setf *separator-positions* (nreverse sep-pos)) - buf-pos)) - - -;;;; Getstring, Setf Method for Getstring - -(defun getstring (string string-table) - "Looks up String in String-Table. Returns two values: the first is - the value of String or NIL if it does not exist; the second is a - boolean flag indicating whether or not String was found in - String-Table." - (with-folded-string (folded len string (string-table-separator string-table)) - (let ((nodes (string-table-value-nodes string-table)) - (num-nodes (string-table-num-nodes string-table))) - (declare (simple-vector nodes) (fixnum num-nodes)) - (multiple-value-bind - (pos found-p) - (bi-svposition folded nodes (string-compare* :end1 len) - :end (1- num-nodes) :key #'value-node-folded) - (if found-p - (values (value-node-value (svref nodes pos)) t) - (values nil nil)))))) - -(defun %set-string-table (string table value) - "Sets the value of String in Table to Value. If necessary, creates - a new entry in the string table." - (with-folded-string (folded len string (string-table-separator table)) - (when (zerop len) - (error "An empty string cannot be inserted into a string-table.")) - (let ((nodes (string-table-value-nodes table)) - (num-nodes (string-table-num-nodes table))) - (declare (simple-string folded) (simple-vector nodes) (fixnum num-nodes)) - (multiple-value-bind - (pos found-p) - (bi-svposition folded nodes (string-compare* :end1 len) - :end (1- num-nodes) :key #'value-node-folded) - (cond (found-p - (setf (value-node-value (svref nodes pos)) value)) - (t - ;; Note that a separator collapsed copy of string is NOT - ;; used here ... - ;; - (let ((node (make-value-node string (subseq folded 0 len) value)) - (word-table (string-table-first-word-table table))) - ;; put in the value nodes array - (setf (string-table-value-nodes table) - (insert-element nodes pos node num-nodes)) - (incf (string-table-num-nodes table)) - ;; insert it into the word tree - (%set-insert-words folded word-table node)))))) - value)) - -(defun %set-insert-words (folded first-word-table value-node) - (declare (simple-string folded)) - (let ((word-table first-word-table) - (entry nil)) - (do-words (word-start word-end) - (let ((word-array (word-table-words word-table)) - (num-words (word-table-num-words word-table))) - (declare (simple-vector word-array) (fixnum num-words)) - ;; find the entry or create a new one and insert it - (multiple-value-bind - (pos found-p) - (bi-svposition folded word-array - (string-compare* :start1 word-start :end1 word-end) - :end (1- num-words) :key #'word-entry-folded) - (declare (fixnum pos)) - (cond (found-p - (setf entry (svref word-array pos))) - (t - (setf entry (make-word-entry - (subseq folded word-start word-end))) - (setf (word-table-words word-table) - (insert-element word-array pos entry num-words)) - (incf (word-table-num-words word-table))))) - (let ((next-table (word-entry-next-table entry))) - (unless next-table - (setf next-table (make-word-table)) - (setf (word-entry-next-table entry) next-table)) - (setf word-table next-table)))) - (setf (word-entry-value-node entry) value-node))) - - -;;;; Find-Bound-Entries - -(defun find-bound-entries (word-entries) - (let ((res nil)) - (dolist (entry word-entries) - (nconcf res (sub-find-bound-entries entry))) - res)) - -(defun sub-find-bound-entries (entry) - (let ((bound-entries nil)) - (when (word-entry-value-node entry) (push entry bound-entries)) - (let ((next-table (word-entry-next-table entry))) - (when next-table - (let ((word-array (word-table-words next-table)) - (num-words (word-table-num-words next-table))) - (declare (simple-vector word-array) (fixnum num-words)) - (dotimes (i num-words) - (declare (fixnum i)) - (nconcf bound-entries - (sub-find-bound-entries (svref word-array i))))))) - bound-entries)) - - -;;;; Find-Ambiguous - -(defun find-ambiguous (string string-table) - "Returns a list, in alphabetical order, of all the strings in String-Table - which String matches." - (with-folded-string (folded len string (string-table-separator string-table)) - (find-ambiguous* folded len string-table))) - -(defun find-ambiguous* (folded len table) - (let ((word-table (string-table-first-word-table table)) - (word-entries nil)) - (cond ((zerop len) - (setf word-entries (find-ambiguous-entries "" 0 0 word-table))) - (t - (let ((word-tables (list word-table))) - (do-words (start end) - (setf word-entries nil) - (dolist (wt word-tables) - (nconcf word-entries - (find-ambiguous-entries folded start end wt))) - (unless word-entries (return)) - (let ((next-word-tables nil)) - (dolist (entry word-entries) - (let ((next-word-table (word-entry-next-table entry))) - (when next-word-table - (push next-word-table next-word-tables)))) - (unless next-word-tables (return)) - (setf word-tables (nreverse next-word-tables))))))) - (let ((bound-entries (find-bound-entries word-entries)) - (res nil)) - (dolist (be bound-entries) - (push (value-node-proper (word-entry-value-node be)) res)) - (nreverse res)))) - -(defun find-ambiguous-entries (folded start end word-table) - (let ((word-array (word-table-words word-table)) - (num-words (word-table-num-words word-table)) - (res nil)) - (declare (simple-vector word-array) (fixnum num-words)) - (unless (zerop num-words) - (multiple-value-bind - (pos found-p) - (bi-svposition folded word-array - (string-compare* :start1 start :end1 end) - :end (1- num-words) :key #'word-entry-folded) - (declare (ignore found-p)) - ;; - ;; Find last ambiguous string, checking for the end of the table. - (do ((i pos (1+ i))) - ((= i num-words)) - (declare (fixnum i)) - (let* ((entry (svref word-array i)) - (str (word-entry-folded entry)) - (str-len (length str)) - (index (string/= folded str :start1 start :end1 end - :end2 str-len))) - (declare (simple-string str) (fixnum str-len)) - (when (and index (/= index end)) (return nil)) - (push entry res))) - (setf res (nreverse res)) - ;; - ;; Scan back to the first string, checking for the beginning. - (do ((i (1- pos) (1- i))) - ((minusp i)) - (declare (fixnum i)) - (let* ((entry (svref word-array i)) - (str (word-entry-folded entry)) - (str-len (length str)) - (index (string/= folded str :start1 start :end1 end - :end2 str-len))) - (declare (simple-string str) (fixnum str-len)) - (when (and index (/= index end)) (return nil)) - (push entry res))))) - res)) - - -;;;; Find-Containing - -(defun find-containing (string string-table) - "Return a list in alphabetical order of all the strings in Table which - contain String as a substring." - (with-folded-string (folded len string (string-table-separator string-table)) - (declare (ignore len)) - (let ((word-table (string-table-first-word-table string-table)) - (words nil)) - ;; cons up a list of the words - (do-words (start end) - (push (subseq folded start end) words)) - (setf words (nreverse words)) - (let ((entries (sub-find-containing words word-table)) - (res nil)) - (dolist (e entries) - (push (value-node-proper (word-entry-value-node e)) res)) - (nreverse res))))) - -(defun sub-find-containing (words word-table) - (let ((res nil) - (word-array (word-table-words word-table)) - (num-words (word-table-num-words word-table))) - (declare (simple-vector word-array) (fixnum num-words)) - (dotimes (i num-words) - (declare (fixnum i)) - (let* ((entry (svref word-array i)) - (word (word-entry-folded entry)) - (found (find word words - :test #'(lambda (y x) - (let ((lx (length x)) - (ly (length y))) - (and (<= lx ly) - (string= x y :end2 lx)))))) - (rest-words (if found - (remove found words :test #'eq :count 1) - words))) - (declare (simple-string word)) - (cond (rest-words - (let ((next-table (word-entry-next-table entry))) - (when next-table - (nconcf res (sub-find-containing rest-words next-table))))) - (t - (nconcf res (sub-find-bound-entries entry)))))) - res)) - - -;;;; Complete-String - -(defvar *complete-string-buffer-size* 128) -(defvar *complete-string-buffer* (make-string *complete-string-buffer-size*)) -(proclaim '(simple-string *complete-string-buffer*)) - -(defun complete-string (string tables) - "Attempts to complete the string String against the string tables in the - list Tables. Tables must all use the same separator character. See the - manual for details on return values." - (let ((separator (string-table-separator (car tables)))) - #|(when (member separator (cdr tables) - :key #'string-table-separator :test-not #'char=) - (error "All tables must have the same separator."))|# - (with-folded-string (folded len string separator) - (let ((strings nil)) - (dolist (table tables) - (nconcf strings (find-ambiguous* folded len table))) - ;; pick off easy case - (when (null strings) - (return-from complete-string (values nil :none nil nil nil))) - ;; grow complete-string buffer if necessary - (let ((size-needed (1+ len))) - (when (> size-needed *complete-string-buffer-size*) - (let* ((new-size (* size-needed 2)) - (new-buffer (make-string new-size))) - (setf *complete-string-buffer* new-buffer) - (setf *complete-string-buffer-size* new-size)))) - (multiple-value-bind - (str ambig-pos unique-p) - (find-longest-completion strings separator) - (multiple-value-bind (value found-p) (find-values str tables) - (let ((field-pos (compute-field-pos string str separator))) - (cond ((not found-p) - (values str :ambiguous nil field-pos ambig-pos)) - (unique-p - (values str :unique value field-pos nil)) - (t - (values str :complete value field-pos ambig-pos)))))))))) - -(defun find-values (string tables) - (dolist (table tables) - (multiple-value-bind (value found-p) (getstring string table) - (when found-p - (return-from find-values (values value t))))) - (values nil nil)) - -(defun compute-field-pos (given best separator) - (declare (simple-string given best) (string-char separator)) - (let ((give-pos 0) - (best-pos 0)) - (loop - (setf give-pos (position separator given :start give-pos :test #'char=)) - (setf best-pos (position separator best :start best-pos :test #'char=)) - (unless (and give-pos best-pos) (return best-pos)) - (incf (the fixnum give-pos)) - (incf (the fixnum best-pos))))) - - -;;;; Find-Longest-Completion - -(defun find-longest-completion (strings separator) - (declare (string-char separator)) - (let ((first (car strings)) - (rest-strings (cdr strings)) - (punt-p nil) - (buf-pos 0) - (first-start 0) - (first-end -1) - (ambig-pos nil) - (maybe-unique-p nil)) - (declare (simple-string first) (fixnum buf-pos first-start)) - ;; - ;; Make room to store each string's next separator index. - (do ((l rest-strings (cdr l))) - ((endp l)) - (setf (car l) (cons (car l) -1))) - ;; - ;; Compare the rest of the strings to the first one. - ;; It's our de facto standard for how far we can go. - (loop - (setf first-start (1+ first-end)) - (setf first-end - (position separator first :start first-start :test #'char=)) - (unless first-end - (setf first-end (length first)) - (setf punt-p t) - (setf maybe-unique-p t)) - (let ((first-max first-end) - (word-ambiguous-p nil)) - (declare (fixnum first-max)) - ;; - ;; For each string, store the separator's next index. - ;; If there's no separator, store nil and prepare to punt. - ;; If the string's field is not equal to the first's, shorten the max - ;; expectation for this field, and declare ambiguity. - (dolist (s rest-strings) - (let* ((str (car s)) - (str-last-pos (cdr s)) - (str-start (1+ str-last-pos)) - (str-end (position separator str - :start str-start :test #'char=)) - (index (string-not-equal first str - :start1 first-start :end1 first-max - :start2 str-start :end2 str-end))) - (declare (simple-string str) (fixnum str-last-pos str-start)) - (setf (cdr s) str-end) - (unless str-end - (setf punt-p t) - (setf str-end (length str))) - (when index - (setf word-ambiguous-p t) ; not equal for some reason - (when (< index first-max) - (setf first-max index))))) - ;; - ;; Store what we matched into the result buffer and save the - ;; ambiguous position if its the first ambiguous field. - (let ((length (- first-max first-start))) - (declare (fixnum length)) - (unless (zerop length) - (unless (zerop buf-pos) - (setf (schar *complete-string-buffer* buf-pos) separator) - (incf buf-pos)) - (replace *complete-string-buffer* first - :start1 buf-pos :start2 first-start :end2 first-max) - (incf buf-pos length)) - (when (and (null ambig-pos) word-ambiguous-p) - (setf ambig-pos buf-pos)) - (when (or punt-p (zerop length)) (return))))) - (values - (subseq *complete-string-buffer* 0 buf-pos) - ;; If every corresponding field in each possible completion was equal, - ;; our result string is an initial substring of some other completion, - ;; so we're ambiguous at the end. - (or ambig-pos buf-pos) - (and (null ambig-pos) - maybe-unique-p - (every #'(lambda (x) (null (cdr x))) rest-strings))))) - - -;;;; Clrstring - -(defun clrstring (string-table) - "Delete all the entries in String-Table." - (fill (the simple-vector (string-table-value-nodes string-table)) nil) - (setf (string-table-num-nodes string-table) 0) - (let ((word-table (string-table-first-word-table string-table))) - (fill (the simple-vector (word-table-words word-table)) nil) - (setf (word-table-num-words word-table) 0)) - t) - - -;;;; Delete-String - -(defun delete-string (string string-table) - (with-folded-string (folded len string (string-table-separator string-table)) - (when (plusp len) - (let* ((nodes (string-table-value-nodes string-table)) - (num-nodes (string-table-num-nodes string-table)) - (end (1- num-nodes))) - (declare (simple-string folded) (simple-vector nodes) - (fixnum num-nodes end)) - (multiple-value-bind - (pos found-p) - (bi-svposition folded nodes (string-compare* :end1 len) - :end end :key #'value-node-folded) - (cond (found-p - (replace nodes nodes - :start1 pos :end1 end :start2 (1+ pos) :end2 num-nodes) - (setf (svref nodes end) nil) - (setf (string-table-num-nodes string-table) end) - (sub-delete-string folded string-table) - t) - (t nil))))))) - -(defun sub-delete-string (folded string-table) - (let ((next-table (string-table-first-word-table string-table)) - (word-table nil) - (node nil) - (entry nil) - (level -1) - last-table last-table-level last-table-pos - last-entry last-entry-level) - (declare (fixnum level)) - (do-words (start end) - (when node - (setf last-entry entry) - (setf last-entry-level level)) - (setf word-table next-table) - (incf level) - (let ((word-array (word-table-words word-table)) - (num-words (word-table-num-words word-table))) - (declare (simple-vector word-array) (fixnum num-words)) - (multiple-value-bind - (pos found-p) - (bi-svposition folded word-array - (string-compare* :start1 start :end1 end) - :end (1- num-words) :key #'word-entry-folded) - (declare (fixnum pos) (ignore found-p)) - (setf entry (svref word-array pos)) - (setf next-table (word-entry-next-table entry)) - (setf node (word-entry-value-node entry)) - (when (or (null last-table) (> num-words 1)) - (setf last-table word-table) - (setf last-table-pos pos) - (setf last-table-level level))))) - (cond (next-table - (setf (word-entry-value-node entry) nil)) - ((and last-entry-level - (>= last-entry-level last-table-level)) - (setf (word-entry-next-table last-entry) nil)) - (t - (let* ((del-word-array (word-table-words last-table)) - (del-num-words (word-table-num-words last-table)) - (del-end (1- del-num-words))) - (declare (simple-vector del-word-array) - (fixnum del-num-words del-end)) - (replace del-word-array del-word-array - :start1 last-table-pos :end1 del-end - :start2 (1+ last-table-pos) - :end2 del-num-words) - (setf (svref del-word-array del-end) nil) - (setf (word-table-num-words last-table) del-end)))))) diff --git a/hemlock/termcap.lisp b/hemlock/termcap.lisp deleted file mode 100644 index 8d57c2f761d3446ab6bb4cf2e68f44b0a662bd43..0000000000000000000000000000000000000000 --- a/hemlock/termcap.lisp +++ /dev/null @@ -1,422 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; -;;; Terminal Capability -;;; -;;; This stuff parses a Termcap file and returns a data structure suitable -;;; for initializing a redisplay methods device. -;;; - -(in-package 'hemlock-internals) - - - -;;;; Interface for device creating code. - -(defun get-termcap (name) - "Look in TERMCAP environment variable for terminal capabilities or a - file to use. If it is a file, look for name in it. If it is a description - of the capabilities, use it, and don't look for name anywhere. If TERMCAP - is undefined, look for name in termcap-file. An error is signaled if it - cannot find the terminal capabilities." - (let ((termcap-env-var (get-termcap-env-var))) - (if termcap-env-var - (if (char= (schar termcap-env-var 0) #\/) ; hack for filenamep - (with-open-file (s termcap-env-var) - (if (find-termcap-entry name s) - (parse-fields s) - (error "Unknown Terminal ~S in file ~S." name termcap-env-var))) - (with-input-from-string (s termcap-env-var) - (skip-termcap-names s) - (parse-fields s))) - (with-open-file (s termcap-file) - (if (find-termcap-entry name s) - (parse-fields s) - (error "Unknown Terminal ~S in file ~S." name termcap-file)))))) - -(proclaim '(inline termcap)) -(defun termcap (name termcap) - (cdr (assoc name termcap :test #'eq))) - - - -;;;; Finding the termcap entry - -(defun find-termcap-entry (name stream) - (loop - (let ((end-of-names (lex-termcap-name stream))) - (when (termcap-found-p name) - (unless end-of-names (skip-termcap-names stream)) - (return t)) - (when end-of-names - (unless (skip-termcap-fields stream) - (return nil)))))) - - -;;; This buffer is used in LEX-TERMCAP-NAME and PARSE-FIELDS to -;;; do string comparisons and build strings from interpreted termcap -;;; characters, respectively. -;;; -(defvar *termcap-string-buffer* (make-string 300)) -(defvar *termcap-string-index* 0) - -(eval-when (compile eval) - -(defmacro init-termcap-string-buffer () - `(setf *termcap-string-index* 0)) - -(defmacro store-char (char) - `(progn - (setf (schar *termcap-string-buffer* *termcap-string-index*) ,char) - (incf *termcap-string-index*))) - -(defmacro termcap-string-buffer-string () - `(subseq (the simple-string *termcap-string-buffer*) - 0 *termcap-string-index*)) - -) ;eval-when - - -;;; LEX-TERMCAP-NAME gathers characters until the next #\|, which separate -;;; terminal names, or #\:, which terminate terminal names for an entry. -;;; T is returned if the end of the names is reached for the entry. -;;; -(defun lex-termcap-name (stream) - (init-termcap-string-buffer) - (loop - (let ((char (read-char stream))) - (case char - (#\| (return nil)) - (#\: (return t)) - (t (store-char char)))))) - -(defun termcap-found-p (name) - (string= name *termcap-string-buffer* :end2 *termcap-string-index*)) - -;;; SKIP-TERMCAP-NAMES eats characters until the next #\: which terminates -;;; terminal names for an entry. -;;; -(defun skip-termcap-names (stream) - (loop - (when (char= (read-char stream) #\:) - (return)))) - -;;; SKIP-TERMCAP-FIELDS skips the rest of an entry, returning nil if there -;;; are no more entries in the file. An entry is terminated by a #\: -;;; followed by a #\newline (possibly by eof). -;;; -(defun skip-termcap-fields (stream) - (loop - (multiple-value-bind (line eofp) - (read-line stream) - (let ((len (length line))) - (declare (simple-string line)) - (when (char= (schar line (1- len)) #\:) - (if eofp - (return nil) - (let ((char (read-char stream nil :eof))) - (if (eq char :eof) - (return nil) - (unread-char char stream)) - (return t)))))))) - - - -;;;; Defining known capabilities for parsing purposes. - -(eval-when (compile load eval) -(defvar *known-termcaps* ()) -) ;eval-when - - -(eval-when (compile eval) - -;;; DEFTERMCAP makes a terminal capability known for parsing purposes. -;;; Type is one of :string, :number, or :boolean. Cl-name is an EQ -;;; identifier for the capability. -;;; -(defmacro deftermcap (name type cl-name) - `(progn (push (list ,name ,type ,cl-name) *known-termcaps*))) - -(defmacro termcap-def (name) - `(cdr (assoc ,name *known-termcaps* :test #'string=))) - -(defmacro termcap-def-type (termcap-def) - `(car ,termcap-def)) - -(defmacro termcap-def-cl-name (termcap-def) - `(cadr ,termcap-def)) - -) ;eval-when - - -(deftermcap "is" :string :init-string) -(deftermcap "if" :string :init-file) -(deftermcap "ti" :string :init-cursor-motion) -(deftermcap "te" :string :end-cursor-motion) -(deftermcap "al" :string :open-line) -(deftermcap "am" :boolean :auto-margins-p) -(deftermcap "ce" :string :clear-to-eol) -(deftermcap "cl" :string :clear-display) -(deftermcap "cm" :string :cursor-motion) -(deftermcap "co" :number :columns) -(deftermcap "dc" :string :delete-char) -(deftermcap "dm" :string :init-delete-mode) -(deftermcap "ed" :string :end-delete-mode) -(deftermcap "dl" :string :delete-line) -(deftermcap "im" :string :init-insert-mode) -(deftermcap "ic" :string :init-insert-char) -(deftermcap "ip" :string :end-insert-char) -(deftermcap "ei" :string :end-insert-mode) -(deftermcap "li" :number :lines) -(deftermcap "so" :string :init-standout-mode) -(deftermcap "se" :string :end-standout-mode) -(deftermcap "tc" :string :similar-terminal) -(deftermcap "os" :boolean :overstrikes) -(deftermcap "ul" :boolean :underlines) - - - -;;;; Parsing an entry. - -(defvar *getchar-ungetchar-buffer* nil) - -(eval-when (compile eval) - -;;; UNGETCHAR -- Internal. -;;; -;;; We need this to be able to peek ahead more than one character. -;;; This is used in PARSE-FIELDS and GET-TERMCAP-STRING-CHAR. -;;; -(defmacro ungetchar (char) - `(push ,char *getchar-ungetchar-buffer*)) - -;;; GETCHAR -- Internal. -;;; -;;; This is used in PARSE-FIELDS and GET-TERMCAP-STRING-CHAR. -;;; -(defmacro getchar () - `(loop - (setf char - (if *getchar-ungetchar-buffer* - (pop *getchar-ungetchar-buffer*) - (read-char stream nil :eof))) - (if (and (characterp char) (char= char #\\)) - (let ((temp (if *getchar-ungetchar-buffer* - (pop *getchar-ungetchar-buffer*) - (read-char stream)))) - (when (char/= temp #\newline) - (ungetchar temp) - (return char))) - (return char)))) - - -;;; STORE-FIELD used in PARSE-FIELDS. -;;; -(defmacro store-field (cl-name value) - (let ((name (gensym))) - `(let ((,name ,cl-name)) - (unless (cdr (assoc ,name termcap :test #'eq)) - (push (cons ,name ,value) termcap))))) - -) ;eval-when - -;;; PARSE-FIELDS parses a termcap entry. We start out in the state get-name. -;;; Each name is looked up in *known-termcaps*, and if it is of interest, then -;;; we dispatch to a state to pick up the value of the field; otherwise, eat -;;; the rest of the field to get to the next name. The name could be present -;;; simply to have the capability negated before the entry indirects to a -;;; similar terminal's capabilities, in which case it is followed by an #\@. -;;; Negated fields are stored with the value :negated since we only store a -;;; field if it does not already have a value -- this is the intent of the -;;; sequencing built into the termcap file. When we are done, we see if there -;;; is a similar terminal to be parsed, and when we are really done, we replace -;;; all the :negated's with nil's. -;;; -(defun parse-fields (stream) - (prog ((termcap-name (make-string 2)) - (termcap ()) - char termcap-def) - GET-NAME - ;; - ;; This state expects char to be a #\:. - (case (getchar) - ((#\space #\tab) - (go GET-NAME)) - (#\: - ;; This is an empty field. - (go GET-NAME)) - ((#\newline :eof) - (go MAYBE-DONE)) - (t - (setf (schar termcap-name 0) char))) - (setf (schar termcap-name 1) (getchar)) - (setf termcap-def (termcap-def termcap-name)) - (unless termcap-def (go EAT-FIELD)) - (when (char= (getchar) #\@) - ;; Negation of a capability to be inherited from a similar terminal. - (store-field (termcap-def-cl-name termcap-def) :negated) - (go EAT-FIELD)) - (case (termcap-def-type termcap-def) - (:number (go NUMBER)) - (:boolean (go BOOLEAN)) - (:string (go STRING))) - NUMBER - (unless (char= char #\#) - (error "Bad termcap format -- number field '#' missing.")) - (let ((number 0) - digit) - (loop - (setf digit (digit-char-p (getchar))) - (if digit - (setf number (+ digit (* number 10))) - (if (char= char #\:) - (return) - (error "Bad termcap format -- number field not : terminated.")))) - (store-field (termcap-def-cl-name termcap-def) number) - (go GET-NAME)) - BOOLEAN - (store-field (termcap-def-cl-name termcap-def) t) - (if (char= char #\:) - (go GET-NAME) - (error "Bad termcap format -- boolean field not : terminated.")) - STRING - (unless (char= char #\=) - (error "Bad termcap format -- string field '=' missing.")) - ;; - ;; Eat up any cost of the capability. - (when (digit-char-p (getchar)) - (let ((dotp nil)) - (loop - (case (getchar) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - (#\. - (when dotp (return)) - (setf dotp t)) - (t (when (char= char #\*) (getchar)) ; '*' means a per line cost - (return)))))) - ;; - ;; Collect the characters. - (let ((normal-string-p (not (eq (termcap-def-cl-name termcap-def) - :cursor-motion))) - xp cm-info) - (init-termcap-string-buffer) - (loop - (case (setf char (get-termcap-string-char stream char)) - (#\% - (if normal-string-p - (store-char #\%) - (case (getchar) - (#\% (store-char #\%)) - ((#\d #\2 #\3) - (push (if (char= char #\d) 0 (digit-char-p char)) - cm-info) - (push (if xp :y-pad :x-pad) cm-info) - (push (termcap-string-buffer-string) cm-info) - (push (if xp :string2 :string1) cm-info) - (init-termcap-string-buffer) - (setf xp t)) - (#\. - (push (termcap-string-buffer-string) cm-info) - (push (if xp :string2 :string1) cm-info) - (init-termcap-string-buffer) - (setf xp t)) - (#\+ - (push (termcap-string-buffer-string) cm-info) - (push (if xp :string2 :string1) cm-info) - (push (get-termcap-string-char stream (getchar)) cm-info) - (push (if xp :y-add-char :x-add-char) cm-info) - (init-termcap-string-buffer) - (setf xp t)) - (#\> - (push (get-termcap-string-char stream (getchar)) cm-info) - (push (if xp :y-condx-char :x-condx-char) cm-info) - (push (get-termcap-string-char stream (getchar)) cm-info) - (push (if xp :y-condx-add-char :x-condx-add-char) cm-info)) - (#\r - (push t cm-info) - (push :reversep cm-info)) - (#\i - (push t cm-info) - (push :one-origin cm-info))))) - (#\: - (store-field (termcap-def-cl-name termcap-def) - (cond (normal-string-p (termcap-string-buffer-string)) - (t (push (termcap-string-buffer-string) cm-info) - (cons :string3 cm-info)))) - (return)) - (t (store-char char))) - (getchar)) - (go GET-NAME)) - EAT-FIELD - (loop (when (char= (getchar) #\:) (return))) - (go GET-NAME) - MAYBE-DONE - (let* ((similar-terminal (assoc :similar-terminal termcap :test #'eq)) - (name (cdr similar-terminal))) - (when name - (file-position stream :start) - (setf (cdr similar-terminal) nil) - (if (find-termcap-entry name stream) - (go GET-NAME) - (error "Unknown similar terminal name -- ~S." name)))) - (dolist (ele termcap) - (when (eq (cdr ele) :negated) - (setf (cdr ele) nil))) - (return termcap))) - -;;; GET-TERMCAP-STRING-CHAR parses/lexes a character out of the termcap -;;; file, converting it first into the appropriate Common Lisp character. -;;; The Common Lisp character is then converted by CL-TERMCAP-CHAR into -;;; another Common Lisp character but one that will eventually have the -;;; right bits on (or be the necessary fixnum) for sending to terminals. -;;; If this function needs to look ahead to determine any characters, it -;;; unreads the character. -;;; -(defun get-termcap-string-char (stream char) - (cl-termcap-char - (case char - (#\\ - (case (getchar) - (#\E #\alt) - (#\n #\newline) - (#\r #\return) - (#\t #\tab) - (#\b #\backspace) - (#\f #\formfeed) - (#\^ #\^) - (#\\ #\\) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (let ((result 0) - (digit (digit-char-p char))) - (loop (setf result (+ digit (* 8 result))) - (unless (setf digit (digit-char-p (getchar))) - (ungetchar char) - (return (translate-tty-char (ldb (byte 7 0) result))))))) - (t (error "Bad termcap format -- unknown backslash character.")))) - (#\^ - (set-char-bit (char-upcase (getchar)) :control t)) - (t char)))) - - - -;;;; Initialization file string. - -(defun get-init-file-string (f) - (unless (probe-file f) - (error "File containing terminal initialization string does not exist -- ~S." - f)) - (with-open-file (s f) - (let* ((len (file-length s)) - (string (make-string len))) - (dotimes (i len string) - (setf (schar string i) (read-char s)))))) diff --git a/hemlock/text.lisp b/hemlock/text.lisp deleted file mode 100644 index 5614724172a44b30dbe15cc938b5ead616b6ff3b..0000000000000000000000000000000000000000 --- a/hemlock/text.lisp +++ /dev/null @@ -1,569 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; -;;; This file contains stuff that operates on units of texts, such as -;;; paragraphs, sentences, lines, and words. -;;; - -(in-package "HEMLOCK") - -;;;; -- New Variables -- - -(defhvar "Paragraph Delimiter Function" - "The function that returns whether or not the current line should break the - paragraph." - :value 'default-para-delim-function) - -;;; The standard paragraph delimiting function is DEFAULT-PARA-DELIM-FUNCTION -(defun default-para-delim-function (mark) - "Return whether or not to break on this line." - (paragraph-delimiter-attribute-p (next-character mark))) - -;;;; -- Paragraph Commands -- - -(defcommand "Forward Paragraph" (p) - "moves point to the end of the current (next) paragraph." - "moves point to the end of the current (next) paragraph." - (let ((point (current-point))) - (unless (paragraph-offset point (or p 1)) - (buffer-end point) - (editor-error)))) - -(defcommand "Backward Paragraph" (p) - "moves point to the start of the current (previous) paragraph." - "moves point to the start of the current (previous) paragraph." - (let ((point (current-point))) - (unless (paragraph-offset point (- (or p 1))) - (buffer-start point) - (editor-error)))) - -(defcommand "Mark Paragraph" (p) - "Put mark and point around current or next paragraph. - A paragraph is delimited by a blank line, a line beginning with a - special character (@,\,-,',and .), or it is begun with a line with at - least one whitespace character starting it. Prefixes are ignored or - skipped over before determining if a line starts or delimits a - paragraph." - "Put mark and point around current or next paragraph." - (declare (ignore p)) - (let* ((point (current-point)) - (mark (copy-mark point :temporary))) - (if (mark-paragraph point mark) - (push-buffer-mark mark t) - (editor-error)))) - -(defun mark-paragraph (mark1 mark2) - "Mark the next or current paragraph, setting mark1 to the beginning and mark2 - to the end. This uses \"Fill Prefix\", and mark1 is always on the first - line of the paragraph. If no paragraph is found, then the marks are not - moved, and nil is returned." - (with-mark ((tmark1 mark1) - (tmark2 mark2)) - (let* ((prefix (value fill-prefix)) - (prefix-len (length prefix)) - (paragraphp (paragraph-offset tmark2 1))) - (when (or paragraphp - (and (last-line-p tmark2) - (end-line-p tmark2) - (not (blank-line-p (mark-line tmark2))))) - (mark-before (move-mark tmark1 tmark2)) - (%fill-paragraph-start tmark1 prefix prefix-len) - (move-mark mark1 tmark1) - (move-mark mark2 tmark2))))) - - - -(eval-when (compile eval) - -;;; %MARK-TO-PARAGRAPH moves mark to next immediate (current) -;;; paragraph in the specified direction. Nil is returned when no -;;; paragraph is found. NOTE: the order of the arguments to OR within the -;;; first branch of the COND must be as it is, and mark must be at the -;;; beginning of the line it is on. -(defmacro %mark-to-paragraph (mark prefix prefix-length - &optional (direction :forward)) - `(do ((skip-prefix-p) - (paragraph-delim-function (value paragraph-delimiter-function))) - (nil) - (setf skip-prefix-p - (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length))) - (if skip-prefix-p (character-offset ,mark ,prefix-length)) - (let ((next-char (next-character ,mark))) - (cond ((and (not (blank-after-p ,mark)) - (or (whitespace-attribute-p next-char) - (not (funcall paragraph-delim-function ,mark)))) - (return (if skip-prefix-p (line-start ,mark) ,mark))) - (,(if (eq direction :forward) - `(last-line-p ,mark) - `(first-line-p ,mark)) - (if skip-prefix-p (line-start ,mark)) - (return nil))) - (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0)))) - - -;;; %PARAGRAPH-OFFSET-AUX is the inner loop of PARAGRAPH-OFFSET. It -;;; moves over a paragraph to find the beginning or end depending on -;;; direction. Prefixes on a line are ignored or skipped over before it -;;; is determined if the line is a paragraph boundary. -(defmacro %paragraph-offset-aux (mark prefix prefix-length - &optional (direction :forward)) - `(do ((paragraph-delim-function (value paragraph-delimiter-function)) - (skip-prefix-p)) - (nil) - (setf skip-prefix-p - (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length))) - (if skip-prefix-p (character-offset ,mark ,prefix-length)) - (cond ((or (blank-after-p ,mark) - (funcall paragraph-delim-function ,mark)) - (return (line-start ,mark))) - (,(if (eq direction :forward) - `(last-line-p ,mark) - `(first-line-p ,mark)) - (return ,(if (eq direction :forward) - `(line-end ,mark) - `(line-start ,mark))))) - (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0))) - -); (eval-when (compile eval) - - - -;;; PARAGRAPH-OFFSET takes a mark and a number of paragraphs to -;;; move over. If the specified number of paragraphs does not exist in -;;; the direction indicated by the sign of number, then nil is -;;; returned, otherwise the mark is returned. - -(defun paragraph-offset (mark number &optional (prefix (value fill-prefix))) - "moves mark past the specified number of paragraph, forward if the number - is positive and vice versa. If the specified number of paragraphs do - not exist in the direction indicated by the sign of the number, then nil - is returned, otherwise the mark is returned." - (if (plusp number) - (%paragraph-offset-forward mark number prefix) - (%paragraph-offset-backward mark number prefix))) - - - -;;; %PARAGRAPH-OFFSET-FORWARD moves mark forward over number -;;; paragraphs. The first branch of the COND is necessary for the side -;;; effect provided by LINE-OFFSET. If %MARK-TO-PARAGRAPH left tmark at -;;; the beginning of some paragraph %PARAGRAPH-OFFSET-AUX will think it has -;;; moved mark past a paragraph, so we make sure tmark is inside the -;;; paragraph or after it. - -(defun %paragraph-offset-forward (mark number prefix) - (do* ((n number (1- n)) - (tmark (line-start (copy-mark mark :temporary))) - (prefix-length (length prefix)) - (paragraphp (%mark-to-paragraph tmark prefix prefix-length) - (if (plusp n) - (%mark-to-paragraph tmark prefix prefix-length)))) - ((zerop n) (move-mark mark tmark)) - (cond ((and paragraphp (not (line-offset tmark 1))) ; - (if (or (> n 1) (and (last-line-p mark) (end-line-p mark))) - (return nil)) - (return (line-end (move-mark mark tmark)))) - (paragraphp (%paragraph-offset-aux tmark prefix prefix-length)) - (t (return nil))))) - - - -(defun %paragraph-offset-backward (mark number prefix) - (with-mark ((tmark1 mark) - (tmark2 mark)) - (do* ((n (abs number) (1- n)) - (prefix-length (length prefix)) - (paragraphp (%para-offset-back-find-para tmark1 prefix - prefix-length mark) - (if (plusp n) - (%para-offset-back-find-para tmark1 prefix - prefix-length tmark2)))) - ((zerop n) (move-mark mark tmark1)) - (cond ((and paragraphp (first-line-p tmark1)) - (if (and (first-line-p mark) (start-line-p mark)) - (return nil) - (if (> n 1) (return nil)))) - (paragraphp - (%paragraph-offset-aux tmark1 prefix prefix-length :backward) - (%para-offset-back-place-mark tmark1 prefix prefix-length)) - (t (return nil)))))) - - - -;;; %PARA-OFFSET-BACK-PLACE-MARK makes sure that mark is in -;;; the right place when it has been moved backward over a paragraph. The -;;; "right place" is defined to be where EMACS leaves it for a given -;;; situation or where it is necessary to ensure the mark's skipping -;;; backward over another paragraph if PARAGRAPH-OFFSET was given an -;;; argument with a greater magnitude than one. I believe these two -;;; constraints are equivalent; that is, neither changes what the other -;;; would dictate. - -(defun %para-offset-back-place-mark (mark prefix prefix-length) - (skip-prefix-if-here mark prefix prefix-length) - (cond ((text-blank-line-p mark) (line-start mark)) - ((not (first-line-p mark)) - (line-offset mark -1 0) - (skip-prefix-if-here mark prefix prefix-length) - (if (text-blank-line-p mark) - (line-start mark) - (line-offset mark 1 0))))) - - - -(defun %para-offset-back-find-para (mark1 prefix prefix-length mark2) - (move-mark mark2 mark1) - (line-start mark1) - (let ((para-p (%mark-to-paragraph mark1 prefix prefix-length :backward))) - (cond ((and para-p (same-line-p mark1 mark2)) - (skip-prefix-if-here mark1 prefix prefix-length) - (find-attribute mark1 :whitespace #'zerop) - (cond ((mark<= mark2 mark1) - (line-offset mark1 -1 0) - (%mark-to-paragraph mark1 prefix prefix-length :backward)) - (t (line-start mark1)))) - (t para-p)))) - - - -;;;; -- Sentence Commands -- - -(defcommand "Forward Sentence" (p) - "Moves forward one sentence or the specified number. - A sentence terminates with a .,?, or ! followed by any number of closing - delimiters (such as \",',),],>,|) which are followed by either two - spaces or a newline." - "Moves forward one sentence or the specified number." - (declare (ignore p)) - (unless (sentence-offset (current-point) (or p 1)) - (editor-error))) - - - -(defcommand "Backward Sentence" (p) - "Moves backward one sentence or the specified number. - A sentence terminates with a .,?, or ! followed by any number of closing - delimiters (such as \",',),],>,|) which are followed by either two - spaces or a newline." - "Moves backward one sentence or the specified number." - (declare (ignore p)) - (unless (sentence-offset (current-point) (- (or p 1))) - (editor-error))) - - - -(defcommand "Mark Sentence" (p) - "Put mark and point around current or next sentence. - A sentence terminates with a .,?, or ! followed by any number of closing - delimiters (such as \",',),],>,|) which are followed by either two - spaces or a newline." - "Put mark and point around current or next sentence." - (declare (ignore p)) - (let* ((point (current-point)) - (end (copy-mark point :temporary))) - (unless (sentence-offset end 1) (editor-error)) - (move-mark point end) - (sentence-offset point -1) - (push-buffer-mark end t))) - - -(defcommand "Forward Kill Sentence" (p) - "Kill forward to end of sentence." - "Kill forward to end of sentence." - (let ((point (current-point)) - (offset (or p 1))) - (with-mark ((mark point)) - (if (sentence-offset mark offset) - (if (plusp offset) - (kill-region (region point mark) :kill-forward) - (kill-region (region mark point) :kill-backward)) - (editor-error))))) - -(defcommand "Backward Kill Sentence" (p) - "Kill backward to beginning of sentence." - "Kill backward to beginning of sentence." - (forward-kill-sentence-command (- (or p 1)))) - -;;; SENTENCE-OFFSET-END-P returns true if mark is at the end of a -;;; sentence. If that the end of a sentence, it leaves mark at an -;;; appropriate position with respect to the sentence-terminator character, -;;; the beginning of the next sentence, and direction. See the commands -;;; "Forward Sentence" and "Backward Sentence" for a definition of a sentence. - -(eval-when (compile eval) -(defmacro sentence-offset-end-p (mark &optional (direction :forward)) - `(let ((start (mark-charpos ,mark))) - (do () - ((not (sentence-closing-char-attribute-p (next-character ,mark)))) - (mark-after ,mark)) - (cond ((char= (next-character ,mark) #\newline) - ,(if (eq direction :forward) mark `(mark-after ,mark))) - ((and (char= (next-character ,mark) #\space) - (or (char= (next-character (mark-after ,mark)) #\space) - (char= (next-character ,mark) #\newline))) - ,(if (eq direction :forward) - `(mark-before ,mark) - `(mark-after ,mark))) - (t (move-to-position ,mark start) - nil)))) -); (eval-when (compile eval) - - - -;;; SENTENCE-OFFSET-FIND-END moves in the direction direction stopping -;;; at sentence terminating characters until either there are not any more -;;; such characters or one is found that defines the end of a sentence. -;;; When looking backwards, we may be at the beginning of some sentence, -;;; and if we are, then we must move mark before the sentence terminator; -;;; otherwise, we would find the immediately preceding sentence terminator -;;; and end up right where we started. - -(eval-when (compile eval) -(defmacro sentence-offset-find-end (mark &optional (direction :forward)) - `(progn - ,@(if (eq direction :backward) - `((reverse-find-attribute ,mark :whitespace #'zerop) - (when (fill-region-insert-two-spaces-p ,mark) - (reverse-find-attribute ,mark :sentence-terminator) - (mark-before ,mark)))) - (do ((foundp) (endp)) (nil) - (setf foundp ,(if (eq direction :forward) - `(find-attribute ,mark :sentence-terminator) - `(reverse-find-attribute ,mark :sentence-terminator))) - (setf endp ,(if (eq direction :forward) - `(if foundp (progn (mark-after ,mark) - (sentence-offset-end-p ,mark))) - `(if foundp (sentence-offset-end-p ,mark :backward)))) - (if endp (return ,mark)) - ,(if (eq direction :forward) - `(unless foundp (return nil)) - `(if foundp (mark-before ,mark) (return nil)))))) -); (eval-when (compile eval) - - - -;;; SENTENCE-OFFSET takes a mark and a number of paragraphs to move -;;; over. If the specified number of paragraphs does not exist in -;;; the direction indicated by the sign of the number, then nil is returned, -;;; otherwise the mark is returned. - -(defun sentence-offset (mark number) - (if (plusp number) - (sentence-offset-forward mark number) - (sentence-offset-backward mark (abs number)))) - - - -;;; SENTENCE-OFFSET-FORWARD tries to move mark forward over number -;;; sentences. If it can, then mark is moved and returned; otherwise, mark -;;; remains unmoved, and nil is returned. When tmark2 is moved to the end -;;; of a new paragraph, we reverse find for a non-whitespace character to -;;; bring tmark2 to the end of the previous line. This is necessary to -;;; detect if tmark1 is at the end of the paragraph, in which case tmark2 -;;; wants to be moved over another paragraph. - -(defun sentence-offset-forward (mark number) - (with-mark ((tmark1 mark) - (tmark2 mark)) - (do ((n number (1- n)) - (found-paragraph-p)) - ((zerop n) (move-mark mark tmark1)) - (when (and (mark<= tmark2 tmark1) - (setf found-paragraph-p (paragraph-offset tmark2 1))) - (reverse-find-attribute tmark2 :whitespace #'zerop) - (when (mark>= tmark1 tmark2) - (line-offset tmark2 1 0) - (setf found-paragraph-p (paragraph-offset tmark2 1)) - (reverse-find-attribute tmark2 :whitespace #'zerop))) - (cond ((sentence-offset-find-end tmark1) - (if (mark> tmark1 tmark2) (move-mark tmark1 tmark2))) - (found-paragraph-p (move-mark tmark1 tmark2)) - (t (return nil)))))) - - - -(defun sentence-offset-backward (mark number) - (with-mark ((tmark1 mark) - (tmark2 mark) - (tmark3 mark)) - (do* ((n number (1- n)) - (prefix (value fill-prefix)) - (prefix-length (length prefix)) - (found-paragraph-p - (cond ((paragraph-offset tmark2 -1) - (sent-back-place-para-start tmark2 prefix prefix-length) - t)))) - ((zerop n) (move-mark mark tmark1)) - (move-mark tmark3 tmark1) - (when (and (sent-back-para-start-p tmark1 tmark3 prefix prefix-length) - (setf found-paragraph-p - (paragraph-offset (move-mark tmark2 tmark3) -1))) - (paragraph-offset (move-mark tmark1 tmark2) 1) - (sent-back-place-para-start tmark2 prefix prefix-length)) - (cond ((sentence-offset-find-end tmark1 :backward) - (if (mark< tmark1 tmark2) (move-mark tmark1 tmark2))) - (found-paragraph-p (move-mark tmark1 tmark2)) - (t (return nil)))))) - - - -(defun sent-back-para-start-p (mark1 mark2 prefix prefix-length) - (skip-prefix-if-here (line-start mark2) prefix prefix-length) - (cond ((text-blank-line-p mark2) - (line-start mark2)) - ((whitespace-attribute-p (next-character mark2)) - (find-attribute mark2 :whitespace #'zerop) - (if (mark= mark1 mark2) (line-offset mark2 -1 0))) - ((and (mark= mark2 mark1) (line-offset mark2 -1 0)) - (skip-prefix-if-here mark2 prefix prefix-length) - (if (text-blank-line-p mark2) - (line-start mark2))))) - - - -(defun sent-back-place-para-start (mark2 prefix prefix-length) - (skip-prefix-if-here mark2 prefix prefix-length) - (when (text-blank-line-p mark2) - (line-offset mark2 1 0) - (skip-prefix-if-here mark2 prefix prefix-length)) - (find-attribute mark2 :whitespace #'zerop)) - - - -;;;; -- Transposing Stuff -- - -(defcommand "Transpose Words" (p) - "Transpose the words before and after the cursor. - With a positive argument it transposes the words before and after the - cursor, moves right, and repeats the specified number of times, - dragging the word to the left of the cursor right. With a negative - argument, it transposes the two words to the left of the cursor, moves - between them, and repeats the specified number of times, exactly undoing - the positive argument form." - "Transpose the words before and after the cursor." - (let ((num (or p 1)) - (point (current-point))) - (with-mark ((mark point :left-inserting) - (start point :left-inserting)) - (let ((mark-prev (previous-character mark)) - (mark-next (next-character mark))) - (cond ((plusp num) - (let ((forwardp (word-offset point num)) - (backwardp (if (or (word-delimiter-attribute-p mark-next) - (word-delimiter-attribute-p mark-prev)) - (word-offset mark -1) - (word-offset mark -2)))) - (if (and forwardp backwardp) - (transpose-words-forward mark point start) - (editor-error)))) - ((minusp num) - (let ((enoughp (word-offset point (1- num)))) - (if (word-delimiter-attribute-p mark-prev) - (reverse-find-attribute mark :word-delimiter #'zerop) - (find-attribute mark :word-delimiter)) - (if enoughp - (transpose-words-backward point mark start) - (editor-error)))) - (t (editor-error))))))) - - -(defun transpose-words-forward (mark1 end mark2) - (with-mark ((tmark1 mark1 :left-inserting) - (tmark2 mark2 :left-inserting)) - (find-attribute tmark1 :word-delimiter) - (do ((region1 (delete-and-save-region (region mark1 tmark1)))) - ((mark= tmark2 end) (ninsert-region end region1)) - (word-offset tmark2 1) - (reverse-find-attribute (move-mark tmark1 tmark2) :word-delimiter) - (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2))) - (move-mark mark1 tmark1)))) - - -(defun transpose-words-backward (start mark1 mark2) - (with-mark ((tmark1 mark1 :left-inserting) - (tmark2 mark2 :left-inserting)) - (reverse-find-attribute tmark1 :word-delimiter) - (move-mark mark2 mark1) - (do ((region1 (delete-and-save-region (region tmark1 mark1)))) - ((mark= tmark1 start) (ninsert-region start region1)) - (word-offset tmark1 -1) - (find-attribute (move-mark tmark2 tmark1) :word-delimiter) - (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2))) - (move-mark mark1 tmark1)))) - -(defcommand "Transpose Lines" (p) - "Transpose the current line with the line before the cursor. - With a positive argument it transposes the current line with the one - before, moves down a line, and repeats the specified number of times, - dragging the originally current line down. With a negative argument, it - transposes the two lines to the prior to the current, moves up a line, - and repeats the specified number of times, exactly undoing the positive - argument form. With a zero argument, it transposes the lines at point - and mark." - "Transpose the current line with the line before the cursor." - (let ((num (or p 1)) - (point (current-point))) - (with-mark ((mark point :left-inserting)) - (cond ((plusp num) - (if (and (line-offset mark -1 0) - (line-offset point num 0)) - (transpose-lines mark point) - (editor-error))) - ((minusp num) - (cond ((and (line-offset mark (1- num) 0) - (line-offset point -1 0)) - (transpose-lines point mark) - (move-mark point mark)) - (t (editor-error)))) - (t - (rotatef (line-string (mark-line point)) - (line-string (mark-line (current-mark)))) - (line-start point)))))) - - -(defun transpose-lines (mark1 mark2) - (with-mark ((tmark1 mark1)) - (line-offset tmark1 1) - (ninsert-region mark2 (delete-and-save-region (region mark1 tmark1))))) - - - -;;;; -- Utilities -- - -(defun skip-prefix-if-here (mark prefix prefix-length) - (if (and prefix (%line-has-prefix-p mark prefix prefix-length)) - (character-offset mark prefix-length))) - - - -(defun text-blank-line-p (mark) - (let ((next-char (next-character mark))) - (or (blank-after-p mark) - (and (funcall (value paragraph-delimiter-function) mark) - (not (whitespace-attribute-p next-char)))))) - - - -(defun whitespace-attribute-p (char) - (= (character-attribute :whitespace char) 1)) - -(defun sentence-terminator-attribute-p (char) - (= (character-attribute :sentence-terminator char) 1)) - -(defun sentence-closing-char-attribute-p (char) - (= (character-attribute :sentence-closing-char char) 1)) - -(defun paragraph-delimiter-attribute-p (char) - (= (character-attribute :paragraph-delimiter char) 1)) - -(defun word-delimiter-attribute-p (char) - (= (character-attribute :word-delimiter char) 1)) diff --git a/hemlock/things-to-do.txt b/hemlock/things-to-do.txt deleted file mode 100644 index 4a4d6792ea5e1e89341c72470ae45e901c9230db..0000000000000000000000000000000000000000 --- a/hemlock/things-to-do.txt +++ /dev/null @@ -1,671 +0,0 @@ --*- Mode: Text; Package: Hemlock; Editor: t -*- - - - -;;;; eval servers. - -"Remote Compile File" is losing now. - -Flakey prompt handling when eval text is used and it gets and error. - - - -;;;; X problems. - -Intermittant line blanking while typing, like server isn't really forcing -output. Tracing shows that it really happens. - -Server not implementing DRAW-IMAGE-GLYPHS correctly, so we don't have to do our -pixmap hack. - -Possibly auto saving and typing ahead tickles the servers force output problem. -There is the remote chance that Hemlock is slipping up and not calling -redisplay or something under perverse conditions. - - - -;;;; Bill and/or Rob. - -Blow away default case translations. Change bindings to lowercase, unless -inappropriate. Modify tty code to always translate to lowercase control -characters on input. - -Make editor-error messages; that is just make many of the (editor-error) -forms have some string to be printed. - Importance: often beeps and don't know why. - Difficulty: pervasive search for EDITOR-ERROR. - -Consider how to use tty standout mode to highlight active regions. We can know -a font mark as pointing to the highlight font due to -*active-region-highlight-font*. The trouble is in smart redisplay and knowing -about highlighted portions of the screen. Currently we just look at the -strings characters, but this would complicate things. - -Probably the ERROR for trying to modify a read-only buffer could/should be an -EDITOR-ERROR. Maybe the error message should be a Hemlock variable that can be -set for certain buffers or modes. - -Make definition editing different. Maybe only one command that offers some -appropriate default, requiring confirmation. Maybe some way to rightly know to -edit the function named under a #'name instead of the function name in a -function position. Think about whizzy, general definition location logging and -finding mechanism that is user extensible. - -Think about regular expression searching. - Importance: probably should be there by Spring 89. - -Make illegal setting window width and height, (or support this). - -Think about example init file for randoms. It should show most of the simple -through intermediate customizations one would want to do starting to use -Hemlock. - setting variables - file type hooks - hooks - transposing two keys - changing modifiers - -DEFMODE should take a keyword argument for the modeline name, so "Fill" -could be named "Auto Fill" but show "Fill" in the modeline (similarly with -"Spell" and "Save"). - Importance: low. - Difficulty: low. - -Optional doc strings for commands? - Importance: suggested by a couple people. - Difficulty: ??? - -Fix "fill as region" case in auto-fill space. Doesn't indent right in Lisp -strings, for example. - Importance: correctness. - Difficulty: unknown. - Probably Bill will have to do this. - -Get a real italic comment mode. - Importance: some people want it, like Scott. - Difficulty: hard to do right. - -Line-wrap-character a user feature? Per device? Per device set from Hvar? - Importance: a few people set this already for bitmap devices. - Difficulty: low. - Bill should just throw this in. - -When MESSAGE'ing the line of a matching open paren, can something be done to -make the exact open paren more pronounced -- SUBSEQ'ing the line string? - Importance: low - Difficulty: one line frob to major echo area changes. - -Do something about active region highlighting and blank lines. Consider -changing redisplay to be able to hack some glyph onto the line, a virtual -newline or something. - Importance: blank lines at the ends of the active region can be confusing. - Difficulty: unknown difficult changes to redisplay. - -Change redisplay on bitmaps to draw top down? Currently line writes are queued -going down the window image but the queue is written backwards. - Importance: low, two people commented on how it looks funny. - Difficulty: unknown, but probably little. - -Disallow tty I/O when the tty is in a bad state. Since editor is sharing -Unix standard input with *terminal-io*, doing reads on this is bad among -other problems. - Importance: necessary or non-experienced users. - Difficulty: slight. Error system wants to use *terminal-io* if you go - into a break loop from the editor. - Bill. - -Improve echo area window raising. On output? Raise when any window -raised? Now it is raised when made current, but output can be displayed -there when it is not current -- EDITOR-ERROR messages. - Importance: more user friendly (maybe). - Difficulty: variable. Could just modify MESSAGE (or something). - Bill. - -Make Lisp indentation respect user indentation even when in a form with known -special arguments? - Importance: noticeable correctness. - Difficulty: Lucid wrote this already with LOOP macro. - Rob. -Make Lisp motion that exceeds the parsed region lose more gracefully by -informing the user, possibly offering to enlarge the parsing parameters. - Importance: very deceptive as it is currently. - Difficulty: ??? - Rob. -Lisp motion fails to handle correctly vertical bar syntax; for example, - package:|foo| - Importance: correctness, not too necessary - Difficulty: ??? -"Editor Evaluate Defun" does not handle multiple value returns correctly -... if we admit that this is often used to evaluate non-DEFUN top-level -forms. - Importance: user convenience. - Difficulty: low. - -Super-confirm select buffer. Super confirm means "make this be a legal -input". Has no interaction with prompting function interface. More -generally, make a *super-confirm-parse-function* that can be bound around -prompters. One suggestion when prompting for a buffer is to make it, but -another suggestion is to find file some appropriate file. - Importance: multiple people requested. - Difficulty: low. - Bill. -A super-confirm for a more facist "Find File" that disallowed creating buffers -when the file didn't exist could tell the command to really create the buffer. - -Displayed-p shouldn't directly call update-window-image, or perhaps uwi should -be changed to check if the ticks and whatnot indicate recomputation is needed. - Importance: minor efficiency hack and maybe a little cleaner. - Difficulty: low. - Bill. - -Fix line-length for hemlock output streams. The following example causes lines -to brek incorrectly in "Eval" mode but not in "Typescript" mode: - (defun dup (x n &aux r) (dolist (i n r) (push x r))) - (dup 'a 100) ;lines wrap due to faulty line breaking - (dup 'aa 100) ;lines wrap due to faulty line breaking - (dup 'aaa 100) ;now lines break correctly - Importance: correctness. It's not screwing anyone. - Difficulty: depends on what the right thing is. - -Termcap bug: - setenv TERMCAP "foobar:li#65:tc=vt102:" - set term = foobar -This causes an EOF unexpectedly on the string stream. This is because the -the termcap parsing stuff wasn't written to go all the way back to the top -entry point to determine what file to use when the TERMCAP variable had an -indirection. The code currently just goes to the beginning of the stream -and looks for the new tty name. - -Make prompt text not part of input buffer. Do some magical thing to solve -the problem of having special echo area commands that simply get around the -prompt text in the echo are buffer. - Importance: low sense problem is currently somewhat taken care of. - Possibly resolve problem when new Hemlock environment stuff - goes in. - Difficulty: Magical in origin. - Rob. - -Commonify everything. Make everything portable that could be made so (file -system extensions, character att. finding, string ops, etc.) and document -our expectations of the non-portable stuff we lean on. Provide portable -code for stuff done in assembler. - Some known problems: - %sp- functions aren't documented and don't have portable code for - them. - semantics of initial values versus declared type. - :error-file to COMPILE-FILE calls. - - Importance: cleanliness and portability ease for those who want our - code. - Difficulty: identify the problems and alter some code. - Bill and Rob. - -Fix things that keep text from getting gc'ed. Buffer local things keep -pointer to buffer. - Importance: could be important, maybe nothing is wrong. - Difficulty: identifying problems. - Bill or Rob. - -Bounds on searches (e.g., give search primitives a region or an end mark -instead of just a start mark). - Importance: would save a lot of work when searches look at whole buffer - instead of just the current line or region or etc. - Difficulty: possibly high. - Bill - -Two reproducible window image builder bugs: -THIS IS NUMBER ONE: -I wrote this command: - (defcommand "Fetch Input" (p) - "Does \"Point to Here\" followed by \"Reenter Interactive Input\"." - "Does \"Point to Here\" followed by \"Reenter Interactive Input\"." - (declare (ignore p)) - (point-to-here-command nil) - (reenter-interactive-input-command nil)) -I made the following bindings: - (bind-key "Fetch Input" #\hyper-leftdown :mode "Eval") - (bind-key "Fetch Input" #\hyper-leftdown :mode "Typescript") - (bind-key "Do Nothing" #\hyper-leftup :mode "Eval") - (bind-key "Do Nothing" #\hyper-leftup :mode "Typescript") -In an interactive buffer I typed hyper-leftdown twice on the same line and -got the following error: - Error in function HEMLOCK-INTERNALS::CACHED-REAL-LINE-LENGTH. - Vector index, 14700, out of bounds. -This index is always the one you get no matter what line of input you try to -enter twice. -;;; -THIS IS NUMBER TWO: -Put point at the beginning of a small defun that has at least some interior -lines in addition to the "(defun ..." line and the last line of the routine. -Mark the defun and save the region. Now, yank the defun, and note that the -beginning of the second instance starts at the end of the line the yanked copy -ends on. Now type c-w. You'll delete the yanked copy, and the lines that -should not have been touched at all end up with font marks. Interestingly the -first line of the defun and the last don't get any font marks. - Importance: well, they are reproducible, and they're pretty ugly. No one - has noticed these yet though. - Difficulty: Rob and I didn't conjure up the bugs after a casual inspection. - Bill AND Rob - -Consider a GNU-style undo where action is undo-able. - Importance: low, but people point it out as an inadequacy of Hemlock. - Difficulty: possibly very hard. Have to figure out what's necessary first. - Bill and Rob - - -;;;; Mailer stuff. - -Find all message-info-msgs sets and refs, changing them from possible list -values to always be a simple-string value. Maybe must leave a list (or make -another slot) if I need to indicate that I can't use the value as a msg-id. -The only problem is coming through SHOW-PROMPTED-MESSAGE. This could pick or -something to really know if there were more than one message or not. - -Write "Refile Message and Show Next". - -Do something about message headers when reading mail. Suggestions include a -list of headers components that get deleted from the buffer and simply -scrolling the window past the "Received:" lines. - -"Examine Message" - -Add more folder support and possibly something specific for Bovik groveling. -For example, rehashing the cached folder names and/or adding new ones from a -folder spec or root directory (allows adding the bovik folders). - -Consistency problems: - Expunging message should not JUST delete headers buffers and their - associated message buffers. There could be independent message buffers with - invalid message id's. Since these are independent, though, we might not - want to gratuitously delete them. - - "Headers Delete Message" should check for message buffers when virtual - message deletion is not used, deleting them I suppose. Instead of just - making headers buffers consistent. - - - -;;;; Spelling stuff. - -This stuff is probably for Rob or Bill, but think about undergrad -dispatching before actually implementing it. - -Two apostrophes precede a punctuation character, as in: - ``This is a very common occurrence in TeX.'' -"Correct Buffer Spelling" complains that '' is an unknown word. The problem -doesn't show up if the character preceding the apostrophes is alphabetic. - -"Correct Last Misspelled Word" should try to transpose the space on the -ends of a word if there are more than one misspelling (adjacent?). This -would have to be done at the command level trying to correct different -words formed from the buffer. - -Fahlman would like to see a list of words that are treated as errors, even -though they may be in the dictionary. These are considered common typos made -that actually are rarely-used words. These would be flagged as errors for the -user to do a conscious double check on. - -When the spelling correction stuff cannot find any possible corrections, it -could try inserting a space between letters that still form legal words, -checking the two new words are in the dictionary. - Importance: possibly pretty useful, especially with "Spell" mode. - Difficulty: low to medium. - Bill, possibly undergrad after I looked at it. - -Fix "Undo Last Spelling" correction interaction with auto-fill. When this -command is invoked on a word that made auto-fill break the line, shit -happens. - Importance: Rob noticed it. - Difficulty: unknown. - Bill or Rob. - - - -;;;; User and Implementors Manuals - -User Manual wall chart appendix based on systems (e.g., dired, mailer, Lisp -editing, spelling, etc.), then modes (e.g., "Headers", "Message", and "Draft"), -then whatever seems appropriate. - -Point out that "Make Buffer Hook" runs after mode setup. - - - -;;;; Things for undergrads. - -Create "Remote Load File" and make "Load File" use it the way "Compile File" -uses "Remote Compile File". - -Make "Insert Scribe Directive" undo-able, and make the "command" insertion -stuff use the active region. Also, clean up terminology with respect to using -command and environment. - Importance: it would be nice. - Difficulty: little - -Add a feature that notes modified or new lines, probably down in -HI::MODIFYING-BUFFER. Then add interfaces for moving over these lines, moving -over text structures with these lines such as DEFUN's, paragraphs, etc. Write -commands that display these in some way, compile them, etc. - -Look at open paren highlighting and the Scribe bracket table stuff to make a -general bracket highlighter. Possibly have to call function based on mode or -something since Lisp parens are found differently than Scribe brackets (Lisp -parse groveling versus counting open and close brackets). - -Make "Next Page" and "Goto Page" be more aware of the end of the buffer and how -it is displayed as a result of these commands. -Maybe :page-delimiters should be allowed to fall within a line instead of only -at the beginning. Only bother changing this if we hit a language we care about -that supports only line-oriented comments (Postscript?). - Importance: low. - Difficulty: low. - -Make hooks that are lists of function have list in the name, so users can know -easily whether to set this to a list or function. - Importance: low. - Difficulty: low, but pervasive. must be careful. - -Make FILTER-REGION not move all marks in the buffer to the end. It should -affect each line, letting marks stay on a line, instead of deleting the whole -region and inserting a new one. - Importance: low, but described behaviour is better than current behaviour. - Difficulty: low. - -Make some "Auto Save Access" variable, so users don't have to write fully -protected auto save files. Possibly there could be some variable to that -represents Hemlock's default file writing protection. - Importance: one person requested. - Difficulty: easy. - -Make "Save" mode on a first write or on startup check for a .CKP file. If it -is there and has a later write date than the file, warn the user before a save -could overwrite this file that potentially has good stuff in it from a previous -Lisp crash. - Importance: good idea, though people should know to check. - Difficulty: easier if done on start up. - -We need Lisp-like movement in Text mode -- skipping parenthetic and quoted -expressions while ignoring some Lisp syntax stuff. Either can write a few -commands that do what we expect, or we can get really clever with the -pre-command parse checking and bounds rules for Text mode. May even be able to -get the right thing to happen with code fragments in documents. - Importance: would be pretty convenient to have it work right all the time. - Difficulty: will take some thinking and playing around. Rob or Bill guidance. - -Make "Extended Command" offer a default of the last command entered. - -Make "Select Group" command take an optional argument for the group -pathname and group name. - Importance: convenience for init files. - Difficulty: low. - -Put in buffer percentage. - Importance: Lots of people want it. - Difficulty: Rob thinks he knows how to do it. - Rob will tell some undergrad how to do it. - -Make "Unexpand Abbrev" work when no expansion had been done -- test for -error condition was backwards. - -Add modeline display of current eval server and current compile server, when -appropriate. - Importance: suggested by a couple people. Low. - Difficulty: none. - Basically, just have to change string and function. - -Make "Corrected xxx to yyy" messages use actual case of yyy that was -inserted into the buffer. - Importance: more user friendly. - Difficult: low. - Anyone could do this, but it wouldn't be very educational for an - undergrad. - -"Find all Symbols" does a FIND-ALL-SYMBOLS on previous or current form if -it is a symbol. See code for "Where is Symbol" in Scott's -Hemlock-Init.Lisp file. - Importance: probably quite useful. - Difficulty: none. - Anyone could grab Scott's code. - -Make buffer read-only when visiting unwritable file? Bill and Scott -vehemently disagreed with this, but thought a variable would make everyone -happy. - Importance: one person suggested. - Difficulty: low. - Anyone could do this, but it wouldn't be very educational for an - undergrad. - -Modify MAKE-BUFFER to error when buffer exists? - Importance: more user friendly. - Difficulty: none. - Anybody could do this, but it wouldn't be very educational for an - undergrad. - -Warn when unable to rename a buffer according to its file. This occurs -when writing files. - Importance: more user friendly. - Difficulty: none. - Anyone could do this. -Uniquify buffer names by tacking a roman numeral on the end? - Importance: I don't know why this is here. - Difficulty: low. - Anyone could do this. - -Automatically save word abbrevs? - Importance: low. - Difficulty: low. - Some undergrad could do this. - -Automatically save named keyboard macros? Maybe on request? - Importance: other editors can do it. - Difficulty: this is non-trivial since our kbmacs are based on their own - little interpreter. - Medium undergrad task. - -Make nested prompts work. - Importance: some day this might be useful. - Difficulty: medium. - Upper level undergrad could do this. - -Make character searches deal with newlines. - Importance: correctness. - Difficulty: medium. - Upper level undergrad. - -Put argument type checks in the Hemlock primitives. - Importance: low, the compiler should do this from type declaration - (cool?!). - Difficulty: work in a lot of places. - Undergrad could do the things Rob or Bill say. - -Add a "Preferred File Types" to work in coordination with "Ignore File Types". - Importance: low, suggested by one user. - Difficulty: minimal. - -Write separate search and i-search commands that do case-sensitive searches, so -user's don't have to set the Hvar for one search. - Importance: low. - Difficulty: low. - -Add a write-region function which writes to a stream. - Importance: low. - Difficulty: medium. - Undergrad. - - - -;;;; The great rewrite and cleanup. - -Compilation order. Cleanup up defvars, defhvars, proclaims, etc. for clean -compilation of Hemlock in a Lisp without one. Rename ED and HI packages -and start cleaning up compilation. Defvars should go near pertinent code, -and proclaims should do the rest. Do something about macros, rompsite, and -main. - Importance: necessary for those taking our code and sets better example. - Difficulty: few days of work. - Bill. - -Hemlock package cleanup -- exporting Hemlock stuff, so users don't live in -ED package. - Find primitives to export and describe in Command Implementor's Manual. - Export existing command names in a separate file. - DEFCOMMAND always interns in current package. - Variables - One global table. - DEFHVAR only at top level. Interns into current package. WHAT ABOUT SITE-INIT? - BIND-VARIABLE, a new form, will be used at top level or in setup - functions to establish default values. - Find all uses of FIND-PACKAGE, *hemlock-package*, etc. since these are - suspect in the new package regime. - Put DEFVAR's (esp. from Main.Lisp) in appropriate files, putting PROCLAIM's - in a single file or in files with compiler warnings. - Importance: really needs to be done along with environment stuff. - Difficulty: pervasive changes to get right. - Bill! - -Generalized environments: - Generalize notion of environment to first-class objects. - can inherit stuff from other environments. Shadowing for conflict - resolution. Transparent key bindings another sort of interaction. - If we retain modes as a primitive concept, then how do they interact? - If not, how do we get the effect? Each buffer has an environment. - This is normally the composition of the default environment and - various mode environments. - - Turning modes on and off is simply adding and removing the mode's environment - from the buffer's environment's inherit list. The only sticky issue is the - order of the inheritence. We could assign each environment a precedence. - - I guess we could punt modes as a primitive concept. The only thing this - wouldn't provide that modes do is a namespace and the major/minor - distinction. Setting the major mode is just frobbing the lowest precedence - environment in a buffer. A major mode is distinct from a minor mode in that - it inherits the global environment. An interesting question is at which - level precedences should be implemented. We could have it be a property only - of minor modes, which determines only the order in which a buffer inherits - its minor modes, or we could make it a property of environments, and have it - determine the total order of inheritance. Probably the former is better: it - simpler, and adequate. Also, at the environment level, it is more powerful - to be able to specify inheritance order on a per-case basis. - - Make mode-hooks be a mode-object slot rather than hemlock variables. [a - random cleanup] - - We change the (... &optional kind where) arguments to - (... &optional where). Where can be an environment such as - *global-environment* (the default) or a buffer, or it can be a string, in - which case it is interpreted as a mode name. - - Instead of having key binding transparentness be a property of modes or of - commands, we make it a property of binding. Each environment has separate - key-tables for transparent and opaque bindings, and there is a - Transparent-Bind-Key function that is used to make transparent key bindings. - [... or something. This would imply a delete-transparent-key-binding and - prehaps other functions, so we might consider passing a transparent flag to - the primitives.] - - *current-environment* is the current environment, which is normally eq to the - current buffer. Attributes and variables are implemented using deep-binding - and caching. Whenever there is any change to the inheritance structure or to - variable or attribute bindings, then we just totally flush all the caches. - The most frequent operation that would cause this to happen would be changing - a mode in a buffer, which is rare enough so that there should be no problem. - - For variables, we just have a symbol-name X environment => binding cache. - - For attributes we have two caches: attribute X environment => value vector - and attribute X environment X test-function => search vector. The first - translates an attribute and environment to a simple-vector that contains the - current value for each character in that environment. This is used for - Character-Attribute and when the Find-Attribute cache misses. When this - cache misses, we fill the vector with a magic "unspecified" object, and then - scan up the inheritance, filling in any bindings that are unspecified. We - could optimize this by noting in the character-attribute object when an - attribute has no shadowings. character-attribute hooks have to go away, - since they depends on shallow-binding. - - Make Hemlock variables be typed. Have a :type defhvar argument, - variable-type function. In implementation, create a test function for each - variable so that we can efficiently check the type of each assigned value. - This implies defhvar should be a macro. We could make specifying the test - function be an explicit feature, but the same effect could always be obtained - with a Satisfies type specfier. - - Split binding of hvars from definition. - Bind-Variable Symbol-Name Value &Optional Where - Creates a binding. If :Value is specified to defhvar, then it creates a - global binding of that value. If no :Value is specified, then there is no - global binding. We could flush the :Mode and :Buffer options, and require an - explicit Bind-Variable to be done in this case, or we could still allow them. - It would probably be better to flush them, since it would break code that is - doing run-time defhvars to make buffer-local variables. Perhaps we would - flush only :Buffer, since it is clearly useless, while being able to give an - initial mode binding may be useless. - - All variable attributes except for value are global. Hooks are global. The - concept of a hook is somewhat dubious in the presence of non-global bindings. - It might be semi-useful to invoke the hook on each new binding in addition to - on each set. - - Importance: Next big step for Hemlock. - Difficulty: Two months. - Bill will do this. - -Multiple font support: - Figure what kind of multi-font stuff we want to do. - Bogus to use integer constants for facecodes. It is reasonable within the - font mark, but the user interface should be keywords for facecodes. - Importance: no documented font support currently. Really need it. - Difficulty: includes massively reworking redisplay data structures. - Bill and Rob. - - - -;;;; Things to think about. - -;;; These are things that have been thought of, but we don't know much more -;;; about them. - -Some general facility for users to associate definition locations with kinds of -things and/or forms. - -What's the right way to be in a comment in some Lisp file and have filling, -spelling, and whatever work out just right. Possibly regions with environment -information. Maybe with a whole new hierarchical text representation, this -would fall out. - -Synchronization/exclusion issues: - Currently there are non-modification primitives that are looking into a - buffer assuming it will not change out from under the primitive. We - need to identify these places and exactly what the nature of this - problem is (including whether it exists). Probably we need to make - non-trivial text examination primitives use without-interrupts so that - they see a consistent state. - - Find other places where exclusion is needed: - Redisplay? - Typescript code? - -Flush case in keyboard events? Instead, have a shift bit that is used by -text-character. You would still want shift-8 to be *, though.... - -Online documentation stuff: What to do and how to do it. Rob has some -notes on this from a year or two ago. - Importance: something to do. - Difficulty: high. - maybe no one. - -Think about general "Save My Editor State". Can generalize notion of -stateful things? -- Word abbrevs, keyboard macros, defindent, spelling -stuff, etc. This could be the last thing we ever do to Hemlock. - Importance: low. - Difficulty: very. - ??? - - - -;;;; New Eval Servers - -Do something about slaves dieing in init files. Lisps start up and first load -init.lisp. When a slave does this, it goes into the debugger before connecting -to the editor. diff --git a/hemlock/ts-buf.lisp b/hemlock/ts-buf.lisp deleted file mode 100644 index e20b44ee2ed570de03b55cad0b73449913793938..0000000000000000000000000000000000000000 --- a/hemlock/ts-buf.lisp +++ /dev/null @@ -1,292 +0,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.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). -;;; ********************************************************************** -;;; -;;; This file contains code for processing input to and output from slaves -;;; using typescript streams. It maintains the stuff that hacks on the -;;; typescript buffer and maintains its state. -;;; -;;; Written by William Lott. -;;; - -(in-package "HEMLOCK") - - -(defhvar "Input Wait Alarm" - "When non-nil, the user is informed when a typescript buffer goes into - an input wait, and it is not visible. Legal values are :message, - :loud-message (the default), and nil." - :value :loud-message) - - - -;;;; Structures. - -(defstruct (ts-data - (:print-function - (lambda (ts s d) - (declare (ignore ts d)) - (write-string "#<TS Data>" s))) - (:constructor - make-ts-data (buffer - &aux - (fill-mark (copy-mark (buffer-end-mark buffer) - :right-inserting))))) - buffer ; The buffer we are in - stream ; Stream in the slave. - wire ; Wire to slave - server ; Server info struct. - fill-mark ; Mark where output goes. This is actually the - ; "Buffer Input Mark" which is :right-inserting, - ; and we make sure it is :left-inserting for - ; inserting output. - ) - - -;;;; Output routines. - -;;; TS-BUFFER-OUTPUT-STRING --- internal interface. -;;; -;;; Called by the slave to output stuff in the typescript. Can also be called -;;; by other random parts of hemlock when they want to output stuff to the -;;; buffer. Since this is called for value from the slave, we have to be -;;; careful about what values we return, so the result can be sent back. It is -;;; called for value only as a synchronization thing. -;;; -;;; Whenever the output is gratuitous, we want it to go behind the prompt. -;;; When it's gratuitous, and we're not at the line-start, then we can output -;;; it normally, but we also make sure we end the output in a newline for -;;; visibility's sake. -;;; -(defun ts-buffer-output-string (ts string &optional gratuitous-p) - "Outputs STRING to the typescript described with TS. The output is inserted - before the fill-mark and the current input." - (when (wire:remote-object-p ts) - (setf ts (wire:remote-object-value ts))) - (system:without-interrupts - (let ((mark (ts-data-fill-mark ts))) - (cond ((and gratuitous-p (not (start-line-p mark))) - (with-mark ((m mark :left-inserting)) - (line-start m) - (insert-string m string) - (unless (start-line-p m) - (insert-character m #\newline)))) - (t - (setf (mark-kind mark) :left-inserting) - (insert-string mark string) - (when (and gratuitous-p (not (start-line-p mark))) - (insert-character mark #\newline)) - (setf (mark-kind mark) :right-inserting))))) - (values)) - -;;; TS-BUFFER-FINISH-OUTPUT --- internal interface. -;;; -;;; Redisplays the windows. Used by ts-stream in order to finish-output. -;;; -(defun ts-buffer-finish-output (ts) - (declare (ignore ts)) - (redisplay) - nil) - -;;; TS-BUFFER-CHARPOS --- internal interface. -;;; -;;; Used by ts-stream in order to find the charpos. -;;; -(defun ts-buffer-charpos (ts) - (mark-charpos (ts-data-fill-mark (if (wire:remote-object-p ts) - (wire:remote-object-value ts) - ts)))) - -;;; TS-BUFFER-LINE-LENGTH --- internal interface. -;;; -;;; Used by ts-stream to find out the line length. Returns the width of the -;;; first window, or 80 if there are no windows. -;;; -(defun ts-buffer-line-length (ts) - (let* ((ts (if (wire:remote-object-p ts) - (wire:remote-object-value ts) - ts)) - (window (car (buffer-windows (ts-data-buffer ts))))) - (if window - (window-width window) - 80))) ; Seems like a good number to me. - - -;;;; Input routines - -(defun ts-buffer-ask-for-input (remote) - (let* ((ts (wire:remote-object-value remote)) - (buffer (ts-data-buffer ts))) - (unless (buffer-windows buffer) - (let ((input-wait-alarm - (if (hemlock-bound-p 'input-wait-alarm - :buffer buffer) - (variable-value 'input-wait-alarm - :buffer buffer) - (variable-value 'input-wait-alarm - :global)))) - (when input-wait-alarm - (when (eq input-wait-alarm :loud-message) - (beep)) - (message "Waiting for input in buffer ~A." - (buffer-name buffer)))))) - nil) - -(defun ts-buffer-clear-input (ts) - (let* ((ts (if (wire:remote-object-p ts) - (wire:remote-object-value ts) - ts)) - (buffer (ts-data-buffer ts)) - (mark (ts-data-fill-mark ts))) - (unless (mark= mark (buffer-end-mark buffer)) - (with-mark ((start mark)) - (line-start start) - (let ((prompt (region-to-string (region start mark))) - (end (buffer-end-mark buffer))) - (unless (zerop (mark-charpos end)) - (insert-character end #\Newline)) - (insert-string end "[Input Cleared]") - (insert-character end #\Newline) - (insert-string end prompt) - (move-mark mark end))))) - nil) - -(defun ts-buffer-set-stream (ts stream) - (setf (ts-data-stream (if (wire:remote-object-p ts) - (wire:remote-object-value ts) - ts)) - stream) - nil) - - - -;;;; Typescript mode. - -(defun setup-typescript (buffer) - (let ((ts (make-ts-data buffer))) - (defhvar "Current Package" - "The package used for evaluation of Lisp in this buffer." - :buffer buffer - :value nil) - - (defhvar "Typescript Data" - "The ts-data structure for this buffer" - :buffer buffer - :value ts) - - (defhvar "Buffer Input Mark" - "Beginning of typescript input in this buffer." - :value (ts-data-fill-mark ts) - :buffer buffer) - - (defhvar "Interactive History" - "A ring of the regions input to the Hemlock typescript." - :buffer buffer - :value (make-ring (value interactive-history-length))) - - (defhvar "Interactive Pointer" - "Pointer into the Hemlock typescript input history." - :buffer buffer - :value 0) - - (defhvar "Searching Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0))) - -(defmode "Typescript" - :setup-function #'setup-typescript - :documentation "The Typescript mode is used to interact with slave lisps.") - -;;; TYPESCRIPTIFY-BUFFER -- Internal interface. -;;; -;;; Buffer creation code for eval server connections calls this to setup a -;;; typescript buffer, tie things together, and make some local Hemlock -;;; variables. -;;; -(defun typescriptify-buffer (buffer server wire) - (setf (buffer-minor-mode buffer "Typescript") t) - (let ((info (variable-value 'typescript-data :buffer buffer))) - (setf (ts-data-server info) server) - (setf (ts-data-wire info) wire) - (defhvar "Server Info" - "Server-info structure for this buffer." - :buffer buffer :value server) - (defhvar "Current Eval Server" - "The Server-Info object for the server currently used for evaluation and - compilation." - :buffer buffer :value server) - info)) - -(defun ts-buffer-wire-died (ts) - (setf (ts-data-stream ts) nil) - (setf (ts-data-wire ts) nil) - (buffer-end (ts-data-fill-mark ts) (ts-data-buffer ts)) - (ts-buffer-output-string ts (format nil "~%~%Slave died!~%"))) - -(defun unwedge-typescript-buffer () - (typescript-slave-to-top-level-command nil) - (buffer-end (current-point) (current-buffer))) - -(defhvar "Unwedge Interactive Input Fun" - "Function to call when input is confirmed, but the point is not past the - input mark." - :value #'unwedge-typescript-buffer - :mode "Typescript") - -(defhvar "Unwedge Interactive Input String" - "String to add to \"Point not past input mark. \" explaining what will - happen if the the user chooses to be unwedged." - :value "Cause the slave to throw to the top level? " - :mode "Typescript") - -(defcommand "Confirm Typescript Input" (p) - "Send the current input to the slave typescript." - "Send the current input to the slave typescript." - (declare (ignore p)) - (let ((ts (value typescript-data))) - (unless ts - (editor-error "This buffer has no typescript data!")) - (let ((input (get-interactive-input))) - (when input - (let ((string (region-to-string input))) - (declare (simple-string string)) - (insert-character (current-point) #\NewLine) - (wire:remote (ts-data-wire ts) - (ts-stream-accept-input (ts-data-stream ts) - (concatenate 'simple-string - string - (string #\newline)))) - (wire:wire-force-output (ts-data-wire ts)) - (buffer-end (ts-data-fill-mark ts) - (ts-data-buffer ts))))))) - -(defcommand "Typescript Slave Break" (p) - "Interrupt the slave Lisp process associated with this interactive buffer, - causing it to invoke BREAK." - "Interrupt the slave Lisp process associated with this interactive buffer, - causing it to invoke BREAK." - (declare (ignore p)) - (send-oob-to-slave "B")) - -(defcommand "Typescript Slave to Top Level" (p) - "Interrupt the slave Lisp process associated with this interactive buffer, - causing it to throw to the top level REP loop." - "Interrupt the slave Lisp process associated with this interactive buffer, - causing it to throw to the top level REP loop." - (declare (ignore p)) - (send-oob-to-slave "T")) - -(defun send-oob-to-slave (string) - (let* ((ts (value typescript-data)) - (wire (ts-data-wire ts)) - (socket (wire:wire-fd wire))) - (unless socket - (editor-error "The slave is no longer alive.")) - (ext:send-character-out-of-band socket (schar string 0)))) diff --git a/hemlock/ts-stream.lisp b/hemlock/ts-stream.lisp deleted file mode 100644 index e14aab70c73c63d36fbe0d9def922b03ca628e5b..0000000000000000000000000000000000000000 --- a/hemlock/ts-stream.lisp +++ /dev/null @@ -1,283 +0,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.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). -;;; ********************************************************************** -;;; -;;; This file implements typescript streams. -;;; -;;; Written by William Lott. -;;; - -(in-package "HEMLOCK") - -(defconstant ts-stream-output-buffer-size 512) - -(defstruct (ts-stream - (:include stream - (in #'%ts-stream-in) - (out #'%ts-stream-out) - (sout #'%ts-stream-sout) - (misc #'%ts-stream-misc)) - (:print-function %ts-stream-print) - (:constructor make-ts-stream (wire typescript))) - wire - typescript - (output-buffer (make-string ts-stream-output-buffer-size) - :type simple-string) - (output-buffer-index 0 :type fixnum) - (char-pos 0) - current-input - (input-read-index 0 :type fixnum)) - -(defun %ts-stream-print (ts stream depth) - (declare (ignore ts depth)) - (write-string "#<TS Stream>" stream)) - -;;; TS-STREAM-ACCEPT-INPUT --- internal interface. -;;; -;;; This routine is called by the editor to indicate that the user has typed -;;; more input. -;;; -(defun ts-stream-accept-input (remote string) - (let ((stream (wire:remote-object-value remote))) - (system:without-interrupts - (setf (ts-stream-current-input stream) - (nconc (ts-stream-current-input stream) - (list string))) - (setf (ts-stream-char-pos stream) 0))) - nil) - -;;; %TS-STREAM-LISTEN --- internal. -;;; -;;; Determine if there is any input available. If we don't think so, process -;;; all pending events, and look again. -;;; -(defun %ts-stream-listen (stream) - (flet ((check () - (system:without-interrupts - (loop - (let ((current (ts-stream-current-input stream))) - (cond ((null current) - (return nil)) - ((>= (ts-stream-input-read-index stream) - (length (the simple-string (car current)))) - (pop (ts-stream-current-input stream)) - (setf (ts-stream-input-read-index stream) 0)) - (t - (return t)))))))) - (or (check) - (progn - (system:serve-all-events 0) - (check))))) - -;;; WAIT-FOR-TYPESCRIPT-INPUT --- internal. -;;; -;;; Keep calling server until some input shows up. -;;; -(defun wait-for-typescript-input (stream) - (unless (%ts-stream-listen stream) - (let ((wire (ts-stream-wire stream)) - (ts (ts-stream-typescript stream))) - (wire:remote wire - (ts-buffer-ask-for-input ts)) - (wire:wire-force-output wire) - (loop - (system:serve-all-events) - (when (%ts-stream-listen stream) - (return)))))) - -;;; %TS-STREAM-IN --- internal. -;;; -;;; The READ-CHAR stream method. -;;; -(defun %ts-stream-in (stream &optional eoferr eofval) - (declare (ignore eoferr eofval)) ; EOF's are impossible. - (wait-for-typescript-input stream) - (system:without-interrupts - (prog1 - (schar (car (ts-stream-current-input stream)) - (ts-stream-input-read-index stream)) - (incf (ts-stream-input-read-index stream))))) - - - -;;; %TS-STREAM-READ-LINE --- internal. -;;; -;;; The READ-LINE stream method. Note: here we take advantage of the fact that -;;; newlines will only appear at the end of strings. -;;; -(defun %ts-stream-read-line (stream eoferr eofval) - (declare (ignore eoferr eofval)) - (macrolet ((next-str () - '(progn - (wait-for-typescript-input stream) - (system:without-interrupts - (prog1 - (if (zerop (ts-stream-input-read-index stream)) - (pop (ts-stream-current-input stream)) - (subseq (pop (ts-stream-current-input stream)) - (ts-stream-input-read-index stream))) - (setf (ts-stream-input-read-index stream) 0)))))) - (do ((result (next-str) (concatenate 'simple-string result (next-str)))) - ((char= (schar result (1- (length result))) #\newline) - (values (subseq result 0 (1- (length result))) - nil)) - (declare (simple-string result))))) - -;;; %TS-STREAM-FLSBUF --- internal. -;;; -;;; Flush the output buffer associated with stream. -;;; -(defun %ts-stream-flsbuf (stream) - (when (and (ts-stream-wire stream) - (ts-stream-output-buffer stream) - (not (zerop (ts-stream-output-buffer-index stream)))) - (wire:remote (ts-stream-wire stream) - (ts-buffer-output-string (ts-stream-typescript stream) - (subseq (the simple-string - (ts-stream-output-buffer stream)) - 0 - (ts-stream-output-buffer-index stream)))) - (setf (ts-stream-output-buffer-index stream) - 0))) - -;;; %TS-STREAM-OUT --- internal. -;;; -;;; Output a single character to stream. -;;; -(defun %ts-stream-out (stream char) - (declare (string-char char)) - (when (= (ts-stream-output-buffer-index stream) - ts-stream-output-buffer-size) - (%ts-stream-flsbuf stream)) - (setf (schar (ts-stream-output-buffer stream) - (ts-stream-output-buffer-index stream)) - char) - (incf (ts-stream-output-buffer-index stream)) - (incf (ts-stream-char-pos stream)) - (when (= (char-code char) - (char-code #\Newline)) - (%ts-stream-flsbuf stream) - (setf (ts-stream-char-pos stream) 0) - (wire:wire-force-output (ts-stream-wire stream))) - char) - -;;; %TS-STREAM-SOUT --- internal. -;;; -;;; Output a string to stream. -;;; -(defun %ts-stream-sout (stream string start end) - (declare (simple-string string)) - (declare (fixnum start end)) - (let ((wire (ts-stream-wire stream)) - (newline (position #\Newline string :start start :end end :from-end t)) - (length (- end start))) - (when wire - (let ((index (ts-stream-output-buffer-index stream))) - (cond ((> (+ index length) - ts-stream-output-buffer-size) - (%ts-stream-flsbuf stream) - (wire:remote wire - (ts-buffer-output-string (ts-stream-typescript stream) - (subseq string start end))) - (when newline - (wire:wire-force-output wire))) - (t - (replace (the simple-string (ts-stream-output-buffer stream)) - string - :start1 index - :end1 (+ index length) - :start2 start - :end2 end) - (incf (ts-stream-output-buffer-index stream) - length) - (when newline - (%ts-stream-flsbuf stream) - (wire:wire-force-output wire)))))) - (setf (ts-stream-char-pos stream) - (if newline - (- end newline 1) - (+ (ts-stream-char-pos stream) - length))))) - -;;; %TS-STREAM-UNREAD --- internal. -;;; -;;; Unread a single character. -;;; -(defun %ts-stream-unread (stream char) - (system:without-interrupts - (cond ((and (ts-stream-current-input stream) - (> (ts-stream-input-read-index stream) 0)) - (setf (schar (car (ts-stream-current-input stream)) - (decf (ts-stream-input-read-index stream))) - char)) - (t - (push (string char) (ts-stream-current-input stream)) - (setf (ts-stream-input-read-index stream) 0))))) - -;;; %TS-STREAM-CLOSE --- internal. -;;; -;;; Can't do much, 'cause the wire is shared. -;;; -(defun %ts-stream-close (stream abort) - (unless abort - (force-output stream)) - (lisp::set-closed-flame stream)) - -;;; %TS-STREAM-CLEAR-INPUT --- internal. -;;; -;;; Pass the request to the editor and clear any buffered input. -;;; -(defun %ts-stream-clear-input (stream) - (when (ts-stream-wire stream) - (wire:remote-value (ts-stream-wire stream) - (ts-buffer-clear-input (ts-stream-typescript stream)))) - (system:without-interrupts - (setf (ts-stream-current-input stream) nil - (ts-stream-input-read-index stream) 0))) - -;;; %TS-STREAM-MISC --- internal. -;;; -;;; The misc stream method. -;;; -(defun %ts-stream-misc (stream operation &optional arg1 arg2) - (case operation - (:read-line - (%ts-stream-read-line stream arg1 arg2)) - (:listen - (%ts-stream-listen stream)) - (:unread - (%ts-stream-unread stream arg1)) - (:close - (%ts-stream-close stream arg1)) - (:clear-input - (%ts-stream-clear-input stream) - t) - (:finish-output - (when (ts-stream-wire stream) - (%ts-stream-flsbuf stream) - ;; Note: for the return value to come back, - ;; all pending RPCs must have completed. - (wire:remote-value (ts-stream-wire stream) - (ts-buffer-finish-output (ts-stream-typescript stream)))) - t) - (:force-output - (when (ts-stream-wire stream) - (%ts-stream-flsbuf stream) - (wire:wire-force-output (ts-stream-wire stream))) - t) - (:clear-output - (setf (ts-stream-output-buffer-index stream) 0) - t) - (:element-type - 'char-string) - (:charpos - (ts-stream-char-pos stream)) - (:line-length - (wire:remote-value (ts-stream-wire stream) - (ts-buffer-line-length (ts-stream-typescript stream)))))) diff --git a/hemlock/tty-disp-rt.lisp b/hemlock/tty-disp-rt.lisp deleted file mode 100644 index 5bd888dc41f81b391cdfe0e704be19cc7e948889..0000000000000000000000000000000000000000 --- a/hemlock/tty-disp-rt.lisp +++ /dev/null @@ -1,139 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles. -;;; - -(in-package "HEMLOCK-INTERNALS") - - -;;;; Terminal init and exit methods. - -(defvar *hemlock-input-handler*) - -(defun init-tty-device (device) - (setf *hemlock-input-handler* - (system:add-fd-handler 0 :input #'get-editor-tty-input)) - (standard-device-init) - (device-write-string (tty-device-init-string device)) - (redisplay-all)) - -(defun exit-tty-device (device) - (cursor-motion device 0 (1- (tty-device-lines device))) - ;; Can't call the clear-to-eol method since we don't have a hunk to - ;; call it on, and you can't count on the bottom hunk being the echo area. - ;; - (if (tty-device-clear-to-eol-string device) - (device-write-string (tty-device-clear-to-eol-string device)) - (dotimes (i (tty-device-columns device) - (cursor-motion device 0 (1- (tty-device-lines device)))) - (tty-write-char #\space))) - (device-write-string (tty-device-cm-end-string device)) - (when (device-force-output device) - (funcall (device-force-output device))) - (when *hemlock-input-handler* - (system:remove-fd-handler *hemlock-input-handler*) - (setf *hemlock-input-handler* nil)) - (standard-device-exit)) - - - -;;;; Output routines and buffering. - -(defconstant redisplay-output-buffer-length 256) - -(defvar *redisplay-output-buffer* - (make-string redisplay-output-buffer-length)) -(proclaim '(simple-string *redisplay-output-buffer*)) - -(defvar *redisplay-output-buffer-index* 0) -(proclaim '(fixnum *redisplay-output-buffer-index*)) - - -;;; TTY-WRITE-STRING blasts the string into the redisplay output buffer. -;;; If the string overflows the buffer, then segments of the string are -;;; blasted into the buffer, dumping the buffer, until the last piece of -;;; the string is stored in the buffer. The buffer is always dumped if -;;; it is full, even if the last piece of the string just fills the buffer. -;;; -(defun tty-write-string (string start length) - (declare (fixnum start length)) - (let ((buffer-space (- redisplay-output-buffer-length - *redisplay-output-buffer-index*))) - (declare (fixnum buffer-space)) - (cond ((<= length buffer-space) - (let ((dst-index (+ *redisplay-output-buffer-index* length))) - (%primitive byte-blt string start *redisplay-output-buffer* - *redisplay-output-buffer-index* dst-index) - (cond ((= length buffer-space) - (mach:unix-write 1 *redisplay-output-buffer* 0 - redisplay-output-buffer-length) - (setf *redisplay-output-buffer-index* 0)) - (t - (setf *redisplay-output-buffer-index* dst-index))))) - (t - (let ((remaining (- length buffer-space))) - (declare (fixnum remaining)) - (loop - (%primitive byte-blt string start *redisplay-output-buffer* - *redisplay-output-buffer-index* - redisplay-output-buffer-length) - (mach:unix-write 1 *redisplay-output-buffer* 0 - redisplay-output-buffer-length) - (when (< remaining redisplay-output-buffer-length) - (%primitive byte-blt string (+ start buffer-space) - *redisplay-output-buffer* 0 remaining) - (setf *redisplay-output-buffer-index* remaining) - (return t)) - (incf start buffer-space) - (setf *redisplay-output-buffer-index* 0) - (setf buffer-space redisplay-output-buffer-length) - (decf remaining redisplay-output-buffer-length))))))) - - -;;; TTY-WRITE-CHAR stores a character in the redisplay output buffer, -;;; dumping the buffer if it becomes full. -;;; -(defun tty-write-char (char) - (setf (schar *redisplay-output-buffer* *redisplay-output-buffer-index*) - char) - (incf *redisplay-output-buffer-index*) - (when (= *redisplay-output-buffer-index* redisplay-output-buffer-length) - (mach:unix-write 1 *redisplay-output-buffer* 0 - redisplay-output-buffer-length) - (setf *redisplay-output-buffer-index* 0))) - - -;;; TTY-FORCE-OUTPUT dumps the redisplay output buffer. This is called -;;; out of terminal device structures in multiple places -- the device -;;; exit method, random typeout methods, out of tty-hunk-stream methods, -;;; after calls to REDISPLAY or REDISPLAY-ALL. -;;; -(defun tty-force-output () - (unless (zerop *redisplay-output-buffer-index*) - (mach:unix-write 1 *redisplay-output-buffer* 0 - *redisplay-output-buffer-index*) - (setf *redisplay-output-buffer-index* 0))) - - -;;; TTY-FINISH-OUTPUT simply dumps output. -;;; -(defun tty-finish-output (device window) - (declare (ignore window)) - (let ((force-output (device-force-output device))) - (when force-output - (funcall force-output)))) - - - -;;;; Screen image line hacks. - -(defmacro replace-si-line (dst-string src-string src-start dst-start dst-end) - `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end)) diff --git a/hemlock/tty-display.lisp b/hemlock/tty-display.lisp deleted file mode 100644 index 29994d9b5d44ed58e5f528ee3adf33debbb50f11..0000000000000000000000000000000000000000 --- a/hemlock/tty-display.lisp +++ /dev/null @@ -1,1102 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(redisplay redisplay-all)) - - - -;;;; Macros. - -(eval-when (compile eval) -(defmacro tty-hunk-modeline-pos (hunk) - `(tty-hunk-text-height ,hunk)) -) ;eval-when - - -(defvar *currently-selected-hunk* nil) -(defvar *hunk-top-line*) - -(proclaim '(fixnum *hunk-top-line*)) - -(eval-when (compile eval) -(defmacro select-hunk (hunk) - `(unless (eq ,hunk *currently-selected-hunk*) - (setf *currently-selected-hunk* ,hunk) - (setf *hunk-top-line* - (the fixnum - (1+ (the fixnum - (- (the fixnum - (tty-hunk-text-position ,hunk)) - (the fixnum - (tty-hunk-text-height ,hunk))))))))) -) ;eval-when - - -;;; Screen image lines. -;;; -(defstruct (si-line (:print-function print-screen-image-line) - (:constructor %make-si-line (chars))) - chars - (length 0)) - -(defun make-si-line (n) - (%make-si-line (make-string n))) - -(defun print-screen-image-line (obj str n) - (declare (ignore n)) - (write-string "#<Screen Image Line \"" str) - (write-string (si-line-chars obj) str :end (si-line-length obj)) - (write-string "\">" str)) - - -(defmacro si-line (screen-image n) - `(svref ,screen-image ,n)) - - - -;;;; Dumb window redisplay. - -(defmacro tty-dumb-line-redisplay (device hunk dis-line &optional y) - (let ((dl (gensym)) (dl-chars (gensym)) (dl-len (gensym)) - (dl-pos (gensym)) (screen-image-line (gensym))) - `(let* ((,dl ,dis-line) - (,dl-chars (dis-line-chars ,dl)) - (,dl-len (dis-line-length ,dl)) - (,dl-pos ,(or y `(dis-line-position ,dl)))) - (funcall (tty-device-display-string ,device) - ,hunk 0 ,dl-pos ,dl-chars 0 ,dl-len) - (setf (dis-line-flags ,dl) unaltered-bits) - (setf (dis-line-delta ,dl) 0) - (select-hunk ,hunk) - (let ((,screen-image-line (si-line (tty-device-screen-image ,device) - (+ *hunk-top-line* ,dl-pos)))) - (replace-si-line (si-line-chars ,screen-image-line) ,dl-chars - 0 0 ,dl-len) - (setf (si-line-length ,screen-image-line) ,dl-len))))) - -(defun tty-dumb-window-redisplay (window) - (let* ((first (window-first-line window)) - (hunk (window-hunk window)) - (device (device-hunk-device hunk)) - (screen-image (tty-device-screen-image device))) - (funcall (tty-device-clear-to-eow device) hunk 0 0) - (do ((i 0 (1+ i)) - (dl (cdr first) (cdr dl))) - ((eq dl the-sentinel) - (setf (window-old-lines window) (1- i)) - (select-hunk hunk) - (do ((last (tty-hunk-text-position hunk)) - (i (+ *hunk-top-line* i) (1+ i))) - ((> i last)) - (declare (fixnum i last)) - (setf (si-line-length (si-line screen-image i)) 0))) - (tty-dumb-line-redisplay device hunk (car dl) i)) - (setf (window-first-changed window) the-sentinel - (window-last-changed window) first) - (when (window-modeline-buffer window) - (let ((dl (window-modeline-dis-line window)) - (y (tty-hunk-modeline-pos hunk))) - (funcall (tty-device-standout-init device) hunk) - (funcall (tty-device-clear-to-eol device) hunk 0 y) - (tty-dumb-line-redisplay device hunk dl y) - (funcall (tty-device-standout-end device) hunk) - (setf (dis-line-flags dl) unaltered-bits))))) - - - -;;;; Dumb redisplay top n lines of a window. - -(defun tty-redisplay-n-lines (window n) - (let* ((hunk (window-hunk window)) - (device (device-hunk-device hunk))) - (funcall (tty-device-clear-lines device) hunk 0 0 n) - (do ((n n (1- n)) - (dl (cdr (window-first-line window)) (cdr dl))) - ((or (zerop n) (eq dl the-sentinel))) - (tty-dumb-line-redisplay device hunk (car dl))))) - - - -;;;; Semi dumb window redisplay - -;;; This is for terminals without opening and deleting lines. - -;;; TTY-SEMI-DUMB-WINDOW-REDISPLAY is a lot like TTY-SMART-WINDOW-REDISPLAY, -;;; but it calls different line redisplay functions. -;;; -(defun tty-semi-dumb-window-redisplay (window) - (let* ((hunk (window-hunk window)) - (device (device-hunk-device hunk))) - (let ((first-changed (window-first-changed window)) - (last-changed (window-last-changed window))) - ;; Is there anything to do? - (unless (eq first-changed the-sentinel) - (if ;; One line-changed. - (and (eq first-changed last-changed) - (zerop (dis-line-delta (car first-changed)))) - (tty-semi-dumb-line-redisplay device hunk (car first-changed)) - ;; More lines changed. - (do-semi-dumb-line-writes first-changed last-changed hunk)) - ;; Set the bounds so we know we displayed... - (setf (window-first-changed window) the-sentinel - (window-last-changed window) (window-first-line window)))) - ;; - ;; Clear any extra lines at the end of the window. - (let ((pos (dis-line-position (car (window-last-line window))))) - (when (< pos (window-old-lines window)) - (tty-smart-clear-to-eow hunk (1+ pos))) - (setf (window-old-lines window) pos)) - ;; - ;; Update the modeline if needed. - (when (window-modeline-buffer window) - (let ((dl (window-modeline-dis-line window))) - (when (/= (dis-line-flags dl) unaltered-bits) - (funcall (tty-device-standout-init device) hunk) - (unwind-protect - (tty-smart-line-redisplay device hunk dl - (tty-hunk-modeline-pos hunk)) - (funcall (tty-device-standout-end device) hunk))))))) - -;;; NEXT-DIS-LINE is used in DO-SEMI-DUMB-LINE-WRITES and -;;; COMPUTE-TTY-CHANGES. -;;; -(eval-when (compile eval) -(defmacro next-dis-line () - `(progn - (setf prev dl) - (setf dl (cdr dl)) - (setf flags (dis-line-flags (car dl))))) -) ;eval-when - -;;; DO-SEMI-DUMB-LINE-WRITES does what it says until it hits the last -;;; changed line. The commented out code was a gratuitous optimization, -;;; especially if the first-changed line really is the first changes line. -;;; Anyway, this had to be removed because of this function's use in -;;; TTY-SMART-WINDOW-REDISPLAY, which was punting line moves due to -;;; "Scroll Redraw Ratio". However, these supposedly moved lines had their -;;; bits set to unaltered bits in COMPUTE-TTY-CHANGES because it was -;;; assuming TTY-SMART-WINDOW-REDISPLAY guaranteed to do line moves. -;;; -(defun do-semi-dumb-line-writes (first-changed last-changed hunk) - (let* ((dl first-changed) - flags ;(dis-line-flags (car dl))) flags bound for NEXT-DIS-LINE. - prev) - (declare (ignore flags)) - ;; - ;; Skip old, unchanged, unmoved lines. - ;; (loop - ;; (unless (zerop flags) (return)) - ;; (next-dis-line)) - ;; - ;; Write every remaining line. - (let* ((device (device-hunk-device hunk)) - (force-output (device-force-output device))) - (loop - (tty-semi-dumb-line-redisplay device hunk (car dl)) - (when force-output (funcall force-output)) - (next-dis-line) - (when (eq prev last-changed) (return)))))) - -;;; TTY-SEMI-DUMB-LINE-REDISPLAY finds the first different character -;;; comparing the display line and the screen image line, writes out the -;;; rest of the display line, and clears to end-of-line as necessary. -;;; -(defun tty-semi-dumb-line-redisplay (device hunk dl - &optional (dl-pos (dis-line-position dl))) - (declare (fixnum dl-pos)) - (let* ((dl-chars (dis-line-chars dl)) - (dl-len (dis-line-length dl))) - (declare (fixnum dl-len) (simple-string dl-chars)) - (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input)) - (select-hunk hunk) - (let* ((screen-image-line (si-line (tty-device-screen-image device) - (+ *hunk-top-line* dl-pos))) - (si-line-chars (si-line-chars screen-image-line)) - (si-line-length (si-line-length screen-image-line)) - (findex (string/= dl-chars si-line-chars - :end1 dl-len :end2 si-line-length))) - (declare (fixnum findex) (simple-string si-line-chars)) - ;; - ;; When the dis-line and screen chars are not string=. - (when findex - (cond - ;; See if the screen shows an initial substring of the dis-line. - ((= findex si-line-length) - (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex dl-len) - (replace-si-line si-line-chars dl-chars findex findex dl-len)) - ;; When the dis-line is an initial substring of what's on the screen. - ((= findex dl-len) - (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) - ;; Otherwise, blast dl-chars and clear to eol as necessary. - (t (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex dl-len) - (when (< dl-len si-line-length) - (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) - (replace-si-line si-line-chars dl-chars findex findex dl-len))) - (setf (si-line-length screen-image-line) dl-len))) - (setf (dis-line-flags dl) unaltered-bits) - (setf (dis-line-delta dl) 0))) - - - -;;;; Smart window redisplay -- operation queues and internal screen image. - -;;; This is used for creating temporary smart redisplay structures. -;;; -(defconstant tty-hunk-height-limit 100) - - -;;; Queues for redisplay operations and access macros. -;;; -(defvar *tty-line-insertions* (make-array (* 2 tty-hunk-height-limit))) - -(defvar *tty-line-deletions* (make-array (* 2 tty-hunk-height-limit))) - -(defvar *tty-line-writes* (make-array tty-hunk-height-limit)) - -(eval-when (compile eval) - -(defmacro queue (value queue ptr) - `(progn - (setf (svref ,queue ,ptr) ,value) - (the fixnum (incf (the fixnum ,ptr))))) - -(defmacro dequeue (queue ptr) - `(prog1 - (svref ,queue ,ptr) - (the fixnum (incf (the fixnum ,ptr))))) - -) ;eval-when - -;;; INSERT-LINE-COUNT is used in TTY-SMART-WINDOW-REDISPLAY. The counting is -;;; based on calls to QUEUE in COMPUTE-TTY-CHANGES. -;;; -(defun insert-line-count (ins) - (do ((i 1 (+ i 2)) - (count 0 (+ count (svref *tty-line-insertions* i)))) - ((> i ins) count))) - - -;;; Temporary storage for screen-image lines and accessing macros. -;;; -(defvar *screen-image-temp* (make-array tty-hunk-height-limit)) - -(eval-when (compile eval) - -;;; DELETE-SI-LINES is used in DO-LINE-DELETIONS to simulate what's -;;; happening to the screen in a device's screen-image. At y, num -;;; lines are deleted and saved in *screen-image-temp*; fsil is the -;;; end of the free screen image lines saved here. Also, we must -;;; move lines up in the screen-image structure. In the outer loop -;;; we save lines in the temp storage and move lines up at the same -;;; time. In the termination/inner loop we move any lines that still -;;; need to be moved up. The screen-length is adjusted by the fsil -;;; because any time a deletion is in progress, there are fsil bogus -;;; lines at the bottom of the screen image from lines being moved -;;; up previously. -;;; -(defmacro delete-si-lines (screen-image y num fsil screen-length) - (let ((do-screen-image (gensym)) (delete-index (gensym)) - (free-lines (gensym)) (source-index (gensym)) (target-index (gensym)) - (n (gensym)) (do-screen-length (gensym)) (do-y (gensym))) - `(let ((,do-screen-image ,screen-image) - (,do-screen-length (- ,screen-length fsil)) - (,do-y ,y)) - (declare (fixnum ,do-screen-length ,do-y)) - (do ((,delete-index ,do-y (1+ ,delete-index)) - (,free-lines ,fsil (1+ ,free-lines)) - (,source-index (+ ,do-y ,num) (1+ ,source-index)) - (,n ,num (1- ,n))) - ((zerop ,n) - (do ((,target-index ,delete-index (1+ ,target-index)) - (,source-index ,source-index (1+ ,source-index))) - ((>= ,source-index ,do-screen-length)) - (declare (fixnum ,target-index ,source-index)) - (setf (si-line ,do-screen-image ,target-index) - (si-line ,do-screen-image ,source-index)))) - (declare (fixnum ,delete-index ,free-lines ,source-index ,n)) - (setf (si-line *screen-image-temp* ,free-lines) - (si-line ,do-screen-image ,delete-index)) - (when (< ,source-index ,do-screen-length) - (setf (si-line ,do-screen-image ,delete-index) - (si-line ,do-screen-image ,source-index))))))) - - -;;; INSERT-SI-LINES is used in DO-LINE-INSERTIONS to simulate what's -;;; happening to the screen in a device's screen-image. At y, num free -;;; lines are inserted from *screen-image-temp*; fsil is the end of the -;;; free lines. When copying lines down in screen-image, we must start -;;; with the lower lines and end with the higher ones, so we don't trash -;;; any lines. The outer loop does all the copying, and the termination/ -;;; inner loop inserts the free screen image lines, setting their length -;;; to zero. -;;; -(defmacro insert-si-lines (screen-image y num fsil screen-length) - (let ((do-screen-image (gensym)) (source-index (gensym)) - (target-index (gensym)) (target-terminus (gensym)) - (do-screen-length (gensym)) (temp (gensym)) (do-y (gensym)) - (insert-index (gensym)) (free-lines-index (gensym)) - (n (gensym))) - `(let ((,do-screen-length ,screen-length) - (,do-screen-image ,screen-image) - (,do-y ,y)) - (do ((,target-terminus (1- (+ ,do-y ,num))) ; (1- target-start) - (,source-index (- ,do-screen-length ,fsil 1) ; (1- source-end) - (1- ,source-index)) - (,target-index (- (+ ,do-screen-length ,num) - ,fsil 1) ; (1- target-end) - (1- ,target-index))) - ((= ,target-index ,target-terminus) - (do ((,insert-index ,do-y (1+ ,insert-index)) - (,free-lines-index (1- ,fsil) (1- ,free-lines-index)) - (,n ,num (1- ,n))) - ((zerop ,n)) - (declare (fixnum ,insert-index ,free-lines-index ,n)) - (let ((,temp (si-line *screen-image-temp* ,free-lines-index))) - (setf (si-line-length ,temp) 0) - (setf (si-line ,do-screen-image ,insert-index) ,temp))) - (decf ,fsil ,num)) - (declare (fixnum ,target-terminus ,source-index ,target-index)) - (setf (si-line ,do-screen-image ,target-index) - (si-line ,do-screen-image ,source-index)))))) - -) ;eval-when - - - -;;;; Smart window redisplay -- the function. - -;;; TTY-SMART-WINDOW-REDISPLAY sees if only one line changed after -;;; some preliminary processing. If more than one line changed, -;;; then we compute changes to make to the screen in the form of -;;; line insertions, deletions, and writes. Deletions must be done -;;; first, so lines are not lost off the bottom of the screen by -;;; inserting lines. -;;; -(defun tty-smart-window-redisplay (window) - (let* ((hunk (window-hunk window)) - (device (device-hunk-device hunk))) - (let ((first-changed (window-first-changed window)) - (last-changed (window-last-changed window))) - ;; Is there anything to do? - (unless (eq first-changed the-sentinel) - (if (and (eq first-changed last-changed) - (zerop (dis-line-delta (car first-changed)))) - ;; One line-changed. - (tty-smart-line-redisplay device hunk (car first-changed)) - ;; More lines changed. - (multiple-value-bind (ins outs writes) - (compute-tty-changes - first-changed last-changed - (tty-hunk-modeline-pos hunk)) - (let ((ratio (variable-value 'ed::scroll-redraw-ratio))) - (cond ((and ratio - (> (/ (insert-line-count ins) - (tty-hunk-text-height hunk)) - ratio)) - (do-semi-dumb-line-writes first-changed last-changed - hunk)) - (t - (do-line-insertions hunk ins - (do-line-deletions hunk outs)) - (do-line-writes hunk writes)))))) - ;; Set the bounds so we know we displayed... - (setf (window-first-changed window) the-sentinel - (window-last-changed window) (window-first-line window)))) - ;; - ;; Clear any extra lines at the end of the window. - (let ((pos (dis-line-position (car (window-last-line window))))) - (when (< pos (window-old-lines window)) - (tty-smart-clear-to-eow hunk (1+ pos))) - (setf (window-old-lines window) pos)) - ;; - ;; Update the modeline if needed. - (when (window-modeline-buffer window) - (let ((dl (window-modeline-dis-line window))) - (when (/= (dis-line-flags dl) unaltered-bits) - (funcall (tty-device-standout-init device) hunk) - (unwind-protect - (tty-smart-line-redisplay device hunk dl - (tty-hunk-modeline-pos hunk)) - (funcall (tty-device-standout-end device) hunk))))))) - - - -;;;; Smart window redisplay -- computing changes to the display. - -;;; There is a lot of documentation here to help since this code is not -;;; obviously correct. The code is not that cryptic, but the correctness -;;; of the algorithm is somewhat. Most of the complexity is in handling -;;; lines that moved on the screen which the introduction deals with. -;;; Also, the block of documentation immediately before the function -;;; COMPUTE-TTY-CHANGES has its largest portion dedicated to this part of -;;; the function which is the largest block of code in the function. - -;;; The window image dis-lines are annotated with the difference between -;;; their current intended locations and their previous locations in the -;;; window. This delta (distance moved) is negative for an upward move and -;;; positive for a downward move. To determine what to do with moved -;;; groups of lines, we consider the transition (or difference in deltas) -;;; between two adjacent groups as we look at the window's dis-lines moving -;;; down the window image, disregarding whether they are contiguous (having -;;; moved only by a different delta) or separated by some lines (such as -;;; lines that are new and unmoved). -;;; -;;; Considering the transition between moved groups makes sense because a -;;; given group's delta affects all the lines below it since the dis-lines -;;; reflect the window's buffer's actual lines which are all connected in -;;; series. Therefore, if the previous group moved up some delta number of -;;; lines because of line deletions, then the lines below this group (down -;;; to the last line of the window image) moved up by the same delta too, -;;; unless one of the following is true: -;;; 1] The lines below the group moved up by a greater delta, possibly -;;; due to multiple disjoint buffer line deletions. -;;; 2] The lines below the group moved up by a lesser delta, possibly -;;; due to a number (less than the previous delta) of new line -;;; insertions below the group that moved up. -;;; 3] The lines below the group moved down, possibly due to a number -;;; (greater than the previous delta) of new line insertions below -;;; the group that moved up. -;;; Similarly, if the previous group moved down some delta number of lines -;;; because of new line insertions, then the lines below this group (down -;;; to the last line of the window image not to fall off the window's lower -;;; edge) moved down by the same delta too, unless one of the following is -;;; true: -;;; 1] The lines below the group moved down by a greater delta, possibly -;;; due to multiple disjoint buffer line insertions. -;;; 2] The lines below the group moved down by a lesser delta, possibly -;;; due to a number (less than the previous delta) of line deletions -;;; below the group that moved down. -;;; 3] The lines below the group moved up, possibly due to a number -;;; (greater than the previous delta) of line deletions below the -;;; group that moved down. -;;; -;;; Now we can see how the first moved group affects the window image below -;;; it except where there is a lower group of lines that have moved a -;;; different delta due to separate operations on the buffer's lines viewed -;;; through a window. We can see that this different delta is the expected -;;; effect throughout the window image below the second group, unless -;;; something lower down again has affected the window image. Also, in the -;;; case of a last group of lines that moved up, the group will never -;;; reflect all of the lines in the window image from the first line to -;;; move down to the bottom of the window image because somewhere down below -;;; the group that moved up are some new lines that have just been drawn up -;;; into the window's image. -;;; - -;;; COMPUTE-TTY-CHANGES is used once in TTY-SMART-WINDOW-REDISPLAY. -;;; It goes through all the display lines for a window recording where -;;; lines need to be inserted, deleted, or written to make the screen -;;; consistent with the internal image of the screen. Pointers to -;;; the insertions, deletions, and writes that have to be done are -;;; returned. -;;; -;;; If a line is new, then simply queue it to be written. -;;; -;;; If a line is moved and/or changed, then we compute the difference -;;; between the last block of lines that moved with the same delta and the -;;; current block of lines that moved with the current delta. If this -;;; difference is positive, then some lines need to be deleted. Since we -;;; do all the line deletions first to prevent line insertions from -;;; dropping lines off the bottom of the screen, we have to compute the -;;; position of line deletions using the cumulative insertions -;;; (cum-inserts). Without any insertions, deletions may be done right at -;;; the dis-line's new position. With insertions needed above a given -;;; deletion point combined with the fact that deletions are all done -;;; first, the location for the deletion is higher than it would be without -;;; the insertions being done above the deletions. The location of the -;;; deletion is higher by the number of insertions we have currently put -;;; off. When computing the position of line insertions (a negative delta -;;; transition), we do not need to consider the cumulative insertions or -;;; cumulative deletions since everything above the point of insertion -;;; (both deletions and insertions) has been done. Because of the screen -;;; state being correct above the point of an insertion, the screen is only -;;; off by the delta transition number of lines. After determining the -;;; line insertions or deletions, loop over contiguous lines with the same -;;; delta queuing any changed ones to be written. The delta and flag -;;; fields are initialized according to the need to be written; since -;;; redisplay may be interrupted by more user input after moves have been -;;; done to the screen, we save the changed bit on, so the line will be -;;; queued to be written after redisplay is re-entered. -;;; -;;; If the line is changed or new, then queue it to be written. Note -;;; before that we checked the flags for equality with the new bits, and -;;; it is possible that updating the window image will yield lines that -;;; are both new and changed. -;;; -;;; Otherwise, get the next display line, loop, and see if it's -;;; interesting. -;;; -(defun compute-tty-changes (first-changed last-changed modeline-pos) - (declare (fixnum modeline-pos)) - (let* ((dl first-changed) - (flags (dis-line-flags (car dl))) - (ins 0) (outs 0) (writes 0) - (prev-delta 0) (cum-deletes 0) (net-delta 0) (cum-inserts 0) - prev) - (declare (fixnum flags ins outs writes prev-delta cum-deletes net-delta - cum-inserts)) - (loop - (cond - ((= flags new-bit) - (queue (car dl) *tty-line-writes* writes) - (next-dis-line)) - ((not (zerop (the fixnum (logand flags moved-bit)))) - (let* ((start-dl (car dl)) - (start-pos (dis-line-position start-dl)) - (curr-delta (dis-line-delta start-dl)) - (delta-delta (- prev-delta curr-delta)) - (car-dl start-dl)) - (declare (fixnum start-pos curr-delta delta-delta)) - (cond ((plusp delta-delta) - (queue (the fixnum (- start-pos cum-inserts)) - *tty-line-deletions* outs) - (queue delta-delta *tty-line-deletions* outs) - (incf cum-deletes delta-delta) - (decf net-delta delta-delta)) - ((minusp delta-delta) - (let ((eff-pos (the fixnum (+ start-pos delta-delta))) - (num (the fixnum (- delta-delta)))) - (queue eff-pos *tty-line-insertions* ins) - (queue num *tty-line-insertions* ins) - (incf net-delta num) - (incf cum-inserts num))) - (t (error "Internal error -- unexpected zero transition delta ~ - in redisplay."))) - (loop - (cond ((and (zerop (the fixnum (logand flags changed-bit))) - (zerop (the fixnum (logand flags new-bit)))) - (setf (dis-line-flags car-dl) unaltered-bits)) - (t (queue car-dl *tty-line-writes* writes) - ;; keep just the changed-bit on. - (setf (dis-line-flags car-dl) changed-bit))) - (setf (dis-line-delta car-dl) 0) - (next-dis-line) - (setf car-dl (car dl)) - (when (/= (the fixnum (dis-line-delta car-dl)) curr-delta) - (setf prev-delta curr-delta) - (return))))) - ((not (and (zerop (logand (the fixnum flags) changed-bit)) - (zerop (logand (the fixnum flags) new-bit)))) - (queue (car dl) *tty-line-writes* writes) - (next-dis-line)) - (t (next-dis-line))) - (when (eq prev last-changed) - (unless (zerop net-delta) - (cond ((plusp net-delta) - (queue (the fixnum (- modeline-pos cum-deletes net-delta)) - *tty-line-deletions* outs) - (queue net-delta *tty-line-deletions* outs)) - (t (queue (the fixnum (+ modeline-pos net-delta)) - *tty-line-insertions* ins) - (queue (the fixnum (- net-delta)) - *tty-line-insertions* ins)))) - (return (values ins outs writes)))))) - - - -;;;; Smart window redisplay -- operation methods. - -;;; TTY-SMART-CLEAR-TO-EOW clears lines y through the last text line of hunk. -;;; It takes care not to clear a line unless it really has some characters -;;; displayed on it. It also maintains the device's screen image lines. -;;; -(defun tty-smart-clear-to-eow (hunk y) - (let* ((device (device-hunk-device hunk)) - (screen-image (tty-device-screen-image device)) - (clear-to-eol (tty-device-clear-to-eol device))) - (select-hunk hunk) - (do ((y y (1+ y)) - (si-idx (+ *hunk-top-line* y) (1+ si-idx)) - (last (tty-hunk-text-position hunk))) - ((> si-idx last)) - (declare (fixnum y si-idx last)) - (let ((si-line (si-line screen-image si-idx))) - (unless (zerop (si-line-length si-line)) - (funcall clear-to-eol hunk 0 y) - (setf (si-line-length si-line) 0)))))) - -;;; DO-LINE-DELETIONS pops elements off the *tty-lines-deletions* queue, -;;; deleting lines from hunk's area of the screen. The internal screen -;;; image is updated, and the total number of lines deleted is returned. -;;; -(defun do-line-deletions (hunk outs) - (declare (fixnum outs)) - (let* ((i 0) - (device (device-hunk-device hunk)) - (fun (tty-device-delete-line device)) - (fsil 0)) ;free-screen-image-lines - (declare (fixnum i fsil)) - (loop - (when (= i outs) (return fsil)) - (let ((y (dequeue *tty-line-deletions* i)) - (num (dequeue *tty-line-deletions* i))) - (declare (fixnum y num)) - (funcall fun hunk 0 y num) - (select-hunk hunk) - (delete-si-lines (tty-device-screen-image device) - (+ *hunk-top-line* y) num fsil - (tty-device-lines device)) - (incf fsil num))))) - -;;; DO-LINE-INSERTIONS pops elements off the *tty-line-insertions* queue, -;;; inserting lines into hunk's area of the screen. The internal screen -;;; image is updated using free screen image lines pointed to by fsil. -;;; -(defun do-line-insertions (hunk ins fsil) - (declare (fixnum ins fsil)) - (let* ((i 0) - (device (device-hunk-device hunk)) - (fun (tty-device-open-line device))) - (declare (fixnum i)) - (loop - (when (= i ins) (return)) - (let ((y (dequeue *tty-line-insertions* i)) - (num (dequeue *tty-line-insertions* i))) - (declare (fixnum y num)) - (funcall fun hunk 0 y num) - (select-hunk hunk) - (insert-si-lines (tty-device-screen-image device) - (+ *hunk-top-line* y) num fsil - (tty-device-lines device)))))) - -;;; DO-LINE-WRITES pops elements off the *tty-line-writes* queue, displaying -;;; these dis-lines with TTY-SMART-LINE-REDISPLAY. We force output after -;;; each line, so the user can see how far we've gotten in case he chooses -;;; to give more editor commands which will abort redisplay until there's no -;;; more input. -;;; -(defun do-line-writes (hunk writes) - (declare (fixnum writes)) - (let* ((i 0) - (device (device-hunk-device hunk)) - (force-output (device-force-output device))) - (declare (fixnum i)) - (loop - (when (= i writes) (return)) - (tty-smart-line-redisplay device hunk (dequeue *tty-line-writes* i)) - (when force-output (funcall force-output))))) - -;;; TTY-SMART-LINE-REDISPLAY uses an auxiliary screen image structure to -;;; try to do minimal character shipping to the terminal. Roughly, we find -;;; the first different character when comparing what's on the screen and -;;; what should be there; we will start altering the line after this same -;;; initial substring. Then we find, from the end, the first character -;;; that is different, blasting out characters to the lesser of the two -;;; indexes. If the dis-line index is lesser, we have some characters to -;;; delete from the screen, and if the screen index is lesser, we have some -;;; additional dis-line characters to insert. There are a few special -;;; cases that allow us to punt out of the above algorithm sketch. If the -;;; terminal doesn't have insert mode or delete mode, we have blast out to -;;; the end of the dis-line and possibly clear to the end of the screen's -;;; line, as appropriate. Sometimes we don't use insert or delete mode -;;; because of the overhead cost in characters; it simply is cheaper to -;;; blast out characters and clear to eol. -;;; -(defun tty-smart-line-redisplay (device hunk dl - &optional (dl-pos (dis-line-position dl))) - (declare (fixnum dl-pos)) - (let* ((dl-chars (dis-line-chars dl)) - (dl-len (dis-line-length dl))) - (declare (fixnum dl-len) (simple-string dl-chars)) - (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input)) - (select-hunk hunk) - (let* ((screen-image-line (si-line (tty-device-screen-image device) - (+ *hunk-top-line* dl-pos))) - (si-line-chars (si-line-chars screen-image-line)) - (si-line-length (si-line-length screen-image-line)) - (findex (string/= dl-chars si-line-chars - :end1 dl-len :end2 si-line-length))) - (declare (fixnum findex) (simple-string si-line-chars)) - ;; - ;; When the dis-line and screen chars are not string=. - (when findex - (block tslr-main-body - ;; - ;; See if the screen shows an initial substring of the dis-line. - (when (= findex si-line-length) - (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex dl-len) - (replace-si-line si-line-chars dl-chars findex findex dl-len) - (return-from tslr-main-body t)) - ;; - ;; When the dis-line is an initial substring of what's on the screen. - (when (= findex dl-len) - (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos) - (return-from tslr-main-body t)) - ;; - ;; Find trailing substrings that are the same. - (multiple-value-bind (sindex dindex) - (do ((sindex (1- si-line-length) (1- sindex)) - (dindex (1- dl-len) (1- dindex))) - ((or (= sindex -1) - (= dindex -1) - (char/= (schar dl-chars dindex) - (schar si-line-chars sindex))) - (values (1+ sindex) (1+ dindex)))) - (declare (fixnum sindex dindex)) - ;; - ;; No trailing substrings -- blast and clear to eol. - (when (= dindex dl-len) - (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex dl-len) - (when (< dindex sindex) - (funcall (tty-device-clear-to-eol device) - hunk dl-len dl-pos)) - (replace-si-line si-line-chars dl-chars findex findex dl-len) - (return-from tslr-main-body t)) - (let ((lindex (min sindex dindex))) - (cond ((< lindex findex) - ;; This can happen in funny situations -- believe me! - (setf lindex findex)) - (t - (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex lindex) - (replace-si-line si-line-chars dl-chars - findex findex lindex))) - (cond - ((= dindex sindex)) - ((< dindex sindex) - (let ((delete-char-num (- sindex dindex))) - (cond ((and (tty-device-delete-char device) - (worth-using-delete-mode - device delete-char-num (- si-line-length dl-len))) - (funcall (tty-device-delete-char device) - hunk dindex dl-pos delete-char-num)) - (t - (funcall (tty-device-display-string device) - hunk dindex dl-pos dl-chars dindex dl-len) - (funcall (tty-device-clear-to-eol device) - hunk dl-len dl-pos))))) - (t - (if (and (tty-device-insert-string device) - (worth-using-insert-mode device (- dindex sindex))) - (funcall (tty-device-insert-string device) - hunk sindex dl-pos dl-chars sindex dindex) - (funcall (tty-device-display-string device) - hunk sindex dl-pos dl-chars sindex dl-len)))) - (replace-si-line si-line-chars dl-chars - lindex lindex dl-len)))) - (setf (si-line-length screen-image-line) dl-len))) - (setf (dis-line-flags dl) unaltered-bits) - (setf (dis-line-delta dl) 0))) - - - -;;;; Device methods - -;;; Initializing and exiting the device (DEVICE-INIT and DEVICE-EXIT functions). -;;; These can be found in Tty-Display-Rt.Lisp. - - -;;; Clearing the device (DEVICE-CLEAR functions). - -(defun clear-device (device) - (device-write-string (tty-device-clear-string device)) - (cursor-motion device 0 0) - (setf (tty-device-cursor-x device) 0) - (setf (tty-device-cursor-y device) 0)) - - -;;; Moving the cursor around (DEVICE-PUT-CURSOR) - -;;; TTY-PUT-CURSOR makes sure the coordinates are mapped from the hunk's -;;; axis to the screen's and determines the minimal cost cursor motion -;;; sequence. Currently, it does no cost analysis of relative motion -;;; compared to absolute motion but simply makes sure the cursor isn't -;;; already where we want it. -;;; -(defun tty-put-cursor (hunk x y) - (declare (fixnum x y)) - (select-hunk hunk) - (let ((y (the fixnum (+ *hunk-top-line* y))) - (device (device-hunk-device hunk))) - (declare (fixnum y)) - (unless (and (= (the fixnum (tty-device-cursor-x device)) x) - (= (the fixnum (tty-device-cursor-y device)) y)) - (cursor-motion device x y) - (setf (tty-device-cursor-x device) x) - (setf (tty-device-cursor-y device) y)))) - -;;; UPDATE-CURSOR is used in device redisplay methods to make sure the -;;; cursor is where it should be. -;;; -(eval-when (compile eval) - (defmacro update-cursor (hunk x y) - `(funcall (device-put-cursor (device-hunk-device ,hunk)) ,hunk ,x ,y)) -) ;eval-when - -;;; CURSOR-MOTION takes two coordinates on the screen's axis, -;;; moving the cursor to that location. X is the column index, -;;; and y is the line index, but Unix and Termcap believe that -;;; the default order of indexes is first the line and then the -;;; column or (y,x). Because of this, when reversep is non-nil, -;;; we send first x and then y. -;;; -(defun cursor-motion (device x y) - (let ((x-add-char (tty-device-cm-x-add-char device)) - (y-add-char (tty-device-cm-y-add-char device)) - (x-condx-add (tty-device-cm-x-condx-char device)) - (y-condx-add (tty-device-cm-y-condx-char device)) - (one-origin (tty-device-cm-one-origin device))) - (when x-add-char (incf x x-add-char)) - (when (and x-condx-add (> x x-condx-add)) - (incf x (tty-device-cm-x-condx-add-char device))) - (when y-add-char (incf y y-add-char)) - (when (and y-condx-add (> y y-condx-add)) - (incf y (tty-device-cm-y-condx-add-char device))) - (when one-origin (incf x) (incf y))) - (device-write-string (tty-device-cm-string1 device)) - (let ((reversep (tty-device-cm-reversep device)) - (x-pad (tty-device-cm-x-pad device)) - (y-pad (tty-device-cm-y-pad device))) - (if reversep - (cm-output-coordinate x x-pad) - (cm-output-coordinate y y-pad)) - (device-write-string (tty-device-cm-string2 device)) - (if reversep - (cm-output-coordinate y y-pad) - (cm-output-coordinate x x-pad)) - (device-write-string (tty-device-cm-string3 device)))) - -;;; CM-OUTPUT-COORDINATE outputs the coordinate with respect to the pad. If -;;; there is a pad, then the coordinate needs to be sent as digit-char's (for -;;; each digit in the coordinate), and if there is no pad, the coordinate needs -;;; to be converted into a character. Using CODE-CHAR here is not really -;;; portable. With a pad, the coordinate buffer is filled from the end as we -;;; truncate the coordinate by 10, generating ones digits. -;;; -(defconstant cm-coordinate-buffer-len 5) -(defvar *cm-coordinate-buffer* (make-string cm-coordinate-buffer-len)) -;;; -(defun cm-output-coordinate (coordinate pad) - (cond (pad - (let ((i (1- cm-coordinate-buffer-len))) - (loop - (when (= i -1) (error "Terminal has too many lines!")) - (multiple-value-bind (tens ones) - (truncate coordinate 10) - (setf (schar *cm-coordinate-buffer* i) (digit-char ones)) - (when (zerop tens) - (dotimes (n (- pad (- cm-coordinate-buffer-len i))) - (decf i) - (setf (schar *cm-coordinate-buffer* i) #\0)) - (device-write-string *cm-coordinate-buffer* i - cm-coordinate-buffer-len) - (return)) - (decf i) - (setf coordinate tens))))) - (t (tty-write-char (code-char coordinate))))) - - -;;; Writing strings (TTY-DEVICE-DISPLAY-STRING functions) - -;;; DISPLAY-STRING is used to put a string at (x,y) on the device. -;;; -(defun display-string (hunk x y string - &optional (start 0) (end (strlen string))) - (declare (fixnum x y start end)) - (update-cursor hunk x y) - (device-write-string string start end) - (setf (tty-device-cursor-x (device-hunk-device hunk)) - (the fixnum (+ x (the fixnum (- end start)))))) - -;;; DISPLAY-STRING-CHECKING-UNDERLINES is used for terminals that special -;;; case underlines doing an overstrike when they don't otherwise overstrike. -;;; Note: we do not know in this code whether the terminal can backspace (or -;;; what the sequence is), whether the terminal has insert-mode, or whether -;;; the terminal has delete-mode. -;;; -(defun display-string-checking-underlines (hunk x y string - &optional (start 0) - (end (strlen string))) - (declare (fixnum x y start end) (simple-string string)) - (update-cursor hunk x y) - (let ((upos (position #\_ string :test #'char= :start start :end end)) - (device (device-hunk-device hunk))) - (if upos - (let ((previous start) - after-pos) - (declare (fixnum previous after-pos)) - (loop (device-write-string string previous upos) - (setf after-pos (do ((i (1+ upos) (1+ i))) - ((or (= i end) - (char/= (schar string i) #\_)) i) - (declare (fixnum i)))) - (let ((ulen (the fixnum (- after-pos upos))) - (cursor-x (the fixnum (+ x (the fixnum - (- after-pos start)))))) - (declare (fixnum ulen)) - (dotimes (i ulen) (tty-write-char #\space)) - (setf (tty-device-cursor-x device) cursor-x) - (update-cursor hunk upos y) - (dotimes (i ulen) (tty-write-char #\_)) - (setf (tty-device-cursor-x device) cursor-x)) - (setf previous after-pos) - (setf upos (position #\_ string :test #'char= - :start previous :end end)) - (unless upos - (device-write-string string previous end) - (return)))) - (device-write-string string start end)) - (setf (tty-device-cursor-x device) - (the fixnum (+ x (the fixnum (- end start))))))) - - -;;; DEVICE-WRITE-STRING is used to shove a string at the terminal regardless -;;; of cursor position. -;;; -(defun device-write-string (string &optional (start 0) (end (strlen string))) - (declare (fixnum start end)) - (unless (= start end) - (tty-write-string string start (the fixnum (- end start))))) - - -;;; Clearing lines (TTY-DEVICE-CLEAR-TO-EOL, DEVICE-CLEAR-LINES, and -;;; TTY-DEVICE-CLEAR-TO-EOW functions.) - -(defun clear-to-eol (hunk x y) - (update-cursor hunk x y) - (device-write-string - (tty-device-clear-to-eol-string (device-hunk-device hunk)))) - -(defun space-to-eol (hunk x y) - (declare (fixnum x)) - (update-cursor hunk x y) - (let* ((device (device-hunk-device hunk)) - (num (- (the fixnum (tty-device-columns device)) - x))) - (declare (fixnum num)) - (dotimes (i num) (tty-write-char #\space)) - (setf (tty-device-cursor-x device) (+ x num)))) - -(defun clear-lines (hunk x y n) - (let* ((device (device-hunk-device hunk)) - (clear-to-eol (tty-device-clear-to-eol device))) - (funcall clear-to-eol hunk x y) - (do ((y (1+ y) (1+ y)) - (count (1- n) (1- count))) - ((zerop count) - (setf (tty-device-cursor-x device) 0) - (setf (tty-device-cursor-y device) (1- y))) - (declare (fixnum count y)) - (funcall clear-to-eol hunk 0 y)))) - -(defun clear-to-eow (hunk x y) - (declare (fixnum x y)) - (funcall (tty-device-clear-lines (device-hunk-device hunk)) - hunk x y - (the fixnum (- (the fixnum (tty-hunk-text-height hunk)) y)))) - - -;;; Opening and Deleting lines (TTY-DEVICE-OPEN-LINE and TTY-DEVICE-DELETE-LINE) - -(defun open-tty-line (hunk x y &optional (n 1)) - (update-cursor hunk x y) - (dotimes (i n) - (device-write-string (tty-device-open-line-string (device-hunk-device hunk))))) - -(defun delete-tty-line (hunk x y &optional (n 1)) - (update-cursor hunk x y) - (dotimes (i n) - (device-write-string (tty-device-delete-line-string (device-hunk-device hunk))))) - - -;;; Insert and Delete modes (TTY-DEVICE-INSERT-STRING and TTY-DEVICE-DELETE-CHAR) - -(defun tty-insert-string (hunk x y string - &optional (start 0) (end (strlen string))) - (declare (fixnum x y start end)) - (update-cursor hunk x y) - (let* ((device (device-hunk-device hunk)) - (init-string (tty-device-insert-init-string device)) - (char-init-string (tty-device-insert-char-init-string device)) - (cis-len (if char-init-string (length char-init-string))) - (char-end-string (tty-device-insert-char-end-string device)) - (ces-len (if char-end-string (length char-end-string))) - (end-string (tty-device-insert-end-string device))) - (declare (simple-string char-init-string char-end-string)) - (when init-string (device-write-string init-string)) - (if char-init-string - (do ((i start (1+ i))) - ((= i end)) - (device-write-string char-init-string 0 cis-len) - (tty-write-char (schar string i)) - (when char-end-string - (device-write-string char-end-string 0 ces-len))) - (device-write-string string start end)) - (when end-string (device-write-string end-string)) - (setf (tty-device-cursor-x device) - (the fixnum (+ x (the fixnum (- end start))))))) - -(defun worth-using-insert-mode (device insert-char-num) - (let* ((init-string (tty-device-insert-init-string device)) - (char-init-string (tty-device-insert-char-init-string device)) - (char-end-string (tty-device-insert-char-end-string device)) - (end-string (tty-device-insert-end-string device)) - (cost 0)) - (when init-string (incf cost (length (the simple-string init-string)))) - (when char-init-string - (incf cost (* insert-char-num (+ (length (the simple-string - char-init-string)) - (if char-end-string - (length (the simple-string - char-end-string)) - 0))))) - (when end-string (incf cost (length (the simple-string end-string)))) - (< cost insert-char-num))) - -(defun delete-char (hunk x y &optional n) - (declare (fixnum x y n)) - (update-cursor hunk x y) - (let* ((device (device-hunk-device hunk)) - (init-string (tty-device-delete-init-string device)) - (end-string (tty-device-delete-end-string device)) - (delete-char-string (tty-device-delete-char-string device))) - (when init-string (device-write-string init-string)) - (dotimes (i n) - (device-write-string delete-char-string)) - (when end-string (device-write-string end-string)))) - -(defun worth-using-delete-mode (device delete-char-num clear-char-num) - (declare (fixnum num)) - (let ((init-string (tty-device-delete-init-string device)) - (end-string (tty-device-delete-end-string device)) - (delete-char-string (tty-device-delete-char-string device)) - (clear-to-eol-string (tty-device-clear-to-eol-string device)) - (cost 0)) - (declare (simple-string init-string end-string delete-char-string) - (fixnum cost)) - (when init-string (incf cost (the fixnum (length init-string)))) - (when end-string (incf cost (the fixnum (length end-string)))) - (incf cost (the fixnum - (* (the fixnum (length delete-char-string)) - delete-char-num))) - (< cost (+ delete-char-num - (if clear-to-eol-string - (length clear-to-eol-string) - clear-char-num))))) - - -;;; Standout mode (TTY-DEVICE-STANDOUT-INIT and TTY-DEVICE-STANDOUT-END) - -(defun standout-init (hunk) - (device-write-string - (tty-device-standout-init-string (device-hunk-device hunk)))) - -(defun standout-end (hunk) - (device-write-string - (tty-device-standout-end-string (device-hunk-device hunk)))) diff --git a/hemlock/tty-screen.lisp b/hemlock/tty-screen.lisp deleted file mode 100644 index 9ca0f1426ac8ac55dfbf21428ea67b78b0373186..0000000000000000000000000000000000000000 --- a/hemlock/tty-screen.lisp +++ /dev/null @@ -1,407 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles, except for the code that implements random typeout, -;;; which was done by Blaine Burks and Bill Chiles. -;;; -;;; Terminal device screen management functions. -;;; - -(in-package "HEMLOCK-INTERNALS") - - - -;;;; Terminal screen initialization - -(proclaim '(special *parse-starting-mark*)) - -(defun init-tty-screen-manager (tty-name) - (setf *line-wrap-char* #\!) - (setf *window-list* ()) - (let* ((device (make-tty-device tty-name)) - (width (tty-device-columns device)) - (height (tty-device-lines device)) - (echo-height (value ed::echo-area-height)) - (main-lines (- height echo-height 1)) ;-1 for echo modeline. - (main-text-lines (1- main-lines)) ;also main-modeline-pos. - (last-text-line (1- main-text-lines))) - (setf (device-bottom-window-base device) last-text-line) - ;; - ;; Make echo area. - (let* ((echo-hunk (make-tty-hunk :position (1- height) :height echo-height - :text-position (- height 2) - :text-height echo-height :device device)) - (echo (internal-make-window :hunk echo-hunk))) - (setf *echo-area-window* echo) - (setf (device-hunk-window echo-hunk) echo) - (setup-window-image *parse-starting-mark* echo echo-height width) - (setup-modeline-image *echo-area-buffer* echo) - (prepare-window-for-redisplay echo)) - ;; - ;; Make the main window. - (let* ((main-hunk (make-tty-hunk :position main-text-lines - :height main-lines - :text-position last-text-line - :text-height main-text-lines - :device device)) - (main (internal-make-window :hunk main-hunk))) - (setf (device-hunk-window main-hunk) main) - (setf *current-window* main) - (setup-window-image (buffer-point *current-buffer*) - main main-text-lines width) - (setup-modeline-image *current-buffer* main) - (prepare-window-for-redisplay main) - (setf (device-hunk-previous main-hunk) main-hunk - (device-hunk-next main-hunk) main-hunk) - (setf (device-hunks device) main-hunk)) - (defhvar "Paren Pause Period" - "This is how long commands that deal with \"brackets\" shows the cursor at - the matching \"bracket\" for this number of seconds." - :value 0.5 - :mode "Lisp") - (defhvar "Highlight Open Parens" - "When non-nil, causes open parens to be displayed in a different font when - the cursor is directly to the right of the corresponding close paren." - :value nil - :mode "Lisp"))) - - - -;;;; Building devices from termcaps. - -;;; MAKE-TTY-DEVICE returns a device built from a termcap. Some function -;;; slots are set to the appropriate function even though the capability -;;; might not exist; in this case, we simply set the control string value -;;; to the empty string. Some function slots are set differently depending -;;; on available capability. -;;; -(defun make-tty-device (name) - (let ((termcap (get-termcap name)) - (device (%make-tty-device :name name))) - (when (termcap :overstrikes termcap) - (error "Terminal sufficiently irritating -- not currently supported.")) - ;; - ;; Similar device slots. - (setf (device-init device) #'init-tty-device) - (setf (device-exit device) #'exit-tty-device) - (setf (device-smart-redisplay device) - (if (and (termcap :open-line termcap) (termcap :delete-line termcap)) - #'tty-smart-window-redisplay - #'tty-semi-dumb-window-redisplay)) - (setf (device-dumb-redisplay device) #'tty-dumb-window-redisplay) - (setf (device-clear device) #'clear-device) - (setf (device-put-cursor device) #'tty-put-cursor) - (setf (device-show-mark device) #'tty-show-mark) - (setf (device-next-window device) #'tty-next-window) - (setf (device-previous-window device) #'tty-previous-window) - (setf (device-make-window device) #'tty-make-window) - (setf (device-delete-window device) #'tty-delete-window) - (setf (device-random-typeout-setup device) #'tty-random-typeout-setup) - (setf (device-random-typeout-cleanup device) #'tty-random-typeout-cleanup) - (setf (device-random-typeout-full-more device) #'do-tty-full-more) - (setf (device-random-typeout-line-more device) - #'update-tty-line-buffered-stream) - (setf (device-force-output device) #'tty-force-output) - (setf (device-finish-output device) #'tty-finish-output) - (setf (device-beep device) #'tty-beep) - ;; - ;; A few useful values. - (setf (tty-device-dumbp device) - (not (and (termcap :open-line termcap) - (termcap :delete-line termcap)))) - (setf (tty-device-lines device) (termcap :lines termcap)) - (setf (tty-device-columns device) - (if (termcap :auto-margins-p termcap) - (1- (termcap :columns termcap)) - (termcap :columns termcap))) - ;; - ;; Some function slots. - (setf (tty-device-display-string device) - (if (termcap :underlines termcap) - #'display-string-checking-underlines - #'display-string)) - (setf (tty-device-standout-init device) #'standout-init) - (setf (tty-device-standout-end device) #'standout-end) - (setf (tty-device-open-line device) - (if (termcap :open-line termcap) - #'open-tty-line - ;; look for scrolling region stuff - )) - (setf (tty-device-delete-line device) - (if (termcap :delete-line termcap) - #'delete-tty-line - ;; look for reverse scrolling stuff - )) - (setf (tty-device-clear-to-eol device) - (if (termcap :clear-to-eol termcap) - #'clear-to-eol - #'space-to-eol)) - (setf (tty-device-clear-lines device) #'clear-lines) - (setf (tty-device-clear-to-eow device) #'clear-to-eow) - ;; - ;; Insert and delete modes. - (let ((init-insert-mode (termcap :init-insert-mode termcap)) - (init-insert-char (termcap :init-insert-char termcap)) - (end-insert-char (termcap :end-insert-char termcap))) - (when (and init-insert-mode (string/= init-insert-mode "")) - (setf (tty-device-insert-string device) #'tty-insert-string) - (setf (tty-device-insert-init-string device) init-insert-mode) - (setf (tty-device-insert-end-string device) - (termcap :end-insert-mode termcap))) - (when init-insert-char - (setf (tty-device-insert-string device) #'tty-insert-string) - (setf (tty-device-insert-char-init-string device) init-insert-char)) - (when (and end-insert-char (string/= end-insert-char "")) - (setf (tty-device-insert-char-end-string device) end-insert-char))) - (let ((delete-char (termcap :delete-char termcap))) - (when delete-char - (setf (tty-device-delete-char device) #'delete-char) - (setf (tty-device-delete-char-string device) delete-char) - (setf (tty-device-delete-init-string device) - (termcap :init-delete-mode termcap)) - (setf (tty-device-delete-end-string device) - (termcap :end-delete-mode termcap)))) - ;; - ;; Some string slots. - (setf (tty-device-standout-init-string device) - (or (termcap :init-standout-mode termcap) "")) - (setf (tty-device-standout-end-string device) - (or (termcap :end-standout-mode termcap) "")) - (setf (tty-device-clear-to-eol-string device) - (termcap :clear-to-eol termcap)) - (let ((clear-string (termcap :clear-display termcap))) - (unless clear-string - (error "Terminal not sufficiently powerful enough to run Hemlock.")) - (setf (tty-device-clear-string device) clear-string)) - (setf (tty-device-open-line-string device) - (termcap :open-line termcap)) - (setf (tty-device-delete-line-string device) - (termcap :delete-line termcap)) - (let* ((init-string (termcap :init-string termcap)) - (init-file (termcap :init-file termcap)) - (init-file-string (if init-file (get-init-file-string init-file))) - (init-cm-string (termcap :init-cursor-motion termcap))) - (setf (tty-device-init-string device) - (concatenate 'simple-string (or init-string "") - (or init-file-string "") (or init-cm-string "")))) - (setf (tty-device-cm-end-string device) - (or (termcap :end-cursor-motion termcap) "")) - ;; - ;; Cursor motion slots. - (let ((cursor-motion (termcap :cursor-motion termcap))) - (unless cursor-motion - (error "Terminal not sufficiently powerful enough to run Hemlock.")) - (let ((x-add-char (getf cursor-motion :x-add-char)) - (y-add-char (getf cursor-motion :y-add-char)) - (x-condx-char (getf cursor-motion :x-condx-char)) - (y-condx-char (getf cursor-motion :y-condx-char))) - (when x-add-char - (setf (tty-device-cm-x-add-char device) (char-code x-add-char))) - (when y-add-char - (setf (tty-device-cm-y-add-char device) (char-code y-add-char))) - (when x-condx-char - (setf (tty-device-cm-x-condx-char device) (char-code x-condx-char)) - (setf (tty-device-cm-x-condx-add-char device) - (char-code (getf cursor-motion :x-condx-add-char)))) - (when y-condx-char - (setf (tty-device-cm-y-condx-char device) (char-code y-condx-char)) - (setf (tty-device-cm-y-condx-add-char device) - (char-code (getf cursor-motion :y-condx-add-char))))) - (setf (tty-device-cm-string1 device) (getf cursor-motion :string1)) - (setf (tty-device-cm-string2 device) (getf cursor-motion :string2)) - (setf (tty-device-cm-string3 device) (getf cursor-motion :string3)) - (setf (tty-device-cm-one-origin device) (getf cursor-motion :one-origin)) - (setf (tty-device-cm-reversep device) (getf cursor-motion :reversep)) - (setf (tty-device-cm-x-pad device) (getf cursor-motion :x-pad)) - (setf (tty-device-cm-y-pad device) (getf cursor-motion :y-pad))) - ;; - ;; Screen image initialization. - (let* ((lines (tty-device-lines device)) - (columns (tty-device-columns device)) - (screen-image (make-array lines))) - (dotimes (i lines) - (setf (svref screen-image i) (make-si-line columns))) - (setf (tty-device-screen-image device) screen-image)) - device)) - - - -;;;; Making a window - -(defun tty-make-window (device start modelinep window font-family - ask-user x y width height) - (declare (ignore window font-family ask-user x y width height)) - (let* ((victim (tty-find-biggest-hunk device)) - (text-height (tty-hunk-text-height victim)) - (availability (if modelinep (1- text-height) text-height))) - (when (> availability 1) - (let* ((new-lines (truncate availability 2)) - (old-lines (- availability new-lines)) - (pos (device-hunk-position victim)) - (new-height (if modelinep (1+ new-lines) new-lines)) - (new-text-pos (if modelinep (1- pos) pos)) - (new-hunk (make-tty-hunk :position pos - :height new-height - :text-position new-text-pos - :text-height new-lines - :device device)) - (new-window (internal-make-window :hunk new-hunk)) - (old-window (device-hunk-window victim))) - (declare (fixnum new-lines old-lines pos new-height new-text-pos)) - (setf (device-hunk-window new-hunk) new-window) - (let* ((old-text-pos-diff (- pos (tty-hunk-text-position victim))) - (old-win-new-pos (- pos new-height))) - (declare (fixnum old-text-pos-diff old-win-new-pos)) - (setf (device-hunk-height victim) - (- (device-hunk-height victim) new-height)) - (setf (tty-hunk-text-height victim) old-lines) - (setf (device-hunk-position victim) old-win-new-pos) - (setf (tty-hunk-text-position victim) - (- old-win-new-pos old-text-pos-diff))) - (setup-window-image start new-window new-lines - (window-width old-window)) - (prepare-window-for-redisplay new-window) - (when modelinep - (setup-modeline-image (line-buffer (mark-line start)) new-window)) - (change-window-image-height old-window old-lines) - (shiftf (device-hunk-previous new-hunk) - (device-hunk-previous (device-hunk-next victim)) - new-hunk) - (shiftf (device-hunk-next new-hunk) (device-hunk-next victim) new-hunk) - (setf *currently-selected-hunk* nil) - (setf *screen-image-trashed* t) - new-window)))) - -(defun tty-find-biggest-hunk (device) - (let* ((top-hunk (device-hunks device)) - (hunk (device-hunk-next top-hunk)) - (max-size 0) - biggest) - (declare (fixnum max-size)) - (loop - (when (> (the fixnum (device-hunk-height hunk)) max-size) - (setf max-size (device-hunk-height hunk)) - (setf biggest hunk)) - (when (eq hunk top-hunk) (return biggest)) - (setf hunk (device-hunk-next hunk))))) - - - -;;;; Deleting a window - -(defun tty-delete-window (window) - (let* ((hunk (window-hunk window)) - (prev (device-hunk-previous hunk)) - (next (device-hunk-next hunk)) - (device (device-hunk-device hunk))) - (setf (device-hunk-next prev) next) - (setf (device-hunk-previous next) prev) - (let ((buffer (window-buffer window))) - (setf (buffer-windows buffer) (delq window (buffer-windows buffer)))) - (let ((new-lines (device-hunk-height hunk))) - (declare (fixnum new-lines)) - (cond ((eq next (device-hunks (device-hunk-device next))) - (incf (device-hunk-height prev) new-lines) - (incf (device-hunk-position prev) new-lines) - (incf (tty-hunk-text-height prev) new-lines) - (incf (tty-hunk-text-position prev) new-lines) - (let ((w (device-hunk-window prev))) - (change-window-image-height w (+ new-lines (window-height w))))) - (t - (incf (device-hunk-height next) new-lines) - (incf (tty-hunk-text-height next) new-lines) - (let ((w (device-hunk-window next))) - (change-window-image-height w (+ new-lines (window-height w))))))) - (when (eq hunk (device-hunks device)) - (setf (device-hunks device) next))) - (setf *currently-selected-hunk* nil) - (setf *screen-image-trashed* t)) - - - -;;;; Next and Previous window operations. - -(defun tty-next-window (window) - (device-hunk-window (device-hunk-next (window-hunk window)))) - -(defun tty-previous-window (window) - (device-hunk-window (device-hunk-previous (window-hunk window)))) - - - -;;;; Random typeout support - -(defun tty-random-typeout-setup (device stream height) - (declare (fixnum height)) - (let* ((*more-prompt-action* :empty) - (height (min (1- (device-bottom-window-base device)) height)) - (old-hwindow (random-typeout-stream-window stream)) - (new-hwindow (if old-hwindow - (change-tty-random-typeout-window old-hwindow height) - (setf (random-typeout-stream-window stream) - (make-tty-random-typeout-window - device - (buffer-start-mark - (line-buffer - (mark-line - (random-typeout-stream-mark stream)))) - height))))) - (funcall (tty-device-clear-to-eow device) (window-hunk new-hwindow) 0 0))) - -(defun change-tty-random-typeout-window (window height) - (update-modeline-field (window-buffer window) window :more-prompt) - (let* ((height-1 (1- height)) - (hunk (window-hunk window))) - (setf (device-hunk-position hunk) height-1 - (device-hunk-height hunk) height - (tty-hunk-text-position hunk) (1- height-1) - (tty-hunk-text-height hunk) height-1) - (change-window-image-height window height-1) - window)) - -(defun make-tty-random-typeout-window (device mark height) - (let* ((height-1 (1- height)) - (hunk (make-tty-hunk :position height-1 - :height height - :text-position (1- height-1) - :text-height height-1 - :device device)) - (window (internal-make-window :hunk hunk))) - (setf (device-hunk-window hunk) window) - (setf (device-hunk-device hunk) device) - (setup-window-image mark window height-1 (tty-device-columns device)) - (setf *window-list* (delete window *window-list*)) - (prepare-window-for-redisplay window) - (setup-modeline-image (line-buffer (mark-line mark)) window) - (update-modeline-field (window-buffer window) window :more-prompt) - window)) - -(defun tty-random-typeout-cleanup (stream degree) - (declare (ignore degree)) - (let* ((window (random-typeout-stream-window stream)) - (stream-hunk (window-hunk window)) - (last-line-affected (device-hunk-position stream-hunk)) - (device (device-hunk-device stream-hunk)) - (*more-prompt-action* :normal)) - (declare (fixnum last-line-affected)) - (update-modeline-field (window-buffer window) window :more-prompt) - (funcall (tty-device-clear-to-eow device) stream-hunk 0 0) - (do* ((hunk (device-hunks device) (device-hunk-next hunk)) - (window (device-hunk-window hunk) (device-hunk-window hunk)) - (last (device-hunk-previous hunk))) - ((>= (device-hunk-position hunk) last-line-affected) - (if (= (device-hunk-position hunk) last-line-affected) - (redisplay-window-all window) - (tty-redisplay-n-lines window - (- (+ last-line-affected - (tty-hunk-text-height hunk)) - (tty-hunk-text-position hunk))))) - (redisplay-window-all window) - (when (eq hunk last) (return))))) diff --git a/hemlock/tty-stream.lisp b/hemlock/tty-stream.lisp deleted file mode 100644 index 84b1781bf4cd0c52313a996b77d21d50540f008f..0000000000000000000000000000000000000000 --- a/hemlock/tty-stream.lisp +++ /dev/null @@ -1,157 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Some stuff to make streams that write out to terminal hunks. -;;; -;;; Written by Bill Chiles. -;;; -;;; This code is VERY similar to that in Pane-Stream.Lisp. The biggest -;;; (if only) difference is in TTY-HUNK-STREAM-NEWLINE. -;;; - -(in-package 'hemlock-internals) - - - -;;;; Constants - -(defconstant tty-hunk-width-limit 200) - - - -;;;; Structures - -;;; Tty-Hunk streams are inherently buffered by line. - -(defstruct (stream-hunk (:print-function %print-device-hunk) - (:include tty-hunk)) - (width 0 :type fixnum) - (point-x 0 :type fixnum) - (point-y 0 :type fixnum) - (buffer "" :type simple-string)) - -(defstruct (tty-hunk-output-stream (:include stream - (out #'hunk-out) - (sout #'hunk-sout) - (misc #'hunk-misc)) - (:constructor - make-tty-hunk-output-stream ())) - (hunk (make-stream-hunk :buffer (make-string tty-hunk-width-limit)))) - - - -;;;; Tty-hunk-output-stream methods - -;;; HUNK-OUT puts a character into a hunk-stream buffer. If the character -;;; makes the current line wrap, or if the character is a newline, then -;;; call TTY-HUNK-NEWLINE. -;;; -(defun hunk-out (stream character) - (let* ((hunk (tty-hunk-output-stream-hunk stream)) - (x (stream-hunk-point-x hunk))) - (declare (fixnum x)) - (cond ((char= character #\newline) - (tty-hunk-stream-newline hunk) - (return-from hunk-out nil)) - ((= x (the fixnum (stream-hunk-width hunk))) - (setf x 0) - (tty-hunk-stream-newline hunk))) - (setf (schar (stream-hunk-buffer hunk) x) character) - (incf (stream-hunk-point-x hunk)))) - -;;; HUNK-MISC, when finishing or forcing output, only needs to blast -;;; out the buffer at y from 0 to x since these streams are inherently -;;; line buffered. Currently, these characters will be blasted out again -;;; since there isn't a separate buffer index from point-x, and we can't -;;; set point-x to zero since we haven't a newline. -;;; -(defun hunk-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - (:charpos - (let ((hunk (tty-hunk-output-stream-hunk stream))) - (values (stream-hunk-point-x hunk) (stream-hunk-point-y hunk)))) - ((:finish-output :force-output) - (let* ((hunk (tty-hunk-output-stream-hunk stream)) - (device (device-hunk-device hunk))) - (funcall (tty-device-display-string device) - hunk 0 (stream-hunk-point-y hunk) (stream-hunk-buffer hunk) - 0 (stream-hunk-point-x hunk)) - (when (device-force-output device) - (funcall (device-force-output device))))) - (:line-length - (stream-hunk-width (tty-hunk-output-stream-hunk stream))) - (:element-type 'string-char))) - -;;; HUNK-SOUT writes a byte-blt's a string to a hunk-stream's buffer. -;;; When newlines are found, recurse on the substrings delimited by start, -;;; end, and newlines. If the string causes line wrapping, then we break -;;; the string up into line-at-a-time segments calling TTY-HUNK-STREAM-NEWLINE. -;;; -(defun hunk-sout (stream string start end) - (declare (fixnum start end)) - (let* ((hunk (tty-hunk-output-stream-hunk stream)) - (buffer (stream-hunk-buffer hunk)) - (x (stream-hunk-point-x hunk)) - (dst-end (+ x (- end start))) - (width (stream-hunk-width hunk)) - (newlinep (%sp-find-character string start end #\newline))) - (declare (fixnum x dst-end width)) - (cond (newlinep - (let ((previous start) (current newlinep)) - (declare (fixnum previous)) - (loop (when (null current) - (hunk-sout stream string previous end) - (return)) - (hunk-sout stream string previous current) - (tty-hunk-stream-newline hunk) - (setf previous (the fixnum (1+ (the fixnum current)))) - (setf current - (%sp-find-character string previous end #\newline))))) - ((> dst-end width) - (let ((new-start (+ start (- width x)))) - (declare (fixnum new-start)) - (%primitive byte-blt string start buffer x width) - (setf (stream-hunk-point-x hunk) width) - (tty-hunk-stream-newline hunk) - (do ((idx (+ new-start width) (+ idx width)) - (prev new-start idx)) - ((>= idx end) - (let ((dst-end (- end prev))) - (%primitive byte-blt string prev buffer 0 dst-end) - (setf (stream-hunk-point-x hunk) dst-end))) - (declare (fixnum prev idx)) - (%primitive byte-blt string prev buffer 0 width) - (setf (stream-hunk-point-x hunk) width) - (tty-hunk-stream-newline hunk)))) - (t - (%primitive byte-blt string start buffer x dst-end) - (setf (stream-hunk-point-x hunk) dst-end))))) - -;;; TTY-HUNK-STREAM-NEWLINE is the only place we display lines and affect -;;; point-y. We also blast out the buffer in HUNK-MISC. -;;; -(defun tty-hunk-stream-newline (hunk) - (let* ((device (device-hunk-device hunk)) - (force-output-fun (device-force-output device)) - (y (stream-hunk-point-y hunk))) - (declare (fixnum y)) - (when (= y (the fixnum (device-hunk-position hunk))) - (funcall (tty-device-display-string device) hunk 0 y "--More--" 0 8) - (when force-output-fun (funcall force-output-fun)) - (wait-for-more) - (funcall (tty-device-clear-to-eow device) hunk 0 0) - (setf (stream-hunk-point-y hunk) 0) - (setf y 0)) - (funcall (tty-device-display-string device) - hunk 0 y (stream-hunk-buffer hunk) 0 (stream-hunk-point-x hunk)) - (when force-output-fun (funcall force-output-fun)) - (setf (stream-hunk-point-x hunk) 0) - (incf (stream-hunk-point-y hunk)))) diff --git a/hemlock/undo.lisp b/hemlock/undo.lisp deleted file mode 100644 index fc8721bd4ef073dda3474615fdf27b98ff00bc87..0000000000000000000000000000000000000000 --- a/hemlock/undo.lisp +++ /dev/null @@ -1,222 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; -;;; This file contains the implementation of the undo mechanism. - -(in-package 'hemlock) - - - -;;;; -- Constants -- - -(defconstant undo-name "Undo") - - - -;;;; -- Variables -- - -(defvar *undo-info* nil - "Structure containing necessary info to undo last undoable operation.") - - - -;;;; -- Structures -- - -(defstruct (undo-info (:print-function %print-undo-info) - (:constructor %make-undo-info - (name method cleanup method-undo buffer)) - (:copier nil)) - name ; string displayed for user to know what's being undone -- - ; typically a command's name. - (hold-name undo-name) ; holds a name for successive invocations of the - ; "Undo" command. - method ; closure stored by command that undoes the command when invoked. - method-undo ; closure stored by command that undoes what method does. - cleanup ; closure stored by command that cleans up any data for method, - ; such as permanent marks. - buffer) ; buffer the command was invoked in. - -(setf (documentation 'undo-info-name 'function) - "Return the string indicating what would be undone for given undo info.") -(setf (documentation 'undo-info-method 'function) - "Return the closure that undoes a command when invoked.") -(setf (documentation 'undo-info-cleanup 'function) - "Return the closure that cleans up data necessary for an undo method.") -(setf (documentation 'undo-info-buffer 'function) - "Return the buffer that the last undoable command was invoked in.") -(setf (documentation 'undo-info-hold-name 'function) - "Return the name being held since the last invocation of \"Undo\"") -(setf (documentation 'undo-info-method-undo 'function) - "Return the closure that undoes what undo-info-method does.") - - -(defun %print-undo-info (obj s depth) - (declare (ignore depth)) - (format s "#<Undo Info ~S>" (undo-info-name obj))) - - - -;;;; -- Commands -- - -(defcommand "Undo" (p) - "Undo last major change, kill, etc. - Simple insertions and deletions cannot be undone. If you change the buffer - in this way before you undo, you may get slightly wrong results, but this - is probably still useful." - "This is not intended to be called in Lisp code." - (declare (ignore p)) - (if (not *undo-info*) (editor-error "No currently undoable command.")) - (let ((buffer (undo-info-buffer *undo-info*)) - (cleanup (undo-info-cleanup *undo-info*)) - (method-undo (undo-info-method-undo *undo-info*))) - (if (not (eq buffer (current-buffer))) - (editor-error "Undo info is for buffer ~S." (buffer-name buffer))) - (when (prompt-for-y-or-n :prompt (format nil "Undo the last ~A? " - (undo-info-name *undo-info*)) - :must-exist t) - (funcall (undo-info-method *undo-info*)) - (cond (method-undo - (rotatef (undo-info-name *undo-info*) - (undo-info-hold-name *undo-info*)) - (rotatef (undo-info-method *undo-info*) - (undo-info-method-undo *undo-info*))) - (t (if cleanup (funcall cleanup)) - (setf *undo-info* nil)))))) - - - -;;;; -- Primitives -- - -(defun save-for-undo (name method - &optional cleanup method-undo (buffer (current-buffer))) - "Stashes information for next \"Undo\" command invocation. If there is - an undo-info object, it is cleaned up first." - (cond (*undo-info* - (let ((old-cleanup (undo-info-cleanup *undo-info*))) - (if old-cleanup (funcall old-cleanup)) - (setf (undo-info-name *undo-info*) name) - (setf (undo-info-hold-name *undo-info*) undo-name) - (setf (undo-info-method *undo-info*) method) - (setf (undo-info-method-undo *undo-info*) method-undo) - (setf (undo-info-cleanup *undo-info*) cleanup) - (setf (undo-info-buffer *undo-info*) buffer) - *undo-info*)) - (t (setf *undo-info* - (%make-undo-info name method cleanup method-undo buffer))))) - - - -(eval-when (compile eval) - -;;; MAKE-TWIDDLE-REGION-UNDO sets up an undo method that deletes region1, -;;; saving the deleted region and eventually storing it in region2. After -;;; deleting region1, its start and end are made :right-inserting and -;;; :left-inserting, so it will contain region2 when it is inserted at region1's -;;; end. This results in a method that takes region1 with permanent marks -;;; into some buffer and results with the contents of region2 in region1 (with -;;; permanent marks into a buffer) and the contents of region1 (from the buffer) -;;; in region2 (a region without marks into any buffer). -;;; -(defmacro make-twiddle-region-undo (region1 region2) - `#'(lambda () - (let* ((tregion (delete-and-save-region ,region1)) - (mark (region-end ,region1))) - (setf (mark-kind (region-start ,region1)) :right-inserting) - (setf (mark-kind mark) :left-inserting) - (ninsert-region mark ,region2) - (setf ,region2 tregion)))) - -;;; MAKE-DELETE-REGION-UNDO sets up an undo method that deletes region with -;;; permanent marks into a buffer, saving the region in region without any -;;; marks into a buffer, deleting one of the permanent marks, and saving one -;;; permanent mark in the variable mark. This is designed to work with -;;; MAKE-INSERT-REGION-UNDO, so mark results in the location in a buffer where -;;; region will be inserted if this method is undone. -;;; -(defmacro make-delete-region-undo (region mark) - `#'(lambda () - (let ((tregion (delete-and-save-region ,region))) - (delete-mark (region-start ,region)) - (setf ,mark (region-end ,region)) - (setf ,region tregion)))) - -;;; MAKE-INSERT-REGION-UNDO sets up an undo method that inserts region at mark, -;;; saving in the variable region a region with permanent marks in a buffer. -;;; This is designed to work with MAKE-DELETE-REGION-UNDO, so region can later -;;; be deleted. -;;; -(defmacro make-insert-region-undo (region mark) - `#'(lambda () - (let ((tregion (region (copy-mark ,mark :right-inserting) ,mark))) - (setf (mark-kind ,mark) :left-inserting) - (ninsert-region ,mark ,region) - (setf ,region tregion)))) - -) ;eval-when - -;;; MAKE-REGION-UNDO handles three common cases that undo'able commands often -;;; need. This function sets up three closures via SAVE-FOR-UNDO that do -;;; an original undo, undo the original undo, and clean up any permanent marks -;;; the next time SAVE-FOR-UNDO is called. Actually, the original undo and -;;; the undo for the original undo setup here are reversible in that each -;;; invocation of "Undo" switches these, so an undo setup by the function is -;;; undo'able, and the undo of the undo is undo'able, and the .... -;;; -;;; :twiddle -;;; Region has permanent marks into a buffer. Mark-or-region is a region -;;; not connected to any buffer. A first undo deletes region, saving it and -;;; inserting mark-or-region. This also sets region around the inserted -;;; region in the buffer and sets mark-or-region to be the deleted and saved -;;; region. Thus the undo and the undo of the undo are the same action. -;;; :insert -;;; Region is not connected to any buffer. Mark-or-region is a permanent -;;; mark into a buffer where region is to be inserted on a first undo, and -;;; this mark is used to form a region on the first undo that will be -;;; deleted upon a subsequent undo. The cleanup method knows mark-or-region -;;; is a permanent mark into a buffer, but it has to determine if region -;;; has marks into a buffer because if a subsequent undo does occur, region -;;; does point into a buffer. -;;; :delete -;;; Region has permanent marks into a buffer. Mark-or-region should not -;;; have been supplied. A first undo deletes region, saving the deleted -;;; region in region and creating a permanent mark that indicates where to -;;; put region back. The permanent mark is stored in mark-or-region. The -;;; cleanup method has to check that mark-or-region is a mark since it won't -;;; be unless there was a subsequent undo. -;;; -(defun make-region-undo (kind name region &optional mark-or-region) - (case kind - (:twiddle - (save-for-undo name - (make-twiddle-region-undo region mark-or-region) - #'(lambda () - (delete-mark (region-start region)) - (delete-mark (region-end region))) - (make-twiddle-region-undo region mark-or-region))) - (:insert - (save-for-undo name - (make-insert-region-undo region mark-or-region) - #'(lambda () - (let ((mark (region-start region))) - (delete-mark mark-or-region) - (when (line-buffer (mark-line mark)) - (delete-mark mark) - (delete-mark (region-end region))))) - (make-delete-region-undo region mark-or-region))) - (:delete - (save-for-undo name - (make-delete-region-undo region mark-or-region) - #'(lambda () - (delete-mark (region-start region)) - (delete-mark (region-end region)) - (if (markp mark-or-region) (delete-mark mark-or-region))) - (make-insert-region-undo region mark-or-region))))) diff --git a/hemlock/unixcoms.lisp b/hemlock/unixcoms.lisp deleted file mode 100644 index 12e887d2ae69a62fa218d33326fd1717e71ac88d..0000000000000000000000000000000000000000 --- a/hemlock/unixcoms.lisp +++ /dev/null @@ -1,220 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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@CS.CMU.EDU). -;;; ********************************************************************** -;;; -;;; -;;; This file contains Commands useful when running on a Unix box. Hopefully -;;; there are no CMU Unix dependencies though there are probably CMU Common -;;; Lisp dependencies, such as RUN-PROGRAM. -;;; -;;; Written by Christopher Hoover. - -(in-package "HEMLOCK") - - - -;;;; Region and File printing commands. - -(defhvar "Print Utility" - "UNIX(tm) program to invoke (via EXT:RUN-PROGRAM) to do printing. - The program should act like lpr: if a filename is given as an argument, - it should print that file, and if no name appears, standard input should - be assumed." - :value "/usr/cs/bin/lpr") - -(defhvar "Print Utility Switches" - "Switches to pass to the \"Print Utility\" program. This should be a list - of strings." - :value ()) - - -;;; PRINT-SOMETHING calls RUN-PROGRAM on the utility-name and args. Output -;;; and error output are done to the echo area, and errors are ignored for -;;; now. Run-program-keys are other keywords to pass to RUN-PROGRAM in -;;; addition to :wait, :output, and :error. -;;; -(defmacro print-something (&optional (run-program-keys) - (utility-name '(value print-utility)) - (args '(value print-utility-switches))) - (let ((pid (gensym)) - (error-code (gensym))) - `(multiple-value-bind (,pid ,error-code) - (ext:run-program ,utility-name ,args - ,@run-program-keys - :wait t - :output *echo-area-stream* - :error *echo-area-stream*) - (declare (ignore ,pid ,error-code)) - (force-output *echo-area-stream*) - ;; Keep the echo area from being cleared at the top of the command loop. - (setf (buffer-modified *echo-area-buffer*) nil)))) - - -;;; PRINT-REGION -- Interface -;;; -;;; Takes a region and outputs the text to the program defined by -;;; the hvar "Print Utility" with options form the hvar "Print -;;; Utility Options" using PRINT-SOMETHING. -;;; -(defun print-region (region) - (with-input-from-region (s region) - (print-something (:input s)))) - - -(defcommand "Print Buffer" (p) - "Prints the current buffer using the program defined by the hvar - \"Print Utility\" with the options from the hvar \"Print Utility - Options\". Errors appear in the echo area." - "Prints the contents of the buffer." - (declare (ignore p)) - (message "Printing buffer...~%") - (print-region (buffer-region (current-buffer)))) - -(defcommand "Print Region" (p) - "Prints the current region using the program defined by the hvar - \"Print Utility\" with the options from the hvar \"Print Utility - Options\". Errors appear in the echo area." - "Prints the current region." - (declare (ignore p)) - (message "Printing region...~%") - (print-region (current-region))) - -(defcommand "Print File" (p) - "Prompts for a file and prints it usings the program defined by - the hvar \"Print Utility\" with the options from the hvar \"Print - Utility Options\". Errors appear in the echo area." - "Prints a file." - (declare (ignore p)) - (let* ((pn (prompt-for-file :prompt "File to print: " - :help "Name of file to print." - :default (buffer-default-pathname (current-buffer)) - :must-exist t)) - (ns (namestring (truename pn)))) - (message "Printing file...~%") - (print-something () (value print-utility) - (append (value print-utility-switches) (list ns))))) - - -;;;; Scribe. - -(defcommand "Scribe File" (p) - "Scribe a file with the default directory set to the directory of the - specified file. The output from running Scribe is sent to the - \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility - Switches\"." - "Scribe a file with the default directory set to the directory of the - specified file." - (declare (ignore p)) - (scribe-file (prompt-for-file :prompt "Scribe file: " - :default - (buffer-default-pathname (current-buffer))))) - -(defhvar "Scribe Buffer File Confirm" - "When set, \"Scribe Buffer File\" prompts for confirmation before doing - anything." - :value t) - -(defcommand "Scribe Buffer File" (p) - "Scribe the file associated with the current buffer. The default directory - set to the directory of the file. The output from running Scribe is sent to - the \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility - Switches\". Before doing anything the user is asked to confirm saving and - Scribe'ing the file. This prompting can be inhibited by with \"Scribe Buffer - File Confirm\"." - "Scribe a file with the default directory set to the directory of the - specified file." - (declare (ignore p)) - (let* ((buffer (current-buffer)) - (pathname (buffer-pathname buffer)) - (modified (buffer-modified buffer))) - (when (or (not (value scribe-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "~:[S~;Save and s~]cribe file ~A? " - modified (namestring pathname)))) - (when modified (write-buffer-file buffer pathname)) - (scribe-file pathname)))) - -(defhvar "Scribe Utility" - "Program name to invoke (via EXT:RUN-PROGRAM) to do text formatting." - :value "/usr/misc/bin/scribe") - -(defhvar "Scribe Utility Switches" - "Switches to pass to the \"Scribe Utility\" program. This should be a list - of strings." - :value ()) - -(defun scribe-file (pathname) - (let* ((pathname (truename pathname)) - (out-buffer (or (getstring "Scribe Warnings" *buffer-names*) - (make-buffer "Scribe Warnings"))) - (out-point (buffer-end (buffer-point out-buffer))) - (stream (make-hemlock-output-stream out-point :line))) - (buffer-end out-point) - (insert-character out-point #\newline) - (insert-character out-point #\newline) - (ext:run-program (namestring (value scribe-utility)) - (list* (namestring pathname) - (value scribe-utility-switches)) - :output stream :error stream - :wait nil - :before-execve - #'(lambda () - (setf (default-directory) (directory-namestring pathname)))))) - - - -;;;; UNIX Filter Region - -(defcommand "Unix Filter Region" (p) - "Unix Filter Region 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 undo-able." - "UNIX-FILTER-REGION-COMMAND is not intended to be called from normal - Hemlock commands; use UNIX-FILTER-REGION instead." - (declare (ignore p)) - (let* ((region (current-region)) - (filter-and-args (prompt-for-string - :prompt "Filter: " - :help "Unix program to filter the region through.")) - (filter-and-args-list (listify-unix-filter-string filter-and-args)) - (filter (car filter-and-args-list)) - (args (cdr filter-and-args-list)) - (new-region (unix-filter-region region filter args)) - (start (copy-mark (region-start region) :right-inserting)) - (end (copy-mark (region-end region) :left-inserting)) - (old-region (region start end)) - (undo-region (delete-and-save-region old-region))) - (ninsert-region end new-region) - (make-region-undo :twiddle "Unix Filter Region" old-region undo-region))) - -(defun unix-filter-region (region command args) - "Passes the region REGION as standard input to the program COMMAND - with arguments ARGS and returns the standard output as a freshly - cons'ed region." - (let ((new-region (make-empty-region))) - (with-input-from-region (input region) - (with-output-to-mark (output (region-end new-region) :full) - (ext:run-program command args - :input input - :output output - :error output))) - new-region)) - -(defun listify-unix-filter-string (str) - (declare (simple-string str)) - (let ((result nil) - (lastpos 0)) - (loop - (let ((pos (position #\Space str :start lastpos :test #'char=))) - (push (subseq str lastpos pos) result) - (unless pos - (return)) - (setf lastpos (1+ pos)))) - (nreverse result))) diff --git a/hemlock/vars.lisp b/hemlock/vars.lisp deleted file mode 100644 index f8776df7aacf32f08d39a4a57d29a747310f06f8..0000000000000000000000000000000000000000 --- a/hemlock/vars.lisp +++ /dev/null @@ -1,301 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; -;;; The file contains the routines which define Hemlock variables. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(variable-value variable-hooks variable-documentation variable-name - hemlock-bound-p defhvar delete-variable)) - -(defstruct (binding - (:type vector) - (:copier nil) - (:constructor make-binding (cons object across symbol))) - cons ; The cons which holds the value for the property. - object ; The variable-object for the binding. - across ; The next binding in this place. - symbol) ; The symbol name for the variable bound. - - - -;;; UNDEFINED-VARIABLE-ERROR -- Internal -;;; -;;; Complain about an undefined Hemlock variable in a helpful fashion. -;;; -(defun undefined-variable-error (name) - (if (eq (symbol-package name) (find-package "HEMLOCK")) - (error "Undefined Hemlock variable ~A." name) - (error "Hemlock variables must be in the \"HEMLOCK\" package, but~%~ - ~S is in the ~S package." - name (package-name (symbol-package name))))) - -;;; GET-MODE-OBJECT -- Internal -;;; -;;; Get the mode-object corresponding to name or die trying. -;;; -(defun get-mode-object (name) - (unless (stringp name) (error "Mode name ~S is not a string." name)) - (let ((res (getstring name *mode-names*))) - (unless res (error "~S is not a defined mode." name)) - res)) - -;;; FIND-BINDING -- Internal -;;; -;;; Return the Binding object corresponding to Name in the collection -;;; of binding Binding, or NIL if none. -;;; -(defun find-binding (name binding) - (do ((b binding (binding-across b))) - ((null b) nil) - (when (eq (binding-symbol b) name) (return b)))) - -;;; GET-VARIABLE-OBJECT -- Internal -;;; -;;; Get the variable-object with the specified symbol-name, kind and where, -;;; or die trying. -;;; -(defun get-variable-object (name kind where) - (case kind - (:current - (let ((obj (get name 'hemlock-variable-value))) - (if obj obj (undefined-variable-error name)))) - (:buffer - (check-type where buffer) - (let ((binding (find-binding name (buffer-var-values where)))) - (unless binding - (error "~S is not a defined Hemlock variable in buffer ~S." name where)) - (binding-object binding))) - (:global - (do ((obj (get name 'hemlock-variable-value) - (variable-object-down obj)) - (prev nil obj)) - ((symbolp obj) - (unless prev (undefined-variable-error name)) - (unless (eq obj :global) - (error "Hemlock variable ~S is not globally defined." name)) - prev))) - (:mode - (let ((binding (find-binding name (mode-object-var-values - (get-mode-object where))))) - (unless binding - (error "~S is not a defined Hemlock variable in mode ~S." name where)) - (binding-object binding))) - (t - (error "~S is not a defined value for Kind." kind)))) - -;;; VARIABLE-VALUE -- Public -;;; -;;; Get the value of the Hemlock variable "name". -;;; -(defun variable-value (name &optional (kind :current) where) - "Return the value of the Hemlock variable given." - (variable-object-value (get-variable-object name kind where))) - -;;; %VALUE -- Internal -;;; -;;; This function is called by the expansion of Value. -;;; -(defun %value (name) - (let ((obj (get name 'hemlock-variable-value))) - (unless obj (undefined-variable-error name)) - (variable-object-value obj))) - -;;; %SET-VALUE -- Internal -;;; -;;; The setf-inverse of Value, set the current value. -;;; -(defun %set-value (var new-value) - (let ((obj (get var 'hemlock-variable-value))) - (unless obj (undefined-variable-error var)) - (invoke-hook (variable-object-hooks obj) var :current nil new-value) - (setf (variable-object-value obj) new-value))) - -;;; %SET-VARIABLE-VALUE -- Internal -;;; -;;; Set the Hemlock variable with the symbol name "name". -;;; -(defun %set-variable-value (name kind where new-value) - (let ((obj (get-variable-object name kind where))) - (invoke-hook (variable-object-hooks obj) name kind where new-value) - (setf (variable-object-value obj) new-value))) - -;;; VARIABLE-HOOKS -- Public -;;; -;;; Return the list of hooks for "name". -;;; -(defun variable-hooks (name &optional (kind :current) where) - "Return the list of hook functions for the Hemlock variable given." - (variable-object-hooks (get-variable-object name kind where))) - -;;; %SET-VARIABLE-HOOKS -- Internal -;;; -;;; Set the hook-list for Hemlock variable Name. -;;; -(defun %set-variable-hooks (name kind where new-value) - (setf (variable-object-hooks (get-variable-object name kind where)) new-value)) - -;;; VARIABLE-DOCUMENTATION -- Public -;;; -;;; Return the documentation for "name". -;;; -(defun variable-documentation (name &optional (kind :current) where) - "Return the documentation for the Hemlock variable given." - (variable-object-documentation (get-variable-object name kind where))) - -;;; %SET-VARIABLE-DOCUMENTATION -- Internal -;;; -;;; Set a variables documentation. -;;; -(defun %set-variable-documentation (name kind where new-value) - (setf (variable-object-documentation (get-variable-object name kind where)) - new-value)) - -;;; VARIABLE-NAME -- Public -;;; -;;; Return the String Name for a Hemlock variable. -;;; -(defun variable-name (name &optional (kind :current) where) - "Return the string name of a Hemlock variable." - (variable-object-name (get-variable-object name kind where))) - -;;; HEMLOCK-BOUND-P -- Public -;;; -(defun hemlock-bound-p (name &optional (kind :current) where) - "Returns T Name is a Hemlock variable defined in the specifed place, or - NIL otherwise." - (case kind - (:current (not (null (get name 'hemlock-variable-value)))) - (:buffer - (check-type where buffer) - (not (null (find-binding name (buffer-var-values where))))) - (:global - (do ((obj (get name 'hemlock-variable-value) - (variable-object-down obj))) - ((symbolp obj) (eq obj :global)))) - (:mode - (not (null (find-binding name (mode-object-var-values - (get-mode-object where)))))))) - -(defun string-to-variable (string) - "Returns the symbol name of a Hemlock variable from the corresponding string - name." - (intern (nsubstitute #\- #\space (the simple-string (string-upcase string))) - (find-package "HEMLOCK"))) - -(proclaim '(special *global-variable-names*)) - -;;; DEFHVAR -- Public -;;; -;;; Define a Hemlock variable somewhere. -;;; -(defun defhvar (name documentation &key mode buffer (hooks nil hook-p) - (value nil value-p)) - (let* ((symbol-name (string-to-variable name)) - (new-binding (make-variable-object documentation name)) - (plist (symbol-plist symbol-name)) - (prop (cdr (or (memq 'hemlock-variable-value plist) - (setf (symbol-plist symbol-name) - (list* 'hemlock-variable-value nil plist))))) - (kind :global) where string-table) - (cond - (mode - (setq kind :mode where mode) - (let* ((obj (get-mode-object where)) - (vars (mode-object-var-values obj))) - (setq string-table (mode-object-variables obj)) - (unless (find-binding symbol-name vars) - (let ((binding (make-binding prop new-binding vars symbol-name))) - (cond ((memq obj (buffer-mode-objects *current-buffer*)) - (let ((l (unwind-bindings obj))) - (setf (mode-object-var-values obj) binding) - (wind-bindings l))) - (t - (setf (mode-object-var-values obj) binding))))))) - (buffer - (check-type buffer buffer) - (setq kind :buffer where buffer string-table (buffer-variables buffer)) - (let ((vars (buffer-var-values buffer))) - (unless (find-binding symbol-name vars) - (let ((binding (make-binding prop new-binding vars symbol-name))) - (setf (buffer-var-values buffer) binding) - (when (eq buffer *current-buffer*) - (setf (variable-object-down new-binding) (car prop) - (car prop) new-binding)))))) - (t - (setq string-table *global-variable-names*) - (unless (hemlock-bound-p symbol-name :global) - (setf (variable-object-down new-binding) :global) - (let ((l (unwind-bindings nil))) - (setf (car prop) new-binding) - (wind-bindings l))))) - (setf (getstring name string-table) symbol-name) - (when hook-p - (setf (variable-hooks symbol-name kind where) hooks)) - (when value-p - (setf (variable-value symbol-name kind where) value))) - name) - -;;; DELETE-BINDING -- Internal -;;; -;;; Delete a binding from a list of bindings. -;;; -(defun delete-binding (binding bindings) - (do ((b bindings (binding-across b)) - (prev nil b)) - ((eq b binding) - (cond (prev - (setf (binding-across prev) (binding-across b)) - bindings) - (t - (binding-across bindings)))))) - -;;; DELETE-VARIABLE -- Public -;;; -;;; Make a Hemlock variable no longer bound, fixing up the saved -;;;binding values as necessary. -;;; -(defun delete-variable (name &optional (kind :global) where) - "Delete a Hemlock variable somewhere." - (let* ((obj (get-variable-object name kind where)) - (sname (variable-object-name obj))) - (case kind - (:buffer - (let* ((values (buffer-var-values where)) - (binding (find-binding name values))) - (invoke-hook ed::delete-variable-hook name :buffer where) - (delete-string sname (buffer-variables where)) - (setf (buffer-var-values where) (delete-binding binding values)) - (when (eq where *current-buffer*) - (setf (car (binding-cons binding)) (variable-object-down obj))))) - (:mode - (let* ((mode (get-mode-object where)) - (values (mode-object-var-values mode)) - (binding (find-binding name values))) - (invoke-hook ed::delete-variable-hook name :mode where) - (delete-string sname (mode-object-variables mode)) - (if (memq mode (buffer-mode-objects *current-buffer*)) - (let ((l (unwind-bindings mode))) - (setf (mode-object-var-values mode) - (delete-binding binding values)) - (wind-bindings l)) - (setf (mode-object-var-values mode) - (delete-binding binding values))))) - (:global - (invoke-hook ed::delete-variable-hook name :global nil) - (delete-string sname *global-variable-names*) - (let ((l (unwind-bindings nil))) - (setf (get name 'hemlock-variable-value) nil) - (wind-bindings l))) - (t (error "Invalid variable kind: ~S" kind))) - nil)) diff --git a/hemlock/window.lisp b/hemlock/window.lisp deleted file mode 100644 index 68f0a2e919d212fdc83c5c8306612e3c26c34892..0000000000000000000000000000000000000000 --- a/hemlock/window.lisp +++ /dev/null @@ -1,676 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains implementation independent code which implements -;;; the Hemlock window primitives and most of the code which defines -;;; other aspects of the interface to redisplay. -;;; -;;; Written by Bill Chiles and Rob MacLachlan. -;;; - -(in-package "HEMLOCK-INTERNALS") - -(export '(current-window window-buffer modeline-field-width - modeline-field-function make-modeline-field update-modeline-fields - update-modeline-field modeline-field-name modeline-field - editor-finish-output *window-list*)) - - - -;;;; CURRENT-WINDOW. - -(defvar *current-window* nil "The current window object.") -(defvar *window-list* () "A list of all window objects.") - -(proclaim '(inline current-window)) - -(defun current-window () - "Return the current window. The current window is specially treated by - redisplay in several ways, the most important of which is that is does - recentering, ensuring that the Buffer-Point of the current window's - Window-Buffer is always displayed. This may be set with Setf." - *current-window*) - -(defun %set-current-window (new-window) - (invoke-hook ed::set-window-hook new-window) - (move-mark (window-point *current-window*) - (buffer-point (window-buffer *current-window*))) - (move-mark (buffer-point (window-buffer new-window)) - (window-point new-window)) - (setq *current-window* new-window)) - - - -;;;; Window structure support. - -(defun %print-hwindow (obj stream depth) - (declare (ignore depth)) - (write-string "#<Hemlock Window \"" stream) - (write-string (buffer-name (window-buffer obj)) stream) - (write-string "\">" stream)) - - -(defun window-buffer (window) - "Return the buffer which is displayed in Window." - (window-%buffer window)) - -(defun %set-window-buffer (window new-buffer) - (unless (bufferp new-buffer) (error "~S is not a buffer." new-buffer)) - (unless (windowp window) (error "~S is not a window." window)) - (unless (eq new-buffer (window-buffer window)) - (invoke-hook ed::window-buffer-hook window new-buffer) - ;; - ;; Move the window's marks to the new start. - (let ((buffer (window-buffer window))) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) - (move-mark (buffer-display-start buffer) (window-display-start window)) - (push window (buffer-windows new-buffer)) - (move-mark (window-point window) (buffer-point new-buffer)) - (move-mark (window-display-start window) (buffer-display-start new-buffer)) - (move-mark (window-display-end window) (buffer-display-start new-buffer))) - ;; - ;; Delete all the dis-lines, and nil out the line and chars so they get - ;; gc'ed. - (let ((first (window-first-line window)) - (last (window-last-line window)) - (free (window-spare-lines window))) - (unless (eq (cdr first) the-sentinel) - (shiftf (cdr last) free (cdr first) the-sentinel)) - (dolist (dl free) - (setf (dis-line-line dl) nil (dis-line-old-chars dl) nil)) - (setf (window-spare-lines window) free)) - ;; - ;; Set the last line and first&last changed so we know there's nothing there. - (setf (window-last-line window) the-sentinel - (window-first-changed window) the-sentinel - (window-last-changed window) the-sentinel) - ;; - ;; Make sure the window gets updated, and set the buffer. - (setf (window-tick window) -3) - (setf (window-%buffer window) new-buffer))) - - - -;;; %INIT-REDISPLAY sets up redisplay's internal data structures. We create -;;; initial windows, setup some hooks to cause modeline recomputation, and call -;;; any device init necessary. This is called from ED. -;;; -(defun %init-redisplay (display) - (%init-screen-manager display) - (add-hook ed::buffer-major-mode-hook 'queue-buffer-change) - (add-hook ed::buffer-minor-mode-hook 'queue-buffer-change) - (add-hook ed::buffer-name-hook 'queue-buffer-change) - (add-hook ed::buffer-pathname-hook 'queue-buffer-change) - (add-hook ed::buffer-modified-hook 'queue-buffer-change) - (add-hook ed::window-buffer-hook 'queue-window-change) - (let ((device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-init device) device)) - (center-window *current-window* (current-point))) - - - -;;;; Modelines-field structure support. - -(defun print-modeline-field (obj stream ignore) - (declare (ignore ignore)) - (write-string "#<Hemlock Modeline-field " stream) - (prin1 (modeline-field-%name obj) stream) - (write-string ">" stream)) - -(defun print-modeline-field-info (obj stream ignore) - (declare (ignore ignore)) - (write-string "#<Hemlock Modeline-field-info " stream) - (prin1 (modeline-field-%name (ml-field-info-field obj)) stream) - (write-string ">" stream)) - - -(defvar *modeline-field-names* (make-hash-table)) - -(defun make-modeline-field (&key name width function) - "Returns a modeline-field object." - (unless (or (eq width nil) (and (integerp width) (plusp width))) - (error "Width must be nil or a positive integer.")) - (when (gethash name *modeline-field-names*) - (with-simple-restart (continue - "Use the new definition for this modeline field.") - (error "Modeline field ~S already exists." - (gethash name *modeline-field-names*)))) - (setf (gethash name *modeline-field-names*) - (%make-modeline-field name function width))) - -(defun modeline-field (name) - "Returns the modeline-field object named name. If none exists, return nil." - (gethash name *modeline-field-names*)) - - -(proclaim '(inline modeline-field-name modeline-field-width - modeline-field-function)) - -(defun modeline-field-name (ml-field) - "Returns the name of a modeline field object." - (modeline-field-%name ml-field)) - -(defun %set-modeline-field-name (ml-field name) - (check-type ml-field modeline-field) - (when (gethash name *modeline-field-names*) - (error "Modeline field ~S already exists." - (gethash name *modeline-field-names*))) - (remhash (modeline-field-%name ml-field) *modeline-field-names*) - (setf (modeline-field-%name ml-field) name) - (setf (gethash name *modeline-field-names*) ml-field)) - -(defun modeline-field-width (ml-field) - "Returns the width of a modeline field." - (modeline-field-%width ml-field)) - -(proclaim '(special *buffer-list*)) - -(defun %set-modeline-field-width (ml-field width) - (check-type ml-field modeline-field) - (unless (or (eq width nil) (and (integerp width) (plusp width))) - (error "Width must be nil or a positive integer.")) - (unless (eql width (modeline-field-%width ml-field)) - (setf (modeline-field-%width ml-field) width) - (dolist (b *buffer-list*) - (when (buffer-modeline-field-p b ml-field) - (dolist (w (buffer-windows b)) - (update-modeline-fields b w))))) - width) - -(defun modeline-field-function (ml-field) - "Returns the function of a modeline field object. It returns a string." - (modeline-field-%function ml-field)) - -(defun %set-modeline-field-function (ml-field function) - (check-type ml-field modeline-field) - (check-type function function) - (setf (modeline-field-%function ml-field) function) - (dolist (b *buffer-list*) - (when (buffer-modeline-field-p b ml-field) - (dolist (w (buffer-windows b)) - (update-modeline-field b w ml-field)))) - function) - - - -;;;; Modelines maintenance. - -;;; Each window stores a modeline-buffer which is a string hunk-width-limit -;;; long. Whenever a field is updated, we must maintain a maximally long -;;; representation of the modeline in case the window is resized. Updating -;;; then first gets the modeline-buffer setup, and second blasts the necessary -;;; portion into the window's modeline-dis-line, setting the dis-line's changed -;;; flag. -;;; - -(defun update-modeline-fields (buffer window) - "Recompute all the fields of buffer's modeline for window, so the next - redisplay will reflect changes." - (let ((ml-buffer (window-modeline-buffer window))) - (declare (simple-string ml-buffer)) - (when ml-buffer - (let* ((ml-buffer-len - (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos)) - (start 0 (blt-modeline-field-buffer - ml-buffer (car finfos) buffer window start))) - ((null finfos) start))) - (dis-line (window-modeline-dis-line window)) - (len (min (window-width window) ml-buffer-len))) - (replace (the simple-string (dis-line-chars dis-line)) ml-buffer - :end1 len :end2 len) - (setf (window-modeline-buffer-len window) ml-buffer-len) - (setf (dis-line-length dis-line) len) - (setf (dis-line-flags dis-line) changed-bit))))) - -;;; UPDATE-MODELINE-FIELD must replace the entire dis-line-chars with ml-buffer -;;; after blt'ing into buffer. Otherwise it has to do all the work -;;; BLT-MODELINE-FIELD-BUFFER to figure out how to adjust dis-line-chars. It -;;; isn't worth it. Since things could have shifted around, after calling -;;; BLT-MODELINE-FIELD-BUFFER, we get the last field's end to know how long -;;; the buffer is now. -;;; -(defun update-modeline-field (buffer window field) - "Recompute the field of the buffer's modeline for window, so the next - redisplay will reflect the change. Field is either a modeline-field object - or the name of one for buffer." - (let ((finfo (internal-buffer-modeline-field-p buffer field))) - (unless finfo - (error "~S is not a modeline-field or the name of one for buffer ~S." - field buffer)) - (let ((ml-buffer (window-modeline-buffer window)) - (dis-line (window-modeline-dis-line window))) - (declare (simple-string ml-buffer)) - (blt-modeline-field-buffer ml-buffer finfo buffer window - (ml-field-info-start finfo) t) - (let* ((ml-buffer-len (ml-field-info-end - (car (last (buffer-%modeline-fields buffer))))) - (dis-len (min (window-width window) ml-buffer-len))) - (replace (the simple-string (dis-line-chars dis-line)) ml-buffer - :end1 dis-len :end2 dis-len) - (setf (window-modeline-buffer-len window) ml-buffer-len) - (setf (dis-line-length dis-line) dis-len) - (setf (dis-line-flags dis-line) changed-bit))))) - -(defvar *truncated-field-char* #\!) - -;;; BLT-MODELINE-FIELD-BUFFER takes a Hemlock buffer, Hemlock window, the -;;; window's modeline buffer, a modeline-field-info object, a start in the -;;; modeline buffer, and an optional indicating whether a variable width field -;;; should be handled carefully. When the field is fixed-width, this is -;;; simple. When it is variable, we possibly have to shift all the text in the -;;; buffer right or left before storing the new string, updating all the -;;; finfo's after the one we're updating. It is an error for the -;;; modeline-field-function to return anything but a simple-string with -;;; standard-chars. This returns the end of the field blasted into ml-buffer. -;;; -(defun blt-modeline-field-buffer (ml-buffer finfo buffer window start - &optional fix-other-fields-p) - (declare (simple-string ml-buffer)) - (let* ((f (ml-field-info-field finfo)) - (width (modeline-field-width f)) - (string (funcall (modeline-field-function f) buffer window)) - (str-len (length string))) - (declare (simple-string string)) - (setf (ml-field-info-start finfo) start) - (setf (ml-field-info-end finfo) - (cond - ((not width) - (let ((end (min (+ start str-len) hunk-width-limit)) - (last-end (ml-field-info-end finfo))) - (when (and fix-other-fields-p (/= end last-end)) - (blt-ml-field-buffer-fix ml-buffer finfo buffer window - end last-end)) - (replace ml-buffer string :start1 start :end1 end :end2 str-len) - end)) - ((= str-len width) - (let ((end (min (+ start width) hunk-width-limit))) - (replace ml-buffer string :start1 start :end1 end :end2 width) - end)) - ((> str-len width) - (let* ((end (min (+ start width) hunk-width-limit)) - (end-1 (1- end))) - (replace ml-buffer string :start1 start :end1 end-1 :end2 width) - (setf (schar ml-buffer end-1) *truncated-field-char*) - end)) - (t - (let ((buf-replace-end (min (+ start str-len) hunk-width-limit)) - (buf-field-end (min (+ start width) hunk-width-limit))) - (replace ml-buffer string - :start1 start :end1 buf-replace-end :end2 str-len) - (fill ml-buffer #\space :start buf-replace-end :end buf-field-end) - buf-field-end)))))) - -;;; BLT-ML-FIELD-BUFFER-FIX shifts the contents of ml-buffer in the direction -;;; of last-end to end. finfo is a modeline-field-info structure in buffer's -;;; list of these. If there are none following finfo, then we simply store the -;;; new end of the buffer. After blt'ing the text around, we have to update -;;; all the finfos' starts and ends making sure nobody gets to stick out over -;;; the ml-buffer's end. -;;; -(defun blt-ml-field-buffer-fix (ml-buffer finfo buffer window end last-end) - (declare (simple-string ml-buffer)) - (let ((finfos (do ((f (buffer-%modeline-fields buffer) (cdr f))) - ((null f) (error "This field must be here.")) - (if (eq (car f) finfo) - (return (cdr f)))))) - (cond - ((not finfos) - (setf (window-modeline-buffer-len window) (min end hunk-width-limit))) - (t - (let ((buffer-len (window-modeline-buffer-len window))) - (replace ml-buffer ml-buffer - :start1 end - :end1 (min (+ end (- buffer-len last-end)) hunk-width-limit) - :start2 last-end :end2 buffer-len) - (let ((diff (- end last-end))) - (macrolet ((frob (f) - `(setf ,f (min (+ ,f diff) hunk-width-limit)))) - (dolist (f finfos) - (frob (ml-field-info-start f)) - (frob (ml-field-info-end f))) - (frob (window-modeline-buffer-len window))))))))) - - - -;;;; Default modeline and update hooks. - -(make-modeline-field :name :hemlock-literal :width 8 - :function #'(lambda (buffer window) - "Returns \"Hemlock \"." - (declare (ignore buffer window)) - "Hemlock ")) - -(make-modeline-field - :name :package - :function #'(lambda (buffer window) - "Returns the value of buffer's \"Current Package\" followed - by a colon and two spaces, or a string with one space." - (declare (ignore window)) - (if (hemlock-bound-p 'ed::current-package :buffer buffer) - (let ((val (variable-value 'ed::current-package - :buffer buffer))) - (if val - (format nil "~A: " val) - " ")) - " "))) - -(make-modeline-field - :name :modes - :function #'(lambda (buffer window) - "Returns buffer's modes followed by one space." - (declare (ignore window)) - (format nil "~A " (buffer-modes buffer)))) - -(make-modeline-field - :name :modifiedp - :function #'(lambda (buffer window) - "Returns \"* \" if buffer is modified, or the empty string." - (declare (ignore window)) - (let ((modifiedp (buffer-modified buffer))) - (if modifiedp - "* " - "")))) - -(make-modeline-field - :name :buffer-name - :function #'(lambda (buffer window) - "Returns buffer's name followed by a colon and a space if the - name is not derived from the buffer's pathname, or the empty - string." - (declare (ignore window)) - (let ((pn (buffer-pathname buffer)) - (name (buffer-name buffer))) - (cond ((not pn) - (format nil "~A: " name)) - ((string/= (ed::pathname-to-buffer-name pn) name) - (format nil "~A: " name)) - (t ""))))) - - -;;; MAXIMUM-MODELINE-PATHNAME-LENGTH-HOOK is called whenever "Maximum Modeline -;;; Pathname Length" is set. -;;; -(defun maximum-modeline-pathname-length-hook (name kind where new-value) - (declare (ignore name new-value)) - (if (eq kind :buffer) - (hi::queue-buffer-change where) - (dolist (buffer *buffer-list*) - (when (and (buffer-modeline-field-p buffer :buffer-pathname) - (buffer-windows buffer)) - (hi::queue-buffer-change buffer))))) - -(defun buffer-pathname-ml-field-fun (buffer window) - "Returns the namestring of buffer's pathname if there is one. When - \"Maximum Modeline Pathname Length\" is set, and the namestring is too long, - return a truncated namestring chopping off leading directory specifications." - (declare (ignore window)) - (let ((pn (buffer-pathname buffer))) - (if pn - (let* ((name (namestring pn)) - (length (length name)) - ;; Prefer a buffer local value over the global one. - ;; Because variables don't work right, blow off looking for - ;; a value in the buffer's modes. In the future this will - ;; be able to get the "current" value as if buffer were current. - (max (if (hemlock-bound-p 'ed::maximum-modeline-pathname-length - :buffer buffer) - (variable-value 'ed::maximum-modeline-pathname-length - :buffer buffer) - (variable-value 'ed::maximum-modeline-pathname-length - :global)))) - (declare (simple-string name)) - (if (or (not max) (<= length max)) - name - (let* ((extra-chars (+ (- length max) 3)) - (slash (or (position #\/ name :start extra-chars) - ;; If no slash, then file-namestring is very - ;; long, and we should include all of it: - (position #\/ name :from-end t - :end extra-chars)))) - (if slash - (concatenate 'simple-string "..." (subseq name slash)) - name)))) - ""))) - -(make-modeline-field - :name :buffer-pathname - :function 'buffer-pathname-ml-field-fun) - - -(defvar *default-modeline-fields* - (list (modeline-field :hemlock-literal) - (modeline-field :package) - (modeline-field :modes) - (modeline-field :modifiedp) - (modeline-field :buffer-name) - (modeline-field :buffer-pathname)) - "This is the default value for \"Default Modeline Fields\".") - - - -;;; QUEUE-BUFFER-CHANGE is used for various buffer hooks (e.g., mode changes, -;;; name changes, etc.), so it takes some arguments to ignore. These hooks are -;;; invoked at a bad time to update the actual modeline-field, and user's may -;;; have fields that change as a function of the changes this function handles. -;;; This makes his update easier. It doesn't cost much update the entire line -;;; anyway. -;;; -(defun queue-buffer-change (buffer &optional something-else another-else) - (declare (ignore something-else another-else)) - (push (list #'update-modelines-for-buffer buffer) *things-to-do-once*)) - -(defun update-modelines-for-buffer (buffer) - (unless (eq buffer *echo-area-buffer*) - (dolist (w (buffer-windows buffer)) - (update-modeline-fields buffer w)))) - - -;;; QUEUE-WINDOW-CHANGE is used for the "Window Buffer Hook". We ignore the -;;; argument since this hook function is invoked before any changes are made, -;;; and the changes must be made before the fields can be set according to the -;;; window's buffer's properties. Therefore, we must queue the change to -;;; happen sometime before redisplay but after the change takes effect. -;;; -(defun queue-window-change (window &optional something-else) - (declare (ignore something-else)) - (push (list #'update-modeline-for-window window) *things-to-do-once*)) - -(defun update-modeline-for-window (window) - (update-modeline-fields (window-buffer window) window)) - - - -;;;; Bitmap setting up new windows and modifying old. - -(defvar dummy-line (make-window-dis-line "") - "Dummy dis-line that we put at the head of window's dis-lines") -(setf (dis-line-position dummy-line) -1) - - -;;; WINDOW-FOR-HUNK makes a Hemlock window and sets up its dis-lines and marks -;;; to display starting at start. -;;; -(defun window-for-hunk (hunk start modelinep) - (check-type start mark) - (setf (bitmap-hunk-changed-handler hunk) #'window-changed) - (let ((buffer (line-buffer (mark-line start))) - (first (cons dummy-line the-sentinel)) - (width (bitmap-hunk-char-width hunk)) - (height (bitmap-hunk-char-height hunk))) - (when (or (< height minimum-window-lines) - (< width minimum-window-columns)) - (error "Window too small.")) - (unless buffer (error "Window start is not in a buffer.")) - (let ((window - (internal-make-window - :hunk hunk - :display-start (copy-mark start :right-inserting) - :old-start (copy-mark start :temporary) - :display-end (copy-mark start :right-inserting) - :%buffer buffer - :point (copy-mark (buffer-point buffer)) - :height height - :width width - :first-line first - :last-line the-sentinel - :first-changed the-sentinel - :last-changed first - :tick -1))) - (push window *window-list*) - (push window (buffer-windows buffer)) - ;; - ;; Make the dis-lines. - (do ((i (- height) (1+ i)) - (res () - (cons (make-window-dis-line (make-string width)) res))) - ((= i height) (setf (window-spare-lines window) res))) - ;; - ;; Make the image up to date. - (update-window-image window) - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) - ;; - ;; If there is a modeline, set it up. - (when modelinep - (setup-modeline-image buffer window) - (setf (bitmap-hunk-modeline-dis-line hunk) - (window-modeline-dis-line window))) - window))) - -;;; SETUP-MODELINE-IMAGE sets up the modeline-dis-line for window using the -;;; modeline-fields list. This is used by tty redisplay too. -;;; -(defun setup-modeline-image (buffer window) - (setf (window-modeline-buffer window) (make-string hunk-width-limit)) - (setf (window-modeline-dis-line window) - (make-window-dis-line (make-string (window-width window)))) - (update-modeline-fields buffer window)) - -;;; Window-Changed -- Internal -;;; -;;; The bitmap-hunk changed handler for windows. This is only called if -;;; the hunk is not locked. We invalidate the window image and change its -;;; size, then do a full redisplay. -;;; -(defun window-changed (hunk) - (let ((window (bitmap-hunk-window hunk))) - ;; - ;; Nuke all the lines in the window image. - (unless (eq (cdr (window-first-line window)) the-sentinel) - (shiftf (cdr (window-last-line window)) - (window-spare-lines window) - (cdr (window-first-line window)) - the-sentinel)) - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) - ;; - ;; Add some new spare lines if needed. If width is greater, - ;; reallocate the dis-line-chars. - (let* ((res (window-spare-lines window)) - (new-width (bitmap-hunk-char-width hunk)) - (new-height (bitmap-hunk-char-height hunk)) - (width (length (the simple-string (dis-line-chars (car res)))))) - (declare (list res)) - (when (> new-width width) - (setq width new-width) - (dolist (dl res) - (setf (dis-line-chars dl) (make-string new-width)))) - (setf (window-height window) new-height (window-width window) new-width) - (do ((i (- (* new-height 2) (length res)) (1- i))) - ((minusp i)) - (push (make-window-dis-line (make-string width)) res)) - (setf (window-spare-lines window) res) - ;; - ;; Force modeline update. - (let ((ml-buffer (window-modeline-buffer window))) - (when ml-buffer - (let ((dl (window-modeline-dis-line window)) - (chars (make-string new-width)) - (len (min new-width (window-modeline-buffer-len window)))) - (setf (dis-line-old-chars dl) nil) - (setf (dis-line-chars dl) chars) - (replace chars ml-buffer :end1 len :end2 len) - (setf (dis-line-length dl) len) - (setf (dis-line-flags dl) changed-bit))))) - ;; - ;; Prepare for redisplay. - (setf (window-tick window) (tick)) - (update-window-image window) - (when (eq window *current-window*) (maybe-recenter-window window)) - hunk)) - - - -;;; EDITOR-FINISH-OUTPUT is used to synch output to a window with the rest of the -;;; system. -;;; -(defun editor-finish-output (window) - (let* ((device (device-hunk-device (window-hunk window))) - (finish-output (device-finish-output device))) - (when finish-output - (funcall finish-output device window)))) - - - -;;;; Tty setting up new windows and modifying old. - -;;; setup-window-image -- Internal -;;; -;;; Set up the dis-lines and marks for Window to display starting -;;; at Start. Height and Width are the number of lines and columns in -;;; the window. -;;; -(defun setup-window-image (start window height width) - (check-type start mark) - (let ((buffer (line-buffer (mark-line start))) - (first (cons dummy-line the-sentinel))) - (unless buffer (error "Window start is not in a buffer.")) - (setf (window-display-start window) (copy-mark start :right-inserting) - (window-old-start window) (copy-mark start :temporary) - (window-display-end window) (copy-mark start :right-inserting) - (window-%buffer window) buffer - (window-point window) (copy-mark (buffer-point buffer)) - (window-height window) height - (window-width window) width - (window-first-line window) first - (window-last-line window) the-sentinel - (window-first-changed window) the-sentinel - (window-last-changed window) first - (window-tick window) -1) - (push window *window-list*) - (push window (buffer-windows buffer)) - ;; - ;; Make the dis-lines. - (do ((i (- height) (1+ i)) - (res () - (cons (make-window-dis-line (make-string width)) res))) - ((= i height) (setf (window-spare-lines window) res))) - ;; - ;; Make the image up to date. - (update-window-image window))) - -;;; change-window-image-height -- Internal -;;; -;;; Milkshake. -;;; -(defun change-window-image-height (window new-height) - ;; Nuke all the lines in the window image. - (unless (eq (cdr (window-first-line window)) the-sentinel) - (shiftf (cdr (window-last-line window)) - (window-spare-lines window) - (cdr (window-first-line window)) - the-sentinel)) - ;; Add some new spare lines if needed. - (let* ((res (window-spare-lines window)) - (width (length (the simple-string (dis-line-chars (car res)))))) - (declare (list res)) - (setf (window-height window) new-height) - (do ((i (- (* new-height 2) (length res)) (1- i))) - ((minusp i)) - (push (make-window-dis-line (make-string width)) res)) - (setf (window-spare-lines window) res))) diff --git a/hemlock/winimage.lisp b/hemlock/winimage.lisp deleted file mode 100644 index 2d3f6c886a86e2a22038ae20452d7b88789a1886..0000000000000000000000000000000000000000 --- a/hemlock/winimage.lisp +++ /dev/null @@ -1,332 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; -;;; This file contains implementation independant functions that -;;; build window images from the buffer structure. -;;; -(in-package "HEMLOCK-INTERNALS") - -(defvar the-sentinel - (list (make-window-dis-line "")) - "This dis-line, which has several interesting properties, is used to end - lists of dis-lines.") -(setf (dis-line-line (car the-sentinel)) - (make-line :number most-positive-fixnum :chars "")) -(setf (dis-line-position (car the-sentinel)) most-positive-fixnum) -(setf (dis-line-old-chars (car the-sentinel)) :unique-thing)) - - -(defconstant unaltered-bits #b000 - "This is the value of the dis-line-flags when a line is neither moved nor - changed nor new.") -(defconstant changed-bit #b001 - "This bit is set in the dis-line-flags when a line is found to be changed.") -(defconstant moved-bit #b010 - "This bit is set in the dis-line-flags when a line is found to be moved.") -(defconstant new-bit #b100 - "This bit is set in the dis-line-flags when a line is found to be new.") - - -;;; move-lines -- Internal -;;; -;;; This function is called by Maybe-Change-Window when it believes that -;;; a line needs to be inserted or deleted. When called it finishes the -;;; image-update for the entire rest of the window. Here and many other -;;; places the phrase "dis-line" is often used to mean a pointer into the -;;; window's list of dis-lines. -;;; -;;; Window - The window whose image needs to be updated. -;;; Changed - True if the first-changed line has already been set, if false -;;; we must set it. -;;; String - The overhang string to be added to the beginning of the first -;;; line image we build. If no overhang then this is NIL. -;;; Underhang - The number of trailing chars of String to use. -;;; Line - The line at which we are to continue building the image. This -;;; may be NIL, in which case we are at the end of the buffer. -;;; Offset - The charpos within Line to continue at. -;;; Current - The dis-line which caused Maybe-Change-Window to choke; it -;;; may be the-sentinel, it may not be the dummy line at head of the -;;; window's dis-lines. This is the dis-line at which Maybe-Change-Window -;;; turns over control, it should not be one whose image it built. -;;; Trail - This is the dis-line which immediately precedes Current in the -;;; dis-line list. It may be the dummy dis-line, it may not be the sentinel. -;;; Width - (window-width window) -(defun move-lines (window changed string underhang line offset trail current - width) - - (do* ((delta 0) - (cc (car current)) - (old-line (dis-line-line cc)) - ;; Can't use current, since might be the-sentinel. - (pos (1+ (dis-line-position (car trail)))) - ;; Are we on an extension line? - (is-wrapped (eq line (dis-line-line (car trail)))) - (last (window-last-line window)) - (last-line (dis-line-line (car last))) - (save trail) - (height (window-height window)) - (spare-lines (window-spare-lines window)) - ;; Make the-sentinel in this buffer so we don't delete it. - (buffer (setf (line-%buffer (dis-line-line (car the-sentinel))) - (window-buffer window))) - (start offset) new-num) - ((or (= pos height) (null line)) - ;; If we have run off the bottom or run out of lines then we are - ;; done. At this point Trail is the last line displayed and Current is - ;; whatever comes after it, possibly the-sentinel. - ;; We always say that last-changed is the last line so that we - ;; don't have to max in the old last-changed. - (setf (window-last-changed window) trail) - ;; If there are extra lines at the end that need to be deleted - ;; and haven't been already then link them into the free-list. - (unless (eq last trail) - ;; This test works, because if the old last line was either - ;; deleted or another line was inserted after it then it's - ;; cdr would be something else. - (when (eq (cdr last) the-sentinel) - (shiftf (cdr last) spare-lines (cdr trail) the-sentinel)) - (setf (window-last-line window) trail)) - (setf (window-spare-lines window) spare-lines) - ;; If first-changed has not been set then we set the first-changed - ;; to the first line we looked at if it does not come after the - ;; new position of the old first-changed. - (unless changed - (when (> (dis-line-position (car (window-first-changed window))) - (dis-line-position (car save))) - (setf (window-first-changed window) (cdr save))))) - - (setq new-num (line-number line)) - ;; If a line has been deleted, it's line-%buffer is smashed; we unlink - ;; any dis-line which displayed such a line. - (cond - ((neq (line-%buffer old-line) buffer) - (do ((ptr (cdr current) (cdr ptr)) - (prev current ptr)) - ((eq (line-%buffer (dis-line-line (car ptr))) buffer) - (setq delta (- pos (1+ (dis-line-position (car prev))))) - (shiftf (cdr trail) (cdr prev) spare-lines current ptr))) - (setq cc (car current) old-line (dis-line-line cc))) - ;; If the line-number of the old line is less than the line-number - ;; of the line we want to display then the old line must be off the top - ;; of the screen - delete it. The-Sentinel fails this test because - ;; it's line-number is most-positive-fixnum. - ((< (line-number old-line) new-num) - (do ((ptr (cdr current) (cdr ptr)) - (prev current ptr)) - ((>= (line-number (dis-line-line (car ptr))) new-num) - (setq delta (- pos (1+ (dis-line-position (car prev))))) - (shiftf (cdr trail) (cdr prev) spare-lines current ptr))) - (setq cc (car current) old-line (dis-line-line cc))) - ;; New line comes before old line, insert it, punting when - ;; we hit the bottom of the screen. - ((neq line old-line) - (do ((chars (unless is-wrapped (line-%chars line)) nil) new) - (()) - (setq new (car spare-lines)) - (setf (dis-line-old-chars new) chars - (dis-line-position new) pos - (dis-line-line new) line - (dis-line-delta new) 0 - (dis-line-flags new) new-bit) - (setq pos (1+ pos) delta (1+ delta)) - (multiple-value-setq (string underhang start) - (compute-line-image string underhang line start new width)) - (rotatef (cdr trail) spare-lines (cdr spare-lines)) - (setq trail (cdr trail)) - (cond ((= pos height) - (return nil)) - ((null underhang) - (setq start 0 line (line-next line)) - (return nil)))) - (setq is-wrapped nil)) - ;; The line is the same, possibly moved. We add in the delta and - ;; or in the moved bit so that if redisplay punts in the middle - ;; the information is not lost. - ((eq (line-%chars line) (dis-line-old-chars cc)) - ;; If the line is the old bottom line on the screen and it has moved and - ;; is full length, then mash the old-chars and quit so that the image - ;; will be recomputed the next time around the loop, since the line might - ;; have been wrapped off the bottom of the screen. - (cond - ((and (eq line last-line) - (= (dis-line-length cc) width) - (not (zerop delta))) - (setf (dis-line-old-chars cc) :another-unique-thing)) - (t - (do () - ((= pos height)) - (unless (zerop delta) - (setf (dis-line-position cc) pos) - (incf (dis-line-delta cc) delta) - (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit))) - (shiftf trail current (cdr current)) - (setq cc (car current) old-line (dis-line-line cc) pos (1+ pos)) - (when (not (eq old-line line)) - (setq start 0 line (line-next line)) - (return nil)))))) - ;; The line is changed, possibly moved. - (t - (do ((chars (line-%chars line) nil)) - (()) - (multiple-value-setq (string underhang start) - (compute-line-image string underhang line start cc width)) - (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit) - (dis-line-old-chars cc) chars - (dis-line-position cc) pos) - (unless (zerop delta) - (incf (dis-line-delta cc) delta) - (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit))) - (shiftf trail current (cdr current)) - (setq cc (car current) old-line (dis-line-line cc) pos (1+ pos)) - (cond ((= pos height) - (return nil)) - ((null underhang) - (setq start 0 line (line-next line)) - (return nil)) - ((not (eq old-line line)) - (setq is-wrapped t) - (return nil)))))))) - - -;;; maybe-change-window -- Internal -;;; -;;; This macro is "Called" in update-window-image whenever it finds that -;;; the chars of the line and the dis-line don't match. This may happen for -;;; several reasons: -;;; -;;; 1] The previous line was unchanged, but wrapped, so the dis-line-chars -;;; are nil. In this case we just skip over the extension lines. -;;; -;;; 2] A line is changed but not moved; update the line noting whether the -;;; next line is moved because of this, and bugging out to Move-Lines if -;;; it is. -;;; -;;; 3] A line is deleted, off the top of the screen, or moved. Bug out -;;; to Move-Lines. -;;; -;;; There are two possible results, either we return NIL, and Line, -;;; Trail and Current are updated, or we return T, in which case -;;; Update-Window-Image should terminate immediately. Changed is true -;;; if a changed line changed lines has been found. -;;; -(eval-when (compile eval) -(defmacro maybe-change-window (window changed line offset trail current width) - `(let* ((cc (car ,current)) - (old-line (dis-line-line cc))) - (cond - ;; We have run into a continuation line, skip over any. - ((and (null (dis-line-old-chars cc)) - (eq old-line (dis-line-line (car ,trail)))) - (do ((ptr (cdr ,current) (cdr ptr)) - (prev ,current ptr)) - ((not (eq (dis-line-line (car ptr)) old-line)) - (setq ,trail prev ,current ptr) nil))) - ;; A line is changed. - ((eq old-line ,line) - (unless ,changed - (when (< (dis-line-position cc) - (dis-line-position (car (window-first-changed ,window)))) - (setf (window-first-changed ,window) ,current) - (setq ,changed t))) - (do ((chars (line-%chars ,line) nil) - (start ,offset) string underhang) - (()) - (multiple-value-setq (string underhang start) - (compute-line-image string underhang ,line start cc ,width)) - (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit)) - (setf (dis-line-old-chars cc) chars) - (setq ,trail ,current ,current (cdr ,current) cc (car ,current)) - (cond - ((eq (dis-line-line cc) ,line) - (unless underhang - (move-lines ,window t nil 0 (line-next ,line) 0 ,trail ,current - ,width) - (return t))) - (underhang - (move-lines ,window t string underhang ,line start ,trail - ,current ,width) - (return t)) - (t - (setq ,line (line-next ,line)) - (when (> (dis-line-position (car ,trail)) - (dis-line-position (car (window-last-changed ,window)))) - (setf (window-last-changed ,window) ,trail)) - (return nil))))) - (t - (move-lines ,window ,changed nil 0 ,line ,offset ,trail ,current - ,width) - t)))) -); eval-when (compile eval) - -;;; update-window-image -- Internal -;;; -;;; This is the function which redisplay calls when it wants to ensure that -;;; a window-image is up-to-date. The main loop here is just to zoom through -;;; the lines and dis-lines, bugging out to Maybe-Change-Window whenever -;;; something interesting happens. -;;; -(defun update-window-image (window) - (let* ((trail (window-first-line window)) - (current (cdr trail)) - (display-start (window-display-start window)) - (line (mark-line display-start)) - (width (window-width window)) changed) - (cond - ;; If the first line or its charpos has changed then bug out. - ((cond ((and (eq (dis-line-old-chars (car current)) (line-%chars line)) - (mark= display-start (window-old-start window))) - (setq trail current current (cdr current) line (line-next line)) - nil) - (t - ;; Force the line image to be invalid in case the start moved - ;; and the line wrapped onto the screen. If we started at the - ;; beginning of the line then we don't need to. - (unless (zerop (mark-charpos (window-old-start window))) - (unless (eq current the-sentinel) - (setf (dis-line-old-chars (car current)) :another-unique-thing))) - (let ((start-charpos (mark-charpos display-start))) - (move-mark (window-old-start window) display-start) - (maybe-change-window window changed line start-charpos - trail current width))))) - (t - (prog () - (go TOP) - STEP - (setf (dis-line-line (car current)) line) - (setq trail current current (cdr current) line (line-next line)) - TOP - (cond ((null line) - (go DONE)) - ((eq (line-%chars line) (dis-line-old-chars (car current))) - (go STEP))) - ;; - ;; We found a suspect line. - ;; See if anything needs to be updated, if we bugged out, punt. - (when (and (eq current the-sentinel) - (= (dis-line-position (car trail)) - (1- (window-height window)))) - (return nil)) - (when (maybe-change-window window changed line 0 trail current width) - (return nil)) - (go TOP) - - DONE - ;; - ;; We hit the end of the buffer. If lines need to be deleted bug out. - (unless (eq current the-sentinel) - (maybe-change-window window changed line 0 trail current width)) - (return nil)))) - ;; - ;; Update the display-end mark. - (let ((dl (car (window-last-line window)))) - (move-to-position (window-display-end window) (dis-line-end dl) - (dis-line-line dl))))) diff --git a/hemlock/xcoms.lisp b/hemlock/xcoms.lisp deleted file mode 100644 index a80852f6fba6b68b68c848ee08b2daf0f224742c..0000000000000000000000000000000000000000 --- a/hemlock/xcoms.lisp +++ /dev/null @@ -1,58 +0,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains commands and support specifically for X related features. -;;; -;;; Written by Bill Chiles. -;;; - -(in-package 'hemlock) - - -(defcommand "Region to Cut Buffer" (p) - "Place the current region into the X cut buffer." - "Place the current region into the X cut buffer." - (declare (ignore p)) - (store-cut-string (hi::bitmap-device-display - (hi::device-hunk-device (hi::window-hunk (current-window)))) - (region-to-string (current-region)))) - -(defcommand "Insert Cut Buffer" (p) - "Insert the X cut buffer at current point." - "Insert the X cut buffer at current point. Returns nil when it is empty." - (declare (ignore p)) - (let ((str (fetch-cut-string (hi::bitmap-device-display - (hi::device-hunk-device - (hi::window-hunk (current-window))))))) - (if str - (let ((point (current-point))) - (push-buffer-mark (copy-mark point)) - (insert-string (current-point) str)) - (editor-error "X cut buffer empty."))) - (setf (last-command-type) :ephemerally-active)) - - -(defcommand "Stack Window" (p) - "Make a new window that overlays 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 ((cw (current-window))) - (unless (typep (hi::device-hunk-device (hi::window-hunk cw)) - 'hi::bitmap-device) - (editor-error - "This command is only valid when running under a graphical windowing ~ - system.")) - (let ((new (make-window (window-display-start cw) - :window (make-xwindow-like-hwindow cw)))) - (unless new (editor-error "Could not make a new window.")) - (setf (current-window) new)))) diff --git a/ldb/Makefile.orig b/ldb/Makefile.orig deleted file mode 100644 index b0eb937179034f812606fbe68b23acbb1a1f2814..0000000000000000000000000000000000000000 --- a/ldb/Makefile.orig +++ /dev/null @@ -1,151 +0,0 @@ -# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/Makefile.orig,v 1.11 1990/05/23 19:07:59 wlott Exp $ -CFLAGS = -g - -OBJS = ldb.o egets.o coreparse.o alloc.o monitor.o print.o \ - os.o vars.o assem.o parse.o interrupt.o test.o \ - search.o validate.o gc.o globals.o dynbind.o \ - regnames.o backtrace.o bitbash.o - -ldb.map: ldb - echo -n 'Map file for ldb version ' > ldb.map - cat version >> ldb.map - nm -gp ldb >> ldb.map - - -ldb: ${OBJS} version syscalls - echo -n '1 + ' | cat - version | bc > ,version - mv ,version version - cc ${CFLAGS} -DVERSION=`cat version` -c version.c - cc `cat syscalls` -o ,ldb ${OBJS} version.o -lmach -lc - mv -f ,ldb ldb - -version: - echo 0 > version - -syscalls: /usr/man/man2 - ls /usr/man/man2 | sed -e '/intro/d' -e 's/^/-u /' -e 's/\.2$$//' > ,syscalls - mv ,syscalls syscalls - - -# If we get an interrupt while in lisp code, the global pointer -# is trash. Therefore, we can't use the GP relative addressing -# mode in the interrupt handlers. - -interrupt.o: interrupt.c - cc ${CFLAGS} -G 0 -c interrupt.c - -assem.o: assem.s - as -G 0 -o $@ assem.s - -lisp.h: - @echo "You must run genesis to create lisp.h!" - @false - -depend: depends - -depends: - rm -f Makefile.BAK - ln Makefile Makefile.BAK - sed -n '1,/^#@/p' Makefile > Makefile.NEW - cc -M *.[cs] | egrep -v ' /usr/' >> Makefile.NEW - mv Makefile.NEW Makefile - rm Makefile.BAK - -#@ Do not edit anything after this line. -alloc.o: alloc.c -alloc.o: lisp.h -alloc.o: ldb.h -alloc.o: alloc.h -alloc.o: globals.h -alloc.o: lisp.h -assem.o: assem.s -assem.o: lisp.h -assem.o: lispregs.h -assem.o: globals.h -assem.o: lisp.h -backtrace.o: backtrace.c -backtrace.o: ldb.h -backtrace.o: lisp.h -backtrace.o: globals.h -backtrace.o: lisp.h -backtrace.o: interrupt.h -backtrace.o: lispregs.h -coreparse.o: coreparse.c -coreparse.o: lisp.h -coreparse.o: globals.h -coreparse.o: lisp.h -dynbind.o: dynbind.c -dynbind.o: ldb.h -dynbind.o: lisp.h -dynbind.o: globals.h -dynbind.o: lisp.h -egets.o: egets.c -gc.o: gc.c -gc.o: lisp.h -gc.o: ldb.h -gc.o: gc.h -gc.o: lisp.h -gc.o: globals.h -gc.o: lisp.h -gc.o: interrupt.h -gc.o: validate.h -gc.o: lispregs.h -globals.o: globals.c -globals.o: lisp.h -globals.o: globals.h -globals.o: lisp.h -interrupt.o: interrupt.c -interrupt.o: lisp.h -interrupt.o: ldb.h -interrupt.o: globals.h -interrupt.o: lisp.h -interrupt.o: lispregs.h -interrupt.o: interrupt.h -ldb.o: ldb.c -ldb.o: ldb.h -ldb.o: lisp.h -ldb.o: alloc.h -ldb.o: vars.h -monitor.o: monitor.c -monitor.o: ldb.h -monitor.o: lisp.h -monitor.o: globals.h -monitor.o: lisp.h -monitor.o: vars.h -monitor.o: parse.h -monitor.o: interrupt.h -monitor.o: lispregs.h -os.o: os.c -os.o: ldb.h -parse.o: parse.c -parse.o: ldb.h -parse.o: lisp.h -parse.o: globals.h -parse.o: lisp.h -parse.o: vars.h -parse.o: parse.h -parse.o: interrupt.h -parse.o: lispregs.h -print.o: print.c -print.o: ldb.h -print.o: print.h -print.o: lisp.h -print.o: vars.h -regnames.o: regnames.c -regnames.o: lispregs.h -search.o: search.c -search.o: lisp.h -search.o: ldb.h -test.o: test.c -test.o: lisp.h -test.o: ldb.h -validate.o: validate.c -validate.o: lisp.h -validate.o: globals.h -validate.o: lisp.h -validate.o: validate.h -vars.o: vars.c -vars.o: ldb.h -vars.o: lisp.h -vars.o: vars.h -version.o: version.c diff --git a/ldb/alloc.c b/ldb/alloc.c deleted file mode 100644 index aaf141ef163f88707e44acb5bfd519025cb3859b..0000000000000000000000000000000000000000 --- a/ldb/alloc.c +++ /dev/null @@ -1,100 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/alloc.c,v 1.3 1990/05/25 23:55:32 ch Exp $ */ -#include "lisp.h" -#include "ldb.h" -#include "alloc.h" -#include "globals.h" - - -/**************************************************************** -Allocation Routines. -****************************************************************/ - -static lispobj *alloc(bytes) -int bytes; -{ - lispobj *result; - - /* Round to dual word boundry. */ - bytes = (bytes + lowtag_Mask) & ~lowtag_Mask; - - result = current_dynamic_space_free_pointer; - current_dynamic_space_free_pointer += (bytes / sizeof(lispobj)); - - return result; -} - -lispobj *alloc_unboxed(type, words) -int type, words; -{ - lispobj *result; - - result = alloc((1 + words) * sizeof(lispobj)); - - *result = (lispobj) (words << type_Bits) | type; - - return result; -} - -lispobj alloc_vector(type, length, size) -int type, length, size; -{ - struct vector *result; - - result = (struct vector *)alloc((2 + (length*size + 31) / 32) * sizeof(lispobj)); - - result->header = type; - result->length = fixnum(length); - - return ((lispobj)result)|type_OtherPointer; -} - -lispobj alloc_cons(car, cdr) -lispobj car, cdr; -{ - struct cons *ptr = (struct cons *)alloc(sizeof(struct cons)); - - ptr->car = car; - ptr->cdr = cdr; - - return (lispobj)ptr | type_ListPointer; -} - -lispobj alloc_number(n) -long n; -{ - struct bignum *ptr; - - if (-0x20000000 < n && n < 0x20000000) - return fixnum(n); - else { - ptr = (struct bignum *)alloc_unboxed(type_Bignum, 1); - - ptr->digits[0] = n; - - return (lispobj) ptr | type_OtherPointer; - } -} - -lispobj alloc_string(str) -char *str; -{ - int len = strlen(str); - lispobj result = alloc_vector(type_SimpleString, len+1, 8); - struct vector *vec = (struct vector *)PTR(result); - - vec->length = fixnum(len); - strcpy(vec->data, str); - - return result; -} - -lispobj alloc_sap(ptr) -char *ptr; -{ - struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 2); - - sap->pointer = ptr; - - return (lispobj) sap | type_OtherPointer; -} - diff --git a/ldb/alloc.h b/ldb/alloc.h deleted file mode 100644 index 4ca5f14466ee6c6bba2a15e5f2e97d9d6dfd92ea..0000000000000000000000000000000000000000 --- a/ldb/alloc.h +++ /dev/null @@ -1,3 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/alloc.h,v 1.1 1990/02/24 19:37:11 wlott Exp $ */ - -lispobj alloc_cons(), alloc_string(), alloc_number(); diff --git a/ldb/backtrace.c b/ldb/backtrace.c deleted file mode 100644 index c2f27da331a601bcc351b3dddce8d8fef30cfb42..0000000000000000000000000000000000000000 --- a/ldb/backtrace.c +++ /dev/null @@ -1,219 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/backtrace.c,v 1.5 1990/05/25 15:57:38 wlott Exp $ - * - * Simple backtrace facility. More or less from Rob's lisp version. - */ - -#include <stdio.h> -#include <signal.h> -#include "ldb.h" -#include "lisp.h" -#include "globals.h" -#include "interrupt.h" -#include "lispregs.h" - -/* Sigh ... I know what the call frame looks like and it had - better not change. */ - -struct call_frame { - struct call_frame *old_cont; - lispobj saved_lra; - lispobj other_state[6]; -}; - -struct call_info { - struct call_frame *frame; - int interrupted; - struct code *code; - lispobj lra; - int pc; /* Note: this is the trace file offset, not the actual pc. */ -}; - -#define HEADER_LENGTH(header) ((header)>>8) - -static struct code * -code_pointer(object) -lispobj object; -{ - lispobj *headerp, header; - int type, len; - - headerp = (lispobj *) PTR(object); - header = *headerp; - type = TypeOf(header); - - switch (type) { - case type_CodeHeader: - break; - case type_ReturnPcHeader: - case type_FunctionHeader: - case type_ClosureFunctionHeader: - len = HEADER_LENGTH(header); - if (len == 0) - headerp = NULL; - else - headerp -= len; - break; - default: - headerp = NULL; - } - - return (struct code *) headerp; -} - -static -cs_valid_pointer_p(pointer) -struct call_frame *pointer; -{ - return (((char *) control_stack <= (char *) pointer) && - ((char *) pointer < (char *) current_control_stack_pointer)); -} - -static void -info_from_lisp_state(info) -struct call_info *info; -{ - info->frame = (struct call_frame *)current_control_frame_pointer; - info->interrupted = 0; - info->code = NULL; - info->lra = 0; - info->pc = 0; - - previous_info(info); -} - -static void -info_from_sigcontext(info, csp) -struct call_info *info; -struct sigcontext *csp; -{ - unsigned long pc; - - info->interrupted = 1; - if (LowtagOf(csp->sc_regs[CODE]) == type_FunctionPointer) { - /* We tried to call a function, but crapped out before $CODE could be fixed up. Probably an undefined function. */ - info->frame = (struct call_frame *)csp->sc_regs[OLDCONT]; - info->lra = (lispobj)csp->sc_regs[LRA]; - info->code = code_pointer(info->lra); - pc = (unsigned long)PTR(info->lra); - } - else { - info->frame = (struct call_frame *)csp->sc_regs[CONT]; - info->code = code_pointer(csp->sc_regs[CODE]); - info->lra = 0; - pc = csp->sc_pc; - } - if (info->code != NULL) - info->pc = pc - (unsigned long) info->code - - (HEADER_LENGTH(info->code->header) * sizeof(lispobj)); - else - info->pc = 0; -} - -static int -previous_info(info) -struct call_info *info; -{ - struct call_frame *this_frame; - int free; - struct sigcontext *csp; - - if (!cs_valid_pointer_p(info->frame)) { - printf("Bogus callee value (0x%08x).\n", (unsigned long)info->frame); - return 0; - } - - this_frame = info->frame; - info->lra = this_frame->saved_lra; - info->frame = this_frame->old_cont; - info->interrupted = 0; - - if (info->frame == NULL || info->frame == this_frame) - return 0; - - info->code = code_pointer(info->lra); - - if (info->code == (struct code *)PTR(info->lra)) { - /* We were interrupted. Find the correct sigcontext. */ - free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2; - while (free-- > 0) { - csp = lisp_interrupt_contexts[free]; - if ((struct call_frame *)(csp->sc_regs[CONT]) == info->frame) - info_from_sigcontext(info, csp); - } - } - else if (info->code != NULL) - info->pc = (unsigned long)PTR(info->lra) - (unsigned long)info->code - - (HEADER_LENGTH(info->code->header) * sizeof(lispobj)); - else - info->pc = 0; - - - - return 1; -} - -void -backtrace(nframes) -int nframes; -{ - struct call_info info; - - info_from_lisp_state(&info); - - do { - printf("<Frame 0x%08x%s, ", (unsigned long) info.frame, - info.interrupted ? " [interrupted]" : ""); - - if (info.code != (struct code *) 0) { - lispobj function; - - printf("CODE: 0x%08x, ", (unsigned long) info.code | type_OtherPointer); - - function = info.code->entry_points; - while (function != NIL) { - struct function_header *header; - lispobj name; - - header = (struct function_header *) PTR(function); - name = header->name; - - if (LowtagOf(name) == type_OtherPointer) { - lispobj *object; - - object = (lispobj *) PTR(name); - - if (TypeOf(*object) == type_SymbolHeader) { - struct symbol *symbol; - - symbol = (struct symbol *) object; - object = (lispobj *) PTR(symbol->name); - } - if (TypeOf(*object) == type_SimpleString) { - struct vector *string; - - string = (struct vector *) object; - printf("%s, ", (char *) string->data); - } else - printf("(Not simple string???), "); - } else - printf("(Not other pointer???), "); - - - function = header->next; - } - } - else - printf("CODE: ???, "); - - if (info.lra != 0) - printf("LRA: 0x%08x, ", (unsigned long)info.lra); - else - printf("<no LRA>, "); - - if (info.pc) - printf("PC: 0x%x>\n", info.pc); - else - printf("PC: ???>\n"); - - } while (--nframes > 0 && previous_info(&info)); -} diff --git a/ldb/bitbash.c b/ldb/bitbash.c deleted file mode 100644 index 0e7314344896f4222fe0a748bbe99f5a7b36c1c8..0000000000000000000000000000000000000000 --- a/ldb/bitbash.c +++ /dev/null @@ -1,72 +0,0 @@ - -unsigned long bit_bash_low_masks[] = { - 0x00000000, - 0x00000001, - 0x00000003, - 0x00000007, - 0x0000000f, - 0x0000001f, - 0x0000003f, - 0x0000007f, - 0x000000ff, - 0x000001ff, - 0x000003ff, - 0x000007ff, - 0x00000fff, - 0x00001fff, - 0x00003fff, - 0x00007fff, - 0x0000ffff, - 0x0001ffff, - 0x0003ffff, - 0x0007ffff, - 0x000fffff, - 0x001fffff, - 0x003fffff, - 0x007fffff, - 0x00ffffff, - 0x01ffffff, - 0x03ffffff, - 0x07ffffff, - 0x0fffffff, - 0x1fffffff, - 0x3fffffff, - 0x7fffffff, - 0xffffffff -}; - -unsigned long bit_bash_high_masks[] = { - 0x00000000, - 0x80000000, - 0xc0000000, - 0xe0000000, - 0xf0000000, - 0xf8000000, - 0xfc000000, - 0xfe000000, - 0xff000000, - 0xff800000, - 0xffc00000, - 0xffe00000, - 0xfff00000, - 0xfff80000, - 0xfffc0000, - 0xfffe0000, - 0xffff0000, - 0xffff8000, - 0xffffc000, - 0xffffe000, - 0xfffff000, - 0xfffff800, - 0xfffffc00, - 0xfffffe00, - 0xffffff00, - 0xffffff80, - 0xffffffc0, - 0xffffffe0, - 0xfffffff0, - 0xfffffff8, - 0xfffffffc, - 0xfffffffe, - 0xffffffff, -}; diff --git a/ldb/coreparse.c b/ldb/coreparse.c deleted file mode 100644 index a2e2f80c3f36500557a49a4b2993b9769b315db6..0000000000000000000000000000000000000000 --- a/ldb/coreparse.c +++ /dev/null @@ -1,138 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/coreparse.c,v 1.4 1990/03/29 02:58:03 ch Exp $ */ -#include <stdio.h> -#include <mach.h> -#include <sys/types.h> -#include <sys/file.h> -#include "lisp.h" -#include "globals.h" - -extern int version; - -#define CORE_PAGESIZE (4*1024) -#define CORE_MAGIC (('C' << 24) | ('O' << 16) | ('R' << 8) | 'E') -#define CORE_END 3840 -#define CORE_NDIRECTORY 3861 -#define CORE_VALIDATE 3845 -#define CORE_VERSION 3860 - -#define DYNAMIC_SPACE_ID (1) -#define STATIC_SPACE_ID (2) -#define READ_ONLY_SPACE_ID (3) - -struct ndir_entry { - long identifier; - long nwords; - long data_page; - long address; - long page_count; -}; - -static void process_directory(fd, ptr, count) -int fd, count; -long *ptr; -{ - long id, offset, len; - lispobj *free_pointer; - vm_address_t addr; - struct ndir_entry *entry; - - entry = (struct ndir_entry *) ptr; - - while (count-- > 0) { - id = entry->identifier; - offset = CORE_PAGESIZE * (1 + entry->data_page); - addr = (vm_address_t) CORE_PAGESIZE * entry->address; - free_pointer = (lispobj *) addr + entry->nwords; - len = CORE_PAGESIZE * entry->page_count; - - if (len != 0) { - printf("Mapping %d bytes at 0x%x.\n", len, addr); - os_map(fd, offset, addr, len); - } - -#if 0 - printf("Space ID = %d, free pointer = 0x%08x.\n", id, free_pointer); -#endif - - switch (id) { - case DYNAMIC_SPACE_ID: - if (current_dynamic_space != (lispobj *) addr) - printf("Strange ... dynamic space lossage.\n"); - current_dynamic_space_free_pointer = free_pointer; - break; - case STATIC_SPACE_ID: - static_space = (lispobj *) addr; - break; - case READ_ONLY_SPACE_ID: - /* Don't care about read only space */ - break; - default: - printf("Strange space ID: %d; ignored.\n", id); - break; - } - entry++; - } -} - -void load_core_file(file) -char *file; -{ - int fd = open(file, O_RDONLY), count; - long header[CORE_PAGESIZE / sizeof(long)], val, len, *ptr; - - if (fd < 0) { - fprintf(stderr, "Could not open file \"%s\".\n", file); - perror("open"); - exit(1); - } - - count = read(fd, header, CORE_PAGESIZE); - if (count < 0) { - perror("read"); - exit(1); - } - if (count < CORE_PAGESIZE) { - fprintf(stderr, "Premature EOF.\n"); - exit(1); - } - - ptr = header; - val = *ptr++; - - if (val != CORE_MAGIC) { - fprintf(stderr, "Invalid magic number: 0x%x should have been 0x%x.\n", - val, CORE_MAGIC); - exit(1); - } - - while (val != CORE_END) { - val = *ptr++; - len = *ptr++; - - switch (val) { - case CORE_END: - break; - - case CORE_VERSION: - if (*ptr != version) { - fprintf(stderr, "WARNING: ldb version (%d) different from core version (%d).\nYou may lose big.\n", version, *ptr); - } - break; - - case CORE_VALIDATE: - fprintf(stderr, "Validation no longer supported; ignored.\n"); - break; - - case CORE_NDIRECTORY: - process_directory(fd, ptr, - (len-2) / (sizeof(struct ndir_entry) / sizeof(long))); - break; - - default: - printf("Unknown core file entry: %d; skipping.\n", val); - break; - } - - ptr += len - 2; - } -} diff --git a/ldb/dynbind.c b/ldb/dynbind.c deleted file mode 100644 index f753121fb27107b957bcabcc6b71fea7963a42c1..0000000000000000000000000000000000000000 --- a/ldb/dynbind.c +++ /dev/null @@ -1,60 +0,0 @@ -/* - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/dynbind.c,v 1.2 1990/03/29 21:13:23 ch Exp $ - * - * Support for dynamic binding from C. - */ - -#include "ldb.h" -#include "lisp.h" -#include "globals.h" - -bind_variable(symbol, value) -lispobj symbol, value; -{ - lispobj old_value; - struct binding *binding; - - old_value = SymbolValue(symbol); - binding = (struct binding *) current_binding_stack_pointer; - current_binding_stack_pointer += (sizeof(struct binding) / sizeof(lispobj)); - binding->value = old_value; - binding->symbol = symbol; - SetSymbolValue(symbol, value); -} - -unbind() -{ - struct binding *binding; - lispobj symbol; - - binding = ((struct binding *) current_binding_stack_pointer) - 1; - - symbol = binding->symbol; - - SetSymbolValue(symbol, binding->value); - - binding->symbol = 0; - - current_binding_stack_pointer -= (sizeof(struct binding) / sizeof(lispobj)); -} - -unbind_to_here(bsp) -lispobj *bsp; -{ - while (bsp > current_binding_stack_pointer) { - struct binding *binding; - lispobj symbol; - - binding = ((struct binding *) current_binding_stack_pointer) - 1; - - symbol = binding->symbol; - - if (symbol) { - SetSymbolValue(symbol, binding->value); - binding->symbol = 0; - } - - current_binding_stack_pointer -= - (sizeof(struct binding) / sizeof(lispobj)); - } -} diff --git a/ldb/egets.c b/ldb/egets.c deleted file mode 100644 index 18a08affc9ac7fdd2ba8d222e998fe7a722bbcb5..0000000000000000000000000000000000000000 --- a/ldb/egets.c +++ /dev/null @@ -1,628 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/egets.c,v 1.1 1990/02/24 19:37:15 wlott Exp $ */ -/******************************************************************** -* * -* * -* Copyright (C) 1987, Carnegie Mellon University * -* * -* * -********************************************************************/ - -/* egets.c -- replacement for C library's gets(3s) - * allows emacs style command editing if stdin is a tty - * Derek Beatty - * HISTORY - * 20 Nov 87 Beatty: added code for more-mode. - * More-mode is handled by this file so gets can reset - * its line count. - */ -#include <stdio.h> -#include <ctype.h> -#include <sgtty.h> -#include <signal.h> -#include <strings.h> -#include <setjmp.h> - -int getpid(); /* this should have been declared somewhere */ - -/*LINTLIBRARY*/ - -#define TRUE (1) -#define FALSE (0) - -typedef unsigned char uchar; - -#define HISTBUF (2000) -#define LINEBUF (132) - -#define CONTROL(x) ((x)&0x1F) -#define META(x) ((x)|0x80) -#define BELL CONTROL('g') -#define ESC (0x1B) -#define RUBOUT (0x7F) -#define ISCONTROL(x) ((x)<0x20 || (x)>0x7E) /* includes meta */ -#define NOTPREFIX(c) ((c)!=ESC) - -/** Global Variables for user settings */ -int ScrollPauseSwitch; -int ScreenLengthLimit; -int EditSwitch = TRUE; - -/** Shared by MORE and GETS **/ -static int CurrentLine = 1; -static int Initialized = FALSE;/* true iff initialize has been called */ - -/** VARIABLES FOR GETS **/ -static struct sgttyb OttyFlags, NttyFlags; -static struct ltchars OltChars, NltChars; - -#ifdef SIGTSTP -static int (*TstpHandler)(); -#endif SIGTSTP - -static int Active = TRUE; /* true iff egets is working */ -static uchar History[HISTBUF]; /* history buffer */ -static uchar - *FirstHistory, /* ptr to earliest line in history buffer */ - *YankedHistory; /* ptr to history last yanked */ -static uchar KillBuf[LINEBUF+1]; /* kill buffer */ -static uchar Line[LINEBUF+1]; /* line being entered, plus null */ -static uchar - *Cursor, /* ptr to character cursor is on */ - *Bol, /* ptr to first char of line */ - *Eol; /* ptr to null that terminates line */ - -static uchar tLine[LINEBUF+1]; /* line displayed on terminal */ -static uchar *tCursor, *tBol, *tEol; - -static uchar Meta = 0; /* meta bit; 0x80 if meta key was last */ -static int Bleep = FALSE; /* TRUE iff bell needed at next screen update */ - -static jmp_buf out_of_here; - -static void saveTtyModes(), restoreTtyModes(), initialize(), showLine(), - killToEol(), yankNext(), yankPrev(), yankKillBuf(), - transpose(), openSpace(), closeSpace(); - -/* saveTtyModes -- save tty state and put tty into cbreak mode */ -static void -saveTtyModes() -{ - (void) ioctl(fileno(stdin), TIOCGETP, (char*) &OttyFlags); - NttyFlags = OttyFlags; - NttyFlags.sg_flags |= CBREAK; - NttyFlags.sg_flags &= ~XTABS; - NttyFlags.sg_flags &= ~ECHO; - (void) ioctl(fileno(stdin), TIOCSETN, (char*) &NttyFlags); - (void) ioctl(fileno(stdin), TIOCGLTC, (char*) &OltChars); - NltChars = OltChars; - NltChars.t_dsuspc = NltChars.t_suspc; - (void) ioctl(fileno(stdin), TIOCSLTC, (char*) &NltChars); -} - -/* restoreTtyModes -- restore tty state */ -static void -restoreTtyModes() -{ - (void) ioctl(fileno(stdin), TIOCSLTC, (char*) &OltChars); - (void) ioctl(fileno(stdin), TIOCSETN, (char*) &OttyFlags); -} - -/* isaCRT -- return nonzero iff fd is a tty with CRT bits set */ -static int -isaCRT( fd) -int fd; -{ - int ltbits; - - (void) ioctl(fd, TIOCLGET, (char*) <bits); - return (ltbits & (LCRTERA | LCRTKIL)); -} - -/* tstp -- handler for SIGTSTP: restore tty and suspend */ -#ifdef SIGTSTP -int -tstp() -{ - if (TstpHandler == SIG_IGN) - return; - restoreTtyModes(); - if (TstpHandler == SIG_DFL) - (void) kill(getpid(), SIGSTOP); - else - (*TstpHandler) (); - saveTtyModes(); - tBol = tEol = tCursor = tLine; - tLine[0] = '\0'; - showLine(); -} -#endif - -/* initialize -- init data structures used by gets and more. called once. */ -static void -initialize() -{ - int i; - - /* initialization for gets */ - Initialized = TRUE; - YankedHistory = FirstHistory = History; - for (i = 0; i < HISTBUF; i++) - History[i] = '\0'; - KillBuf[0] = '\0'; - - /* initialization for more */ - ScrollPauseSwitch= isaCRT(fileno(stdin)) && isatty(fileno(stdout)); - - ScreenLengthLimit= -1; -#ifdef TIOCGWINSZ /* 4.3bsd window size */ - { - struct winsize wss; - ioctl(fileno(stdin), TIOCGWINSZ, (char*) &wss); - ScreenLengthLimit= wss.ws_row-1; - } -#endif -#ifdef TIOCGSIZE /* sun window size */ - { - struct ttysize tss; - ioctl(fileno(stdin), TIOCGSIZE, (char*) &tss); - ScreenLengthLimit= tss.ts_lines-1; - } -#endif - if (ScreenLengthLimit==-1) - ScreenLengthLimit = 24; -} - - -/* killToEol -- delete characters on and following cursor into kill buffer */ -static void -killToEol() -{ - int n = strlen( (char*) Cursor); - - (void) strcpy((char*) KillBuf, (char*) Cursor); - closeSpace(n); -} - -/* transpose -- transpose two characters preceding cursor */ -static void -transpose() -{ - if (Cursor <= Bol + 1) - Bleep = TRUE; - else { - uchar c = *(Cursor - 1); - *(Cursor - 1) = *(Cursor - 2); - *(Cursor - 2) = c; - } -} - -/* numInWord -- return number of chars through word before or after cursor */ -static int -numInWord( before) - int before; /* true iff want count in word before cursor */ -{ - uchar *tempCursor = Cursor; - int n; - - if (before) { - if (tempCursor > Bol) - tempCursor--; - else - Bleep = TRUE; - while (tempCursor > Bol && !isalnum(*tempCursor)) - tempCursor--; - while (tempCursor > Bol && isalnum(*tempCursor)) - tempCursor--; - n = Cursor - tempCursor; - if (n != 0 && !isalnum(*tempCursor)) - n--; - return (n); - } else { - if (tempCursor >= Eol) - Bleep = TRUE; - while (tempCursor < Eol && !isalnum(*tempCursor)) - tempCursor++; - while (tempCursor < Eol && isalnum(*tempCursor)) - tempCursor++; - return (tempCursor - Cursor); - } -} - -/* yankHistory -- yank line at YankedHistory into Line */ -static void -yankHistory() -{ - uchar *tempHistory; - - YankedHistory++; - if (YankedHistory >= History + HISTBUF) - YankedHistory = History; - tempHistory = YankedHistory; - Bol = Cursor = Line; - while (*tempHistory) { - *Cursor++ = *tempHistory++; - if (tempHistory >= History + HISTBUF) - tempHistory = History; - } - *Cursor = '\0'; - Eol = Cursor; -} - -/* yankNext -- yank the next line from the history buffer */ -static void -yankNext() -{ - while (*YankedHistory) { - YankedHistory++; - if (YankedHistory >= History + HISTBUF) - YankedHistory = History; - } - yankHistory(); -} - -/* yankPrev -- yank the previous line from the history buffer */ -static void -yankPrev() -{ - YankedHistory--; - if (YankedHistory < History) - YankedHistory = History + HISTBUF - 1; - YankedHistory--; - if (YankedHistory < History) - YankedHistory = History + HISTBUF - 1; - while (*YankedHistory) { - YankedHistory--; - if (YankedHistory < History) - YankedHistory = History + HISTBUF - 1; - } - yankHistory(); -} - -/* addHistory -- add the current line to the history buffer */ -static void -addHistory() -{ - uchar *tempCursor = Bol; - - while (*tempCursor) { - *FirstHistory++ = *tempCursor++; - if (FirstHistory >= History + HISTBUF) - FirstHistory = History; - } - *FirstHistory++ = '\0'; - if (FirstHistory >= History + HISTBUF) - FirstHistory = History; - YankedHistory = FirstHistory; -} - -/* yankKillBuf -- insert kill buffer in current line. Bleep if trouble */ -static void -yankKillBuf() -{ - uchar *sourceCursor = KillBuf; - uchar *destCursor = Cursor; - int n = strlen((char*) KillBuf); - - if (Eol + n > Line + LINEBUF) - Bleep = TRUE; - else { - openSpace(n); - while (*sourceCursor) - *destCursor++ = *sourceCursor++; - Cursor += n; - } -} - -/* redraw -- force showLine to redraw current line on screen */ -static void -redraw() -{ - tCursor = tBol = tEol = tLine; - tLine[0] = '\0'; - printf("\n"); - (void) fflush(stdout); -} - -/* showLine -- update screen and tLine to reflect Line */ -static void -showLine() -{ - uchar *Dif, *tDif; - - - /* find first place the lines differ */ - Dif = Bol; - tDif = tBol; - while (*Dif && *tDif && *Dif == *tDif) { - Dif++; - tDif++; - } - if (*Dif || *tDif) { - /* lines differ: move tCursor to the point of difference */ - while (tCursor > tDif) { - printf("\b"); - tCursor--; - } - while (tCursor < tDif) - printf("%c", *tCursor++); - /* write remainder of Line */ - while (*Dif) - printf("%c", *tCursor++ = *Dif++); - /* add blanks to bring tLine up to length of Line */ - while (tCursor < tEol) { - printf(" "); - *tCursor++ = '\0'; - } - /* adjust tEol */ - tEol = tBol + (Eol - Bol); - } - /* move tCursor to proper place */ - while (tCursor - tBol > Cursor - Bol) { - printf("\b"); - tCursor--; - } - while (tCursor - tBol < Cursor - Bol) - printf("%c", *tCursor++); - /* cleanup */ - if (Bleep) { - printf("%c", BELL); - Bleep = FALSE; - } - (void) fflush(stdout); -} - -/* openSpace -- open space for n characters at cursor. Beep if trouble. */ -static void -openSpace( n) - int n; -{ - uchar *sourceCursor, *destCursor; - - if (n == 0) - return; - destCursor = Eol + n; - if (destCursor > Line + LINEBUF + 1) - Bleep = TRUE; - else { - sourceCursor = Eol; - Eol = destCursor; - while (sourceCursor >= Cursor) - *destCursor-- = *sourceCursor--; - } -} - -/* closeSpace -- close space for n characters at cursor. Bleep if trouble. */ -static void -closeSpace( n) - int n; -{ - uchar *sourceCursor, *destCursor; - - if (n == 0) - return; - if (n > Eol - Cursor) { - Bleep = TRUE; - n = Eol - Cursor; - } - sourceCursor = Cursor + n; - destCursor = Cursor; - while (sourceCursor <= Eol) - *destCursor++ = *sourceCursor++; - Eol = destCursor - 1; -} - -/* ogets -- get a line without command line editing */ -static char * -ogets(s, n) -char *s; -int n; /* total length of string */ -{ - int c, i; - char *t; - - t = s; i = n; - - if (n <= 0) - return NULL; - - while ((--i > 0) && ((c = getchar()) != '\n') && (c != EOF)) - *t++ = c; - if ((n != 1) && (c == EOF) && (s == t)) - return NULL; - *t = '\0'; - - return(s); -} - -static sigint_handler() -{ - longjmp(out_of_here, 1); -} - - -/* egets -- get a line from stdin with command line editing */ -char * -egets() -{ - uchar c= '\0'; - int done, returnEOF; - long int buffered= 0L; - int n; - int arg = 0; - int gettingArg = FALSE, gettingDigitArg = FALSE; - int stillGettingArg = FALSE; - struct sigvec sv, old_int_sv; - - if (!EditSwitch - || !Active - || (!Initialized && (!isatty(fileno(stdin)) )) - || !isaCRT(fileno(stdin))) { - Active = FALSE; - return (ogets(Line, LINEBUF + 1)); - } - if (!Initialized) - initialize(); - fflush(stdout); - CurrentLine=1; /* Reset line count for more-mode. */ - Line[0] = '\0'; - tLine[0] = '\0'; - Cursor = Bol = Eol = Line; - tCursor = tBol = tEol = tLine; -#ifdef SIGTSTP - TstpHandler = signal(SIGTSTP, tstp); -#endif - saveTtyModes(); - if (setjmp(out_of_here)) - returnEOF = TRUE; - else { - sv.sv_handler = sigint_handler; - sv.sv_mask = 0; - sv.sv_flags = 0; - sigvec(SIGINT, &sv, &old_int_sv); - - returnEOF = done = FALSE; - while (!done) { - /* lint complains that c may be used before set */ - if (!gettingArg && arg > 0 && NOTPREFIX(c)) - arg--; - else { - if (read(fileno(stdin), (char*) &c, 1) == 0) - c = CONTROL('m'); - else { - c |= Meta; - Meta = 0; - } - } - if (ISCONTROL(c)) { - switch (c) { - case CONTROL('a'): - Cursor = Bol; - break; - case CONTROL('b'): - if (Cursor > Bol) - Cursor--; - else - Bleep = TRUE; - break; - case CONTROL('d'): - if (Cursor < Eol) - closeSpace(1); - else - Bleep = TRUE; - break; - case CONTROL('e'): - Cursor = Eol; - break; - case CONTROL('f'): - if (Cursor < Eol) - Cursor++; - else - Bleep = TRUE; - break; - case CONTROL('h'): - case RUBOUT: - if (Cursor > Bol) { - Cursor--; - closeSpace(1); - } else - Bleep = TRUE; - break; - case CONTROL('j'): - done = TRUE; - break; - case CONTROL('k'): - killToEol(); - break; - case CONTROL('m'): - done = TRUE; - break; - case CONTROL('n'): - yankNext(); - break; - case CONTROL('p'): - yankPrev(); - break; - case CONTROL('r'): - redraw(); - break; - case CONTROL('t'): - transpose(); - break; - case CONTROL('u'): - if (gettingArg) - arg *= 4; - else - arg = 4; - stillGettingArg = TRUE; - gettingDigitArg = FALSE; - break; - case CONTROL('y'): - yankKillBuf(); - break; - case ESC: - Meta = 0x80; - break; - case META('f'): - Cursor += numInWord(0); - break; - case META('b'): - Cursor -= numInWord(1); - break; - case META('d'): - closeSpace(numInWord(0)); - break; - case CONTROL('w'): - case META('h'): - n = numInWord(1); - Cursor -= n; - closeSpace(n); - break; - case META(CONTROL('d')): - if (Bol == Eol) - done = returnEOF = TRUE; - else - Bleep = TRUE; - break; - default: - Bleep = TRUE; - break; - } - } else if (!gettingArg || !isdigit(c)) { - if (Eol + 1 > Line + LINEBUF) - Bleep = TRUE; - else { - openSpace(1); - *Cursor++ = c; - } - } else { - /* getting argument digits */ - if (gettingDigitArg) - arg = 10 * arg + c - '0'; - else - arg = c - '0'; - stillGettingArg = TRUE; - gettingDigitArg = TRUE; - } - if (gettingArg && !stillGettingArg) - arg--; - gettingArg = stillGettingArg; - stillGettingArg = FALSE; - if (Bleep) - arg = 0; - (void) ioctl(fileno(stdin), FIONREAD, (char*) &buffered); - if ((buffered == 0L && arg == 0) || done) - showLine(); - } - addHistory(); - } - - if (!returnEOF) printf("\n"); - (void) fflush(stdout); - - restoreTtyModes(); -#ifdef SIGTSTP - (void) signal(SIGTSTP, TstpHandler); -#endif - sigvec(SIGINT, &old_int_sv, NULL); - return (returnEOF ? NULL : (char *) Line); -} diff --git a/ldb/gc.c b/ldb/gc.c deleted file mode 100644 index 338908c4611768809df1f1d03e6abedd16addc01..0000000000000000000000000000000000000000 --- a/ldb/gc.c +++ /dev/null @@ -1,1729 +0,0 @@ -/* - * Stop and Copy GC based on Cheney's algorithm. - * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/gc.c,v 1.7 1990/05/24 18:04:14 ch Exp $ - * - * Written by Christopher Hoover. - */ - -#include <stdio.h> -#include <sys/time.h> -#include <sys/resource.h> -#include <signal.h> -#include "lisp.h" -#include "ldb.h" -#include "gc.h" -#include "globals.h" -#include "interrupt.h" -#include "validate.h" -#include "lispregs.h" - -lispobj *from_space; -lispobj *from_space_free_pointer; - -lispobj *new_space; -lispobj *new_space_free_pointer; - -static int (*scavtab[256])(); -static lispobj (*transother[256])(); -static int (*sizetab[256])(); - -static struct weak_pointer *weak_pointers; - - -/* Predicates */ - -#if defined(DEBUG_SPACE_PREDICATES) - -from_space_p(object) -lispobj object; -{ - lispobj *ptr; - - gc_assert(Pointerp(object)); - - ptr = (lispobj *) PTR(object); - - return ((from_space <= ptr) && - (ptr < from_space_free_pointer)); -} - -new_space_p(object) -lispobj object; -{ - lispobj *ptr; - - gc_assert(Pointerp(object)); - - ptr = (lispobj *) PTR(object); - - return ((new_space <= ptr) && - (ptr < new_space_free_pointer)); -} - -#else - -#define from_space_p(ptr) \ - ((from_space <= ((lispobj *) ptr)) && \ - (((lispobj *) ptr) < from_space_free_pointer)) - -#define new_space_p(ptr) \ - ((new_space <= ((lispobj *) ptr)) && \ - (((lispobj *) ptr) < new_space_free_pointer)) - -#endif - - -/* GC Lossage */ - -void -gc_lose() -{ - exit(1); -} - - -/* Copying Objects */ - -static lispobj -copy_object(object, nwords) -lispobj object; -int nwords; -{ - int tag; - lispobj *new; - lispobj *source, *dest; - - gc_assert(Pointerp(object)); - gc_assert(from_space_p(object)); - gc_assert((nwords & 0x01) == 0); - - /* get tag of object */ - tag = LowtagOf(object); - - /* allocate space */ - new = new_space_free_pointer; - new_space_free_pointer += nwords; - - dest = new; - source = (lispobj *) PTR(object); - - /* copy the object */ - while (nwords > 0) { - *dest++ = *source++; - *dest++ = *source++; - nwords -= 2; - } - - /* return lisp pointer of new object */ - return ((lispobj) new) | tag; -} - - -/* Collect Garbage */ - -static double tv_diff(x, y) -struct timeval *x, *y; -{ - return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) - - ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6)); -} - -collect_garbage() -{ - struct timeval start_tv, stop_tv; - struct rusage start_rusage, stop_rusage; - double real_time, system_time, user_time; - lispobj *current_static_space_free_pointer; - long static_space_size; - long control_stack_size, binding_stack_size; - long size_retained, size_discarded; - int oldmask; - - getrusage(RUSAGE_SELF, &start_rusage); - gettimeofday(&start_tv, (struct timezone *) 0); - - printf("[Collecting garbage ... \n"); - - oldmask = sigblock(BLOCKABLE); - - current_static_space_free_pointer = - (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER); - - - /* Set up from space and new space pointers */ - - from_space = current_dynamic_space; - from_space_free_pointer = current_dynamic_space_free_pointer; - - if (current_dynamic_space == dynamic_0_space) - new_space = dynamic_1_space; - else if (current_dynamic_space == dynamic_1_space) - new_space = dynamic_0_space; - else { - fprintf(stderr, "GC lossage. Current dynamic space is bogus!\n"); - gc_lose(); - } - - os_validate(new_space, DYNAMIC_SPACE_SIZE); - new_space_free_pointer = new_space; - - - /* Initialize the weak pointer list. */ - weak_pointers = (struct weak_pointer *) NULL; - - - /* Scavenge the roots. */ - printf("Scavenging interrupt contexts ...\n"); - scavenge_interrupt_contexts(); - - printf("Scavenging interrupt handlers (%d bytes) ...\n", - sizeof(interrupt_handlers)); - scavenge((lispobj *) interrupt_handlers, - sizeof(interrupt_handlers) / sizeof(lispobj)); - - control_stack_size = current_control_stack_pointer - control_stack; - printf("Scavenging the control stack (%d bytes) ...\n", - control_stack_size * sizeof(lispobj)); - scavenge(control_stack, control_stack_size); - - binding_stack_size = current_binding_stack_pointer - binding_stack; - printf("Scavenging the binding stack (%d bytes) ...\n", - binding_stack_size * sizeof(lispobj)); - scavenge(binding_stack, binding_stack_size); - - static_space_size = current_static_space_free_pointer - static_space; - printf("Scavenging static space (%d bytes) ...\n", - static_space_size * sizeof(lispobj)); - scavenge(static_space, static_space_size); - - printf("Scavenging new space (%d bytes) ...\n", - (new_space_free_pointer - new_space) * sizeof(lispobj)); - scavenge_newspace(); - -#if defined(DEBUG_PRINT_GARBAGE) - print_garbage(from_space, from_space_free_pointer); -#endif - - printf("Scanning weak pointers ...\n"); - scan_weak_pointers(); - - /* Flip spaces */ - os_invalidate(current_dynamic_space, DYNAMIC_SPACE_SIZE); - current_dynamic_space = new_space; - current_dynamic_space_free_pointer = new_space_free_pointer; - - size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj); - size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj); - - /* Zero stack */ - printf("Zeroing empty part of control stack ...\n"); - os_zero(current_control_stack_pointer, - CONTROL_STACK_SIZE - control_stack_size * sizeof(lispobj)); - - (void) sigsetmask(oldmask); - - printf("done.]\n"); - - printf("Total of %d bytes out of %d bytes retained (%3.2f%%).\n", - size_retained, size_discarded, - (((float) size_retained) / ((float) size_discarded)) * 100.0); - - gettimeofday(&stop_tv, (struct timezone *) 0); - getrusage(RUSAGE_SELF, &stop_rusage); - - real_time = tv_diff(&stop_tv, &start_tv); - user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime); - system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime); - - printf("Statistics:\n"); - printf("%10.2f msec of real time\n", real_time * 1000.0); - printf("%10.2f msec of user time,\n", user_time * 1000.0); - printf("%10.2f msec of system time.\n", system_time * 1000.0); - - printf("%10.2f M bytes/sec collected.\n", - (((float) size_retained / (float) (1<<20)) / real_time)); -} - - -/* Scavenging */ - -static -scavenge(start, nwords) -lispobj *start; -long nwords; -{ - while (nwords > 0) { - lispobj object; - int type, words_scavenged; - - object = *start; - type = TypeOf(object); - -#if defined(DEBUG_SCAVENGE_VERBOSE) - printf("Scavenging object at 0x%08x, object = 0x%08x, type = %d\n", - (unsigned long) start, (unsigned long) object, type); -#endif - - words_scavenged = (scavtab[type])(start, object); - - start += words_scavenged; - nwords -= words_scavenged; - } - gc_assert(nwords == 0); -} - -static -scavenge_newspace() -{ - lispobj *here; - - here = new_space; - while (here < new_space_free_pointer) { - lispobj object; - int type, words_scavenged; - - object = *here; - type = TypeOf(object); - -#if defined(DEBUG_SCAVENGE_VERBOSE) - printf("Scavenging object at 0x%08x, object = 0x%08x, type = %d\n", - (unsigned long) here, (unsigned long) object, type); -#endif - - words_scavenged = (scavtab[type])(here, object); - - here += words_scavenged; - } - gc_assert(here == new_space_free_pointer); -} - - -/* Scavenging Interrupt Contexts */ - -scavenge_interrupt_contexts() -{ - int i, index; - struct sigcontext *context; - - index = FIXNUM_TO_INT(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)); -#if defined(DEBUG_PRINT_CONTEXT_INDEX) - printf("Number of active contexts: %d\n", index); -#endif - - for (i = 0; i < index; i++) { - context = lisp_interrupt_contexts[i]; - scavenge_interrupt_context(context); - } -} - -static int boxed_registers[] = { - A0, A1, A2, A3, A4, A5, CNAME, LEXENV, - ARGS, OLDCONT, LRA, L0, L1, L2, CODE -}; - -scavenge_interrupt_context(context) -struct sigcontext *context; -{ - int i; - unsigned long lip; - unsigned long lip_offset; - int lip_register_pair; - unsigned long pc_code_offset; - - /* Find the LIP's register pair and calculate it's offset */ - /* before we scavenge the context. */ - lip = context->sc_regs[LIP]; - lip_offset = 0xFFFFFFFF; - lip_register_pair = -1; - for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) { - unsigned long reg, offset; - int index; - - index = boxed_registers[i]; - reg = context->sc_regs[index]; - if (reg <= lip) { - offset = lip - reg; - if (offset < lip_offset) { - lip_offset = offset; - lip_register_pair = index; - } - } - } - -#if defined(DEBUG_LIP) - printf("LIP = %08x, Pair is R%d = %08x, Offset = %08x\n", - context->sc_regs[LIP], - lip_register_pair, - context->sc_regs[lip_register_pair], - lip_offset); -#endif - - /* Compute the PC's offset from the start of the CODE */ - /* register. */ - pc_code_offset = context->sc_pc - context->sc_regs[CODE]; - -#if defined(DEBUG_PC) - printf("PC = %08x, CODE = %08x, Offset = %08x\n", - context->sc_pc, context->sc_regs[CODE], pc_code_offset); -#endif - - /* Scanvenge all boxed registers in the context. */ - for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) { - int index; - unsigned long reg; - - index = boxed_registers[i]; - reg = context->sc_regs[index]; - scavenge((lispobj *) &(context->sc_regs[index]), 1); -#if defined(DEBUG_SCAVENGE_REGISTERS) - printf("Scavenged R%d: was 0x%08x now 0x%08x\n", - index, reg, context->sc_regs[index]); -#endif - } - - /* Fix the LIP */ - context->sc_regs[LIP] = - context->sc_regs[lip_register_pair] + lip_offset; - -#if defined(DEBUG_LIP) - printf("LIP = %08x, Pair is R%d = %08x, Offset = %08x\n", - context->sc_regs[LIP], - lip_register_pair, - context->sc_regs[lip_register_pair], - lip_offset); -#endif - - /* Fix the PC if it was in from space */ - if (from_space_p(context->sc_pc)) - context->sc_pc = context->sc_regs[CODE] + pc_code_offset; - -#if defined(DEBUG_PC) - printf("PC = %08x, CODE = %08x, Offset = %08x\n", - context->sc_pc, context->sc_regs[CODE], pc_code_offset); -#endif - -} - - -/* Debugging Code */ - -print_garbage(from_space, from_space_free_pointer) -lispobj *from_space, *from_space_free_pointer; -{ - lispobj *start; - int total_words_not_copied; - - printf("Scanning from space ...\n"); - - total_words_not_copied = 0; - start = from_space; - while (start < from_space_free_pointer) { - lispobj object; - int forwardp, type, nwords; - lispobj header; - - object = *start; - forwardp = Pointerp(object) && new_space_p(object); - - if (forwardp) { - int tag; - lispobj *pointer; - - tag = LowtagOf(object); - - switch (tag) { - case type_ListPointer: - nwords = 2; - break; - case type_StructurePointer: - printf("Don't know about structures yet!\n"); - nwords = 1; - break; - case type_FunctionPointer: - nwords = 1; - break; - case type_OtherPointer: - pointer = (lispobj *) PTR(object); - header = *pointer; - type = TypeOf(header); - nwords = (sizetab[type])(pointer); - } - } else { - type = TypeOf(object); - nwords = (sizetab[type])(start); - total_words_not_copied += nwords; - printf("%4d words not copied at 0x%08x; ", - nwords, (unsigned long) start); - printf("Header word is 0x%08x\n", (unsigned long) object); - } - start += nwords; - } - printf("%d total words not copied.\n", total_words_not_copied); -} - - -/* Code and Code-Related Objects */ - -static lispobj trans_function_header(); -static lispobj trans_closure_function_header(); -static lispobj trans_boxed(); - -static -scav_function_pointer(where, object) -lispobj *where, object; -{ - gc_assert(Pointerp(object)); - - if (from_space_p(object)) { - lispobj first, *first_pointer; - - /* object is a pointer into from space. check to see */ - /* if it has been forwarded */ - first_pointer = (lispobj *) PTR(object); - first = *first_pointer; - - if (!(Pointerp(first) && new_space_p(first))) { - int type; - lispobj copy; - - /* must transport object -- object may point */ - /* to either a function header, a closure */ - /* function header, or to a closure header. */ - - type = TypeOf(first); - switch (type) { - case type_FunctionHeader: - copy = trans_function_header(object); - break; - case type_ClosureFunctionHeader: - copy = trans_closure_function_header(object); - break; - case type_ClosureHeader: - copy = trans_boxed(object); - break; - default: - fprintf(stderr, "GC lossage. Bogus function pointer.\n"); - fprintf(stderr, "Pointer: 0x%08x, Header: 0x%08x\n", - (unsigned long) object, (unsigned long) first); - gc_lose(); - } - - first = *first_pointer = copy; - } - - gc_assert(Pointerp(first)); - gc_assert(!from_space_p(first)); - - *where = first; - } - return 1; -} - -static struct code * -trans_code(code) -struct code *code; -{ - struct code *new_code; - lispobj first, l_code, l_new_code; - int nheader_words, ncode_words, nwords; - unsigned long displacement; - lispobj fheaderl, *prev_pointer; - -#if defined(DEBUG_CODE_GC) - printf("\nTransporting code object located at 0x%08x.\n", - (unsigned long) code); -#endif - - /* if object has already been transported, just return pointer */ - first = code->header; - if (Pointerp(first) && new_space_p(first)) - return (struct code *) PTR(first); - - gc_assert(TypeOf(first) == type_CodeHeader); - - /* prepare to transport the code vector */ - l_code = (lispobj) code | type_OtherPointer; - - ncode_words = FIXNUM_TO_INT(code->code_size); - nheader_words = HeaderValue(code->header); - nwords = ncode_words + nheader_words; - nwords = CEILING(nwords, 2); - - l_new_code = copy_object(l_code, nwords); - new_code = (struct code *) PTR(l_new_code); - - displacement = l_new_code - l_code; - -#if defined(DEBUG_CODE_GC) - printf("Old code object at 0x%08x, new code object at 0x%08x.\n", - (unsigned long) code, (unsigned long) new_code); - printf("Code object is %d words long.\n", nwords); -#endif - - /* set forwarding pointer */ - code->header = l_new_code; - - /* set forwarding pointers for all the function headers in the */ - /* code object. also fix all self pointers */ - - fheaderl = code->entry_points; - prev_pointer = &new_code->entry_points; - - while (fheaderl != NIL) { - struct function_header *fheaderp, *nfheaderp; - lispobj nfheaderl, header; - - fheaderp = (struct function_header *) PTR(fheaderl); - header = fheaderp->header; - gc_assert(TypeOf(header) == type_FunctionHeader); - - /* calcuate the new function pointer and the new */ - /* function header */ - nfheaderl = fheaderl + displacement; - nfheaderp = (struct function_header *) PTR(nfheaderl); - - /* set forwarding pointer */ - fheaderp->header = nfheaderl; - - /* fix self pointer */ - nfheaderp->self = nfheaderl; - - *prev_pointer = nfheaderl; - - fheaderl = fheaderp->next; - prev_pointer = &nfheaderp->next; - } - - return new_code; -} - -static -scav_code_header(where, object) -lispobj *where, object; -{ - struct code *code; - int nheader_words, ncode_words, nwords; - lispobj fheaderl; - struct function_header *fheaderp; - - code = (struct code *) where; - ncode_words = FIXNUM_TO_INT(code->code_size); - nheader_words = HeaderValue(object); - nwords = ncode_words + nheader_words; - nwords = CEILING(nwords, 2); - -#if defined(DEBUG_CODE_GC) - printf("\nScavening code object at 0x%08x.\n", - (unsigned long) where); - printf("Code object is %d words long.\n", nwords); - printf("Scavenging boxed section of code data block (%d words).\n", - nheader_words - 1); -#endif - - /* Scavenge the boxed section of the code data block */ - scavenge(where + 1, nheader_words - 1); - - /* Scavenge the boxed section of each function object in the */ - /* code data block */ - fheaderl = code->entry_points; - while (fheaderl != NIL) { - lispobj header; - - fheaderp = (struct function_header *) PTR(fheaderl); - header = fheaderp->header; - gc_assert(TypeOf(header) == type_FunctionHeader); - -#if defined(DEBUG_CODE_GC) - printf("Scavenging boxed section of entry point located at 0x%08x.\n", - (unsigned long) PTR(fheaderl)); -#endif - scavenge(&fheaderp->name, 1); - scavenge(&fheaderp->arglist, 1); - scavenge(&fheaderp->type, 1); - - fheaderl = fheaderp->next; - } - - return nwords; -} - -static lispobj -trans_code_header(object) -lispobj object; -{ - struct code *ncode; - - ncode = trans_code((struct code *) PTR(object)); - return (lispobj) ncode | type_OtherPointer; -} - -static -size_code_header(where) -lispobj *where; -{ - struct code *code; - int nheader_words, ncode_words, nwords; - - code = (struct code *) where; - - ncode_words = FIXNUM_TO_INT(code->code_size); - nheader_words = HeaderValue(code->header); - nwords = ncode_words + nheader_words; - nwords = CEILING(nwords, 2); - - return nwords; -} - - -static -scav_return_pc_header(where, object) -lispobj *where, object; -{ - fprintf(stderr, "GC lossage. Should not be scavenging a "); - fprintf(stderr, "Return PC Header.\n"); - fprintf(stderr, "where = 0x%08x, object = 0x%08x", - (unsigned long) where, (unsigned long) object); - gc_lose(); -} - -static lispobj -trans_return_pc_header(object) -lispobj object; -{ - struct function_header *return_pc; - unsigned long offset; - struct code *code, *ncode; - - return_pc = (struct function_header *) PTR(object); - offset = HeaderValue(return_pc->header) * 4; - - /* Transport the whole code object */ - code = (struct code *) ((unsigned long) return_pc - offset); - ncode = trans_code(code); - - return ((lispobj) ncode + offset) | type_OtherPointer; -} - - -static -scav_function_header(where, object) -lispobj *where, object; -{ - fprintf(stderr, "GC lossage. Should not be scavenging a "); - fprintf(stderr, "Function Header.\n"); - fprintf(stderr, "where = 0x%08x, object = 0x%08x", - (unsigned long) where, (unsigned long) object); - gc_lose(); -} - -static lispobj -trans_function_header(object) -lispobj object; -{ - struct function_header *fheader; - unsigned long offset; - struct code *code, *ncode; - - fheader = (struct function_header *) PTR(object); - offset = HeaderValue(fheader->header) * 4; - - /* Transport the whole code object */ - code = (struct code *) ((unsigned long) fheader - offset); - ncode = trans_code(code); - - return ((lispobj) ncode + offset) | type_FunctionPointer; -} - - -static -scav_closure_function_header(where, object) -lispobj *where, object; -{ - fprintf(stderr, "GC lossage. Should not be scavenging a "); - fprintf(stderr, "Closure Function Header.\n"); - fprintf(stderr, "where = 0x%08x, object = 0x%08x", - (unsigned long) where, (unsigned long) object); - gc_lose(); -} - -static lispobj -trans_closure_function_header(object) -lispobj object; -{ - struct function_header *fheader; - unsigned long offset; - struct code *code, *ncode; - - fheader = (struct function_header *) PTR(object); - offset = HeaderValue(fheader->header) * 4; - - /* Transport the whole code object */ - code = (struct code *) ((unsigned long) fheader - offset); - ncode = trans_code(code); - - return ((lispobj) ncode + offset) | type_FunctionPointer; -} - - -/* Structures */ - -static -scav_structure_pointer(where, object) -lispobj *where, object; -{ - if (from_space_p(object)) { - /* ### I don't know how to transport these! */ - - fprintf(stderr, "GC lossage. Cannot scavenge structure pointer in from space!\n"); - gc_lose(); - } else - return 1; -} - - -/* Lists and Conses */ - -static lispobj trans_list(); - -static -scav_list_pointer(where, object) -lispobj *where, object; -{ - gc_assert(Pointerp(object)); - - if (from_space_p(object)) { - lispobj first, *first_pointer; - - /* object is a pointer into from space. check to see */ - /* if it has been forwarded */ - first_pointer = (lispobj *) PTR(object); - first = *first_pointer; - - if (!(Pointerp(first) && new_space_p(first))) - first = *first_pointer = trans_list(object); - - gc_assert(Pointerp(first)); - gc_assert(!from_space_p(first)); - - *where = first; - } - return 1; -} - -static lispobj -trans_list(object) -lispobj object; -{ - lispobj new_list_pointer; - struct cons *cons, *new_cons; - - cons = (struct cons *) PTR(object); - - /* ### Don't use copy_object here. */ - new_list_pointer = copy_object(object, 2); - new_cons = (struct cons *) PTR(new_list_pointer); - - /* Set forwarding pointer. */ - cons->car = new_list_pointer; - - /* Try to linearize the list in the cdr direction to help reduce */ - /* paging. */ - - while (1) { - lispobj cdr, new_cdr; - struct cons *cdr_cons, *new_cdr_cons; - - cdr = cons->cdr; - - if (!((LowtagOf(cdr) == type_ListPointer) && from_space_p(cdr))) - break; - - cdr_cons = (struct cons *) PTR(cdr); - - /* ### Don't use copy_object here */ - new_cdr = copy_object(cdr, 2); - new_cdr_cons = (struct cons *) PTR(new_cdr); - - /* Set forwarding pointer */ - cdr_cons->car = new_cdr; - - /* Update the cdr of the last cons copied into new */ - /* space to keep the newspace scavenge from having to */ - /* do it. */ - new_cons->cdr = new_cdr; - - cons = cdr_cons; - new_cons = new_cdr_cons; - } - - return new_list_pointer; -} - - -/* Scavenging and Transporting Other Pointers */ - -static -scav_other_pointer(where, object) -lispobj *where, object; -{ - gc_assert(Pointerp(object)); - - if (from_space_p(object)) { - lispobj first, *first_pointer; - - /* object is a pointer into from space. check to see */ - /* if it has been forwarded */ - first_pointer = (lispobj *) PTR(object); - first = *first_pointer; - - if (!(Pointerp(first) && new_space_p(first))) - first = *first_pointer = - (transother[TypeOf(first)])(object); - - gc_assert(Pointerp(first)); - gc_assert(!from_space_p(first)); - - *where = first; - } - return 1; -} - - -/* Immediate, Boxed, and Unboxed Objects */ - -static -size_pointer(where) -lispobj *where; -{ - return 1; -} - - -static -scav_immediate(where, object) -lispobj *where, object; -{ - return 1; -} - -static lispobj -trans_immediate(object) -lispobj object; -{ - fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n"); - gc_lose(); -} - -static -size_immediate(where) -lispobj *where; -{ - return 1; -} - - -static -scav_boxed(where, object) -lispobj *where, object; -{ - return 1; -} - -static lispobj -trans_boxed(object) -lispobj object; -{ - lispobj header; - unsigned long length; - - gc_assert(Pointerp(object)); - - header = *((lispobj *) PTR(object)); - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return copy_object(object, length); -} - -static -size_boxed(where) -lispobj *where; -{ - lispobj header; - unsigned long length; - - header = *where; - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return length; -} - - -static -scav_unboxed(where, object) -lispobj *where, object; -{ - unsigned long length; - - length = HeaderValue(object) + 1; - length = CEILING(length, 2); - - return length; -} - -static lispobj -trans_unboxed(object) -lispobj object; -{ - lispobj header; - unsigned long length; - - - gc_assert(Pointerp(object)); - - header = *((lispobj *) PTR(object)); - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return copy_object(object, length); -} - -static -size_unboxed(where) -lispobj *where; -{ - lispobj header; - unsigned long length; - - header = *where; - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return length; -} - - -/* Vector-Like Objects */ - -#define NWORDS(x,y) (CEILING((x),(y)) / (y)) - -static -scav_string(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - -static lispobj -trans_string(object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return copy_object(object, nwords); -} - -static -size_string(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - - -static lispobj -trans_vector(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - int subtype; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length + 2, 2); - - /* When transporting an EQ hashtable, GC must change subtype */ - /* so that the hash functions will know to rehash it. */ - - subtype = HeaderValue(vector->header); - if (subtype == subtype_VectorValidHashing) - vector->header = (subtype_VectorMustRehash<<8) | - type_SimpleVector; - - return copy_object(object, nwords); -} - -static -size_vector(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - - -static -scav_vector_bit(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_bit(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return copy_object(object, nwords); -} - -static -size_vector_bit(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return nwords; -} - - -static -scav_vector_unsigned_byte_2(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_2(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return copy_object(object, nwords); -} - -static -size_vector_unsigned_byte_2(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return nwords; -} - - -static -scav_vector_unsigned_byte_4(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_4(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return copy_object(object, nwords); -} - -static -size_vector_unsigned_byte_4(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return nwords; -} - - -static -scav_vector_unsigned_byte_8(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_8(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return copy_object(object, nwords); -} - -static -size_vector_unsigned_byte_8(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - - -static -scav_vector_unsigned_byte_16(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_16(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return copy_object(object, nwords); -} - -static -size_vector_unsigned_byte_16(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return nwords; -} - - -static -scav_vector_unsigned_byte_32(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_32(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length + 2, 2); - - return copy_object(object, nwords); -} - -static -size_vector_unsigned_byte_32(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - - -static -scav_vector_single_float(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_single_float(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length + 2, 2); - - return copy_object(object, nwords); -} - -static -size_vector_single_float(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - - -static -scav_vector_double_float(where, object) -lispobj *where, object; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_double_float(object) -lispobj object; -{ - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - vector = (struct vector *) PTR(object); - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return copy_object(object, nwords); -} - -static -size_vector_double_float(where) -lispobj *where; -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = FIXNUM_TO_INT(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} - - -/* Weak Pointers */ - -#define WEAK_POINTER_NWORDS \ - CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2) - -static -scav_weak_pointer(where, object) -lispobj *where, object; -{ - /* Do not let GC scavenge the value slot of the weak pointer */ - /* (that is why it is a weak pointer). Note: we could use */ - /* the scav_unboxed method here. */ - - return WEAK_POINTER_NWORDS; -} - -static lispobj -trans_weak_pointer(object) -lispobj object; -{ - int nwords; - lispobj copy; - struct weak_pointer *wp; - - gc_assert(Pointerp(object)); - -#if defined(DEBUG_WEAK) - printf("Transporting weak pointer from 0x%08x\n", object); -#endif - - /* Need to remember where all the weak pointers are that have */ - /* been transported so they can be fixed up in a post-GC pass. */ - - copy = copy_object(object, WEAK_POINTER_NWORDS); - wp = (struct weak_pointer *) PTR(copy); - - - /* Push the weak pointer onto the list of weak pointers. */ - wp->next = weak_pointers; - weak_pointers = wp; - - return copy; -} - -static -size_weak_pointer(where) -lispobj *where; -{ - return WEAK_POINTER_NWORDS; -} - -scan_weak_pointers() -{ - struct weak_pointer *wp; - - for (wp = weak_pointers; wp != (struct weak_pointer *) NULL; - wp = wp->next) { - lispobj value; - lispobj first, *first_pointer; - - value = wp->value; - -#if defined(DEBUG_WEAK) - printf("Weak pointer at 0x%08x\n", (unsigned long) wp); - printf("Value: 0x%08x\n", (unsigned long) value); -#endif - - /* ### May want to make it an error to make a weak */ - /* pointer to a non-pointer since it doesn't make any */ - /* sense to do it. But for now, if it happens, don't */ - /* lose big -- just go on. */ - if (!(Pointerp(value) && from_space_p(value))) - continue; - - /* Now, we need to check if the object has been */ - /* forwarded. If it has been, the weak pointer is */ - /* still good and needs to be updated. Otherwise, the */ - /* weak pointer needs to be nil'ed out. */ - first_pointer = (lispobj *) PTR(value); - first = *first_pointer; - -#if defined(DEBUG_WEAK) - printf("First: 0x%08x\n", (unsigned long) first); -#endif - - if (Pointerp(first) && new_space_p(first)) - wp->value = first; - else - wp->value = NIL; - } -} - - - -/* Initialization */ - -static -scav_lose(object) -lispobj object; -{ - fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x\n", - (unsigned long) object); - gc_lose(); -} - -static lispobj -trans_lose(object) -lispobj object; -{ - fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n", - (unsigned long) object); - gc_lose(); -} - -static -size_lose(where) -lispobj *where; -{ - fprintf(stderr, "Size lossage. No size function for object at 0x%08x\n", - (unsigned long) where); - fprintf(stderr, "First word of object: 0x%08x\n", - (unsigned long) *where); - return 1; -} - -gc_init() -{ - int i; - - /* Scavenge Table */ - for (i = 0; i < 256; i++) - scavtab[i] = scav_lose; - - for (i = 0; i < 32; i++) { - scavtab[type_EvenFixnum|(i<<3)] = scav_immediate; - scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer; - /* OtherImmediate0 */ - scavtab[type_ListPointer|(i<<3)] = scav_list_pointer; - scavtab[type_OddFixnum|(i<<3)] = scav_immediate; - scavtab[type_StructurePointer|(i<<3)] = scav_structure_pointer; - /* OtherImmediate1 */ - scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer; - } - - scavtab[type_Bignum] = scav_unboxed; - scavtab[type_Ratio] = scav_boxed; - scavtab[type_SingleFloat] = scav_unboxed; - scavtab[type_DoubleFloat] = scav_unboxed; - scavtab[type_Complex] = scav_boxed; - scavtab[type_SimpleArray] = scav_boxed; - scavtab[type_SimpleString] = scav_string; - scavtab[type_SimpleBitVector] = scav_vector_bit; - scavtab[type_SimpleVector] = scav_boxed; - scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2; - scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4; - scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8; - scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16; - scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32; - scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float; - scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float; - scavtab[type_ComplexString] = scav_boxed; - scavtab[type_ComplexBitVector] = scav_boxed; - scavtab[type_ComplexVector] = scav_boxed; - scavtab[type_ComplexArray] = scav_boxed; - scavtab[type_CodeHeader] = scav_code_header; - scavtab[type_FunctionHeader] = scav_function_header; - scavtab[type_ClosureFunctionHeader] = scav_closure_function_header; - scavtab[type_ReturnPcHeader] = scav_return_pc_header; - scavtab[type_ClosureHeader] = scav_boxed; - scavtab[type_ValueCellHeader] = scav_boxed; - scavtab[type_SymbolHeader] = scav_boxed; - scavtab[type_BaseCharacter] = scav_immediate; - scavtab[type_Sap] = scav_unboxed; - scavtab[type_UnboundMarker] = scav_immediate; - scavtab[type_WeakPointer] = scav_weak_pointer; - - - /* Transport Other Table */ - for (i = 0; i < 256; i++) - transother[i] = trans_lose; - - transother[type_Bignum] = trans_unboxed; - transother[type_Ratio] = trans_boxed; - transother[type_SingleFloat] = trans_unboxed; - transother[type_DoubleFloat] = trans_unboxed; - transother[type_Complex] = trans_boxed; - transother[type_SimpleArray] = trans_boxed; - transother[type_SimpleString] = trans_string; - transother[type_SimpleBitVector] = trans_vector_bit; - transother[type_SimpleVector] = trans_vector; - transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2; - transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4; - transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8; - transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16; - transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32; - transother[type_SimpleArraySingleFloat] = trans_vector_single_float; - transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float; - transother[type_ComplexString] = trans_boxed; - transother[type_ComplexBitVector] = trans_boxed; - transother[type_ComplexVector] = trans_boxed; - transother[type_ComplexArray] = trans_boxed; - transother[type_CodeHeader] = trans_code_header; - transother[type_FunctionHeader] = trans_function_header; - transother[type_ClosureFunctionHeader] = trans_closure_function_header; - transother[type_ReturnPcHeader] = trans_return_pc_header; - transother[type_ClosureHeader] = trans_boxed; - transother[type_ValueCellHeader] = trans_boxed; - transother[type_SymbolHeader] = trans_boxed; - transother[type_BaseCharacter] = trans_immediate; - transother[type_Sap] = trans_unboxed; - transother[type_UnboundMarker] = trans_immediate; - transother[type_WeakPointer] = trans_weak_pointer; - - /* Size table */ - - for (i = 0; i < 256; i++) - sizetab[i] = size_lose; - - for (i = 0; i < 32; i++) { - sizetab[type_EvenFixnum|(i<<3)] = size_immediate; - sizetab[type_FunctionPointer|(i<<3)] = size_pointer; - /* OtherImmediate0 */ - sizetab[type_ListPointer|(i<<3)] = size_pointer; - sizetab[type_OddFixnum|(i<<3)] = size_immediate; - sizetab[type_StructurePointer|(i<<3)] = size_pointer; - /* OtherImmediate1 */ - sizetab[type_OtherPointer|(i<<3)] = size_pointer; - } - - sizetab[type_Bignum] = size_unboxed; - sizetab[type_Ratio] = size_boxed; - sizetab[type_SingleFloat] = size_unboxed; - sizetab[type_DoubleFloat] = size_unboxed; - sizetab[type_Complex] = size_boxed; - sizetab[type_SimpleArray] = size_boxed; - sizetab[type_SimpleString] = size_string; - sizetab[type_SimpleBitVector] = size_vector_bit; - sizetab[type_SimpleVector] = size_vector; - sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2; - sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4; - sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8; - sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16; - sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32; - sizetab[type_SimpleArraySingleFloat] = size_vector_single_float; - sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float; - sizetab[type_ComplexString] = size_boxed; - sizetab[type_ComplexBitVector] = size_boxed; - sizetab[type_ComplexVector] = size_boxed; - sizetab[type_ComplexArray] = size_boxed; - sizetab[type_CodeHeader] = size_code_header; -#if 0 - /* Shouldn't see these so just lose if it happens */ - sizetab[type_FunctionHeader] = size_function_header; - sizetab[type_ClosureFunctionHeader] = size_closure_function_header; - sizetab[type_ReturnPcHeader] = size_return_pc_header; -#endif - sizetab[type_ClosureHeader] = size_boxed; - sizetab[type_ValueCellHeader] = size_boxed; - sizetab[type_SymbolHeader] = size_boxed; - sizetab[type_BaseCharacter] = size_immediate; - sizetab[type_Sap] = size_unboxed; - sizetab[type_UnboundMarker] = size_immediate; - sizetab[type_WeakPointer] = size_weak_pointer; -} diff --git a/ldb/gc.h b/ldb/gc.h deleted file mode 100644 index af01f05a1498b8e0899674029add9075a760375e..0000000000000000000000000000000000000000 --- a/ldb/gc.h +++ /dev/null @@ -1,26 +0,0 @@ -/* - * Header file for GC - * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/gc.h,v 1.3 1990/05/13 15:30:58 ch Exp $ - */ - -#if !defined(_INCLUDED_GC_H_) -#define _INCLUDED_GC_H_ - -#include "lisp.h" - -extern void gc_lose(); - -#define gc_assert(ex) { \ - if (!(ex)) { \ - fprintf(stderr, "GC invariant lost! File \"%s\", line %d\n", \ - __FILE__, __LINE__); \ - gc_lose(); \ - } \ -} - -#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1))) -#define FIXNUM_TO_INT(x) ((x)>>2) -#define INT_TO_FIXNUM(x) ((x)<<2) - -#endif diff --git a/ldb/globals.c b/ldb/globals.c deleted file mode 100644 index 9863b3393faf40d53e9ee4b709bf13b347a49a78..0000000000000000000000000000000000000000 --- a/ldb/globals.c +++ /dev/null @@ -1,43 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/globals.c,v 1.2 1990/05/24 17:46:05 wlott Exp $ */ - -/* Variables everybody needs to look at or frob on. */ - -#include "lisp.h" -#include "globals.h" - -int foreign_function_call_active; - -unsigned long saved_global_pointer; - -lispobj *current_control_stack_pointer; -lispobj *current_control_frame_pointer; -lispobj *current_binding_stack_pointer; -unsigned long current_flags_register; - -lispobj *read_only_space; -lispobj *static_space; -lispobj *dynamic_0_space; -lispobj *dynamic_1_space; -lispobj *control_stack; -lispobj *binding_stack; - -lispobj *current_dynamic_space; -lispobj *current_dynamic_space_free_pointer; - -globals_init() -{ - /* Space, stack, and free pointer vars are initialized by - validate() and coreparse(). */ - - /* Get the current value of GP. */ - saved_global_pointer = current_global_pointer(); - - /* Set foreign function call active. */ - foreign_function_call_active = 1; - - /* Initialize the current lisp state. */ - current_control_stack_pointer = control_stack; - current_control_frame_pointer = (lispobj *)0; - current_binding_stack_pointer = binding_stack; - current_flags_register = 1<<flag_Atomic; -} diff --git a/ldb/globals.h b/ldb/globals.h deleted file mode 100644 index 2f08a3681b659be5682ff39564fdf2d790f4c891..0000000000000000000000000000000000000000 --- a/ldb/globals.h +++ /dev/null @@ -1,43 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/globals.h,v 1.2 1990/05/24 17:46:07 wlott Exp $ */ - -#if !defined(_INCLUDE_GLOBALS_H_) -#define _INCLUDED_GLOBALS_H_ - -#include "lisp.h" - -#if !defined(LANGUAGE_ASSEMBLY) - -extern int foreign_function_call_active; - -extern unsigned long saved_global_pointer; - -extern lispobj *current_control_stack_pointer; -extern lispobj *current_control_frame_pointer; -extern lispobj *current_binding_stack_pointer; -extern unsigned long current_flags_register; - -extern lispobj *read_only_space; -extern lispobj *static_space; -extern lispobj *dynamic_0_space; -extern lispobj *dynamic_1_space; -extern lispobj *control_stack; -extern lispobj *binding_stack; - -extern lispobj *current_dynamic_space; -extern lispobj *current_dynamic_space_free_pointer; - -#else - -/* These are needed by ./assem.s */ - -.extern foreign_function_call_active 4 - -.extern current_dynamic_space_free_pointer 4 -.extern current_control_stack_pointer 4 -.extern current_control_frame_pointer 4 -.extern current_binding_stack_pointer 4 -.extern current_flags_register 4 - -#endif - -#endif diff --git a/ldb/interrupt.c b/ldb/interrupt.c deleted file mode 100644 index bbaf98c6e772dd99d30cd7dd0455acf1296c2325..0000000000000000000000000000000000000000 --- a/ldb/interrupt.c +++ /dev/null @@ -1,174 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/interrupt.c,v 1.5 1990/05/26 01:20:17 ch Exp $ */ - -/* Interrupt handing magic. */ - -#include <signal.h> -#include <mips/cpu.h> - -#include "lisp.h" -#include "ldb.h" -#include "globals.h" -#include "lispregs.h" -#include "interrupt.h" - -struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS]; - -union interrupt_handler interrupt_handlers[NSIG]; - -static int pending_signal, pending_code, pending_mask; - - -static handle_now(signal, code, context) -int signal, code; -struct sigcontext *context; -{ - int were_in_lisp; - union interrupt_handler handler; - lispobj *args; - lispobj callname, function; - - handler = interrupt_handlers[signal]; - were_in_lisp = !foreign_function_call_active; - - if (were_in_lisp) { - int context_index; - - /* Get current LISP state from context */ - current_dynamic_space_free_pointer = - (lispobj *) context->sc_regs[ALLOC]; - current_binding_stack_pointer = - (lispobj *) context->sc_regs[BSP]; - current_flags_register = context->sc_regs[FLAGS]|(1<<flag_Atomic); - - /* Build a fake stack frame */ - current_control_frame_pointer = - (lispobj *) context->sc_regs[CSP]; - current_control_stack_pointer = - current_control_frame_pointer + 8; - current_control_frame_pointer[0] = - context->sc_regs[CONT]; - current_control_frame_pointer[1] = - context->sc_regs[CODE]; - - /* Restore the GP */ - set_global_pointer(saved_global_pointer); - - /* Do dynamic binding of the active interrupt context index - and save the context in the context array. */ - context_index = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2; - - if (context_index >= MAX_INTERRUPTS) { - fprintf("Maximum number (%d) of interrupts exceeded. Exiting.\n", - MAX_INTERRUPTS); - exit(1); - } - - bind_variable(FREE_INTERRUPT_CONTEXT_INDEX, - fixnum(context_index + 1)); - - lisp_interrupt_contexts[context_index] = context; - - /* No longer in Lisp now. */ - foreign_function_call_active = 1; - } - - if (LowtagOf(handler.lisp) == type_EvenFixnum || - LowtagOf(handler.lisp) == type_OddFixnum) - (*handler.c)(signal, code, context); - else { - args = current_control_stack_pointer; - current_control_stack_pointer += 3; - args[0] = fixnum(signal); - args[1] = fixnum(code); - args[2] = alloc_sap(context); - callname = handler.lisp; - if (LowtagOf(callname) == type_FunctionPointer) - function = callname; - else - function = ((struct symbol *)PTR(callname))->function; - call_into_lisp(callname, function, args, 3); - } - - if (were_in_lisp) { - int context_index; - - /* Block all blockable signals */ - sigblock(BLOCKABLE); - - /* Going back into lisp. */ - foreign_function_call_active = 0; - - /* Undo dynamic binding. */ - /* ### Do I really need to unbind_to_here()? */ - unbind(); - - /* Put the dynamic space free pointer back into the context. */ - context->sc_regs[ALLOC] = - (unsigned long) current_dynamic_space_free_pointer; - - } -} - -static maybe_now_maybe_later(signal, code, context) -int signal, code; -struct sigcontext *context; -{ - if ((!foreign_function_call_active) && - (context->sc_regs[FLAGS] & (1<<flag_Atomic))) { - pending_signal = signal; - pending_code = code; - pending_mask = context->sc_mask; - context->sc_mask |= BLOCKABLE; - context->sc_regs[FLAGS] |= (1<<flag_Interrupted); - } else - handle_now(signal, code, context); -} - -static trap_handler(signal, code, context) -int signal, code; -struct sigcontext *context; -{ - if (code == trap_PendingInterrupt) { - signal = pending_signal; - code = pending_code; - context->sc_mask = pending_mask; - pending_signal = 0; - pending_code = 0; - pending_mask = 0; - } - handle_now(signal, code, context); -} - -void install_handler(signal, handler) -int signal; -union interrupt_handler handler; -{ - struct sigvec sv; - - if (sigmask(signal)&BLOCKABLE) - sv.sv_handler = maybe_now_maybe_later; - else if (signal == SIGTRAP) - sv.sv_handler = trap_handler; - else - sv.sv_handler = handle_now; - sv.sv_mask = BLOCKABLE; - sv.sv_flags = 0; - - interrupt_handlers[signal] = handler; - - sigvec(signal, &sv, NULL); -} - -void unistall_handler(signal) -int signal; -{ - -} - -interrupt_init() -{ - int i; - - for (i = 0; i < NSIG; i++) - interrupt_handlers[i].lisp = (lispobj) fixnum(0); -} diff --git a/ldb/interrupt.h b/ldb/interrupt.h deleted file mode 100644 index cd3546cc4e0e356ec7674d8b889231d5b2d959d9..0000000000000000000000000000000000000000 --- a/ldb/interrupt.h +++ /dev/null @@ -1,28 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/interrupt.h,v 1.1 1990/03/29 21:23:00 ch Exp $ */ - -#if !defined(_INCLUDE_INTERRUPT_H_) -#define _INCLUDE_INTERRUPT_H_ - -#include <signal.h> - -#define MAX_INTERRUPTS (4096) - -extern struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS]; - -union interrupt_handler { - lispobj lisp; - int (*c)(); -}; - -extern union interrupt_handler interrupt_handlers[NSIG]; - -#define BLOCKABLE (sigmask(SIGHUP) | sigmask(SIGINT) | \ - sigmask(SIGQUIT) | sigmask(SIGPIPE) | \ - sigmask(SIGALRM) | sigmask(SIGURG) | \ - sigmask(SIGTSTP) | sigmask(SIGCHLD) | \ - sigmask(SIGIO) | sigmask(SIGXCPU) | \ - sigmask(SIGXFSZ) | sigmask(SIGVTALRM) | \ - sigmask(SIGPROF) | sigmask(SIGWINCH) | \ - sigmask(SIGUSR1) | sigmask(SIGUSR2)) - -#endif diff --git a/ldb/ldb.c b/ldb/ldb.c deleted file mode 100644 index 062da325abd829adc0f95cff0f99e6dc2f089a47..0000000000000000000000000000000000000000 --- a/ldb/ldb.c +++ /dev/null @@ -1,90 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/ldb.c,v 1.5 1990/05/23 19:02:45 ch Exp $ */ -/* Lisp kernel core debugger */ - -#include <stdio.h> -#include <sys/types.h> -#include <sys/file.h> -#include <mach.h> - -#include "ldb.h" -#include "lisp.h" -#include "alloc.h" -#include "vars.h" - -lispobj lisp_nil_reg = NIL; -char *lisp_csp_reg, *lisp_bsp_reg; - -static lispobj alloc_str_list(list) -char *list[]; -{ - lispobj result, newcons; - struct cons *ptr; - - if (*list == NULL) - result = NIL; - else { - result = newcons = alloc_cons(alloc_string(*list++), NIL); - - while (*list != NULL) { - ptr = (struct cons *)PTR(newcons); - newcons = alloc_cons(alloc_string(*list++), NIL); - ptr->cdr = newcons; - } - } - - return result; -} - - -main(argc, argv, envp) -int argc; -char *argv[]; -char *envp[]; -{ - char *arg, **argptr; - char *core = NULL; - - define_var("nil", NIL, TRUE); - define_var("t", T, TRUE); - - argptr = argv; - while ((arg = *++argptr) != NULL) { - if (strcmp(arg, "-core") == 0) { - if (core != NULL) { - fprintf(stderr, "can only specify one core file.\n"); - exit(1); - } - core = *++argptr; - if (core == NULL) { - fprintf(stderr, "-core must be followed by the name of the core file to use.\n"); - exit(1); - } - } - } - - if (core == NULL) - core = "test.core"; - -#if defined(EXT_PAGER) - pager_init(); -#endif - - gc_init(); - - validate(); - - load_core_file(core); - - globals_init(); - - interrupt_init(); - - /* Convert the argv and envp to something Lisp can grok. */ - SetSymbolValue(LISP_COMMAND_LINE_LIST, alloc_str_list(argv)); - SetSymbolValue(LISP_ENVIRONMENT_LIST, alloc_str_list(envp)); - - test_init(); - - while (1) - monitor(); -} diff --git a/ldb/ldb.h b/ldb/ldb.h deleted file mode 100644 index a205b94f5765841950a98f5c05849a7b534ca70f..0000000000000000000000000000000000000000 --- a/ldb/ldb.h +++ /dev/null @@ -1,18 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/ldb.h,v 1.1 1990/02/24 19:37:19 wlott Exp $ */ -#ifndef _LDB_H_ -#define _LDB_H_ - -#ifndef NULL -#define NULL 0 -#endif - -#define boolean int -#define TRUE 1 -#define FALSE 0 - -#define SymbolValue(sym) (((struct symbol *)PTR(sym))->value) -#define SetSymbolValue(sym,val) (((struct symbol *)PTR(sym))->value = (val)) -#define SymbolFunction(sym) (((struct symbol *)PTR(sym))->function) -#define SetSymbolFunction(sym,val) (((struct symbol *)PTR(sym))->function = (val)) - -#endif _LDB_H_ diff --git a/ldb/lispregs.h b/ldb/lispregs.h deleted file mode 100644 index 35cc431efa01ab6866e38f1e2676e21811c98fd7..0000000000000000000000000000000000000000 --- a/ldb/lispregs.h +++ /dev/null @@ -1,42 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/lispregs.h,v 1.3 1990/05/12 16:41:33 ch Exp $ */ - -#ifdef LANGUAGE_ASSEMBLY -#define REG(num) $num -#else -#define REG(num) num - -extern char *lisp_register_names[]; -#endif - -#define NREGS (32) - -#define ZERO REG(0) -#define LIP REG(1) -#define NL0 REG(2) -#define NL1 REG(3) -#define NL2 REG(4) -#define NL3 REG(5) -#define NL4 REG(6) -#define NARGS REG(7) -#define A0 REG(8) -#define A1 REG(9) -#define A2 REG(10) -#define A3 REG(11) -#define A4 REG(12) -#define A5 REG(13) -#define CNAME REG(14) -#define LEXENV REG(15) -#define ARGS REG(16) -#define OLDCONT REG(17) -#define LRA REG(18) -#define L0 REG(19) -#define NULLREG REG(20) -#define BSP REG(21) -#define CONT REG(22) -#define CSP REG(23) -#define FLAGS REG(24) -#define ALLOC REG(25) -#define L1 REG(28) -#define NSP REG(29) -#define CODE REG(30) -#define L2 REG(31) diff --git a/ldb/mips-assem.s b/ldb/mips-assem.s deleted file mode 100644 index db4ac09bcd91959518cbbf777d1067a8fc80bb58..0000000000000000000000000000000000000000 --- a/ldb/mips-assem.s +++ /dev/null @@ -1,288 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/mips-assem.s,v 1.6 1990/05/26 01:21:53 ch Exp $ */ -#include <machine/regdef.h> - -#include "lisp.h" -#include "lispregs.h" -#include "globals.h" - -/* - * Function to save the global pointer. - */ - .text - .globl current_global_pointer - .ent current_global_pointer -current_global_pointer: - move v0, gp - j ra - .end current_global_pointer - -/* - * And a function to restore the global pointer. - */ - .text - .globl set_global_pointer - .ent set_global_pointer -set_global_pointer: - move gp, a0 - j ra - .end set_global_pointer - -#if !defined(s8) -#define s8 $30 -#endif - -/* - * Function to transfer control into lisp. - */ - .text - .globl call_into_lisp - .ent call_into_lisp -call_into_lisp: -#define framesize 11*4 - subu sp, framesize - .frame sp, framesize, ra - /* Save all the C regs. */ - .mask 0xd0ff0000, 0 - sw ra, framesize(sp) - sw s8, framesize-4(sp) - sw gp, framesize-8(sp) - sw s7, framesize-12(sp) - sw s6, framesize-16(sp) - sw s5, framesize-20(sp) - sw s4, framesize-24(sp) - sw s3, framesize-28(sp) - sw s2, framesize-32(sp) - sw s1, framesize-36(sp) - sw s0, framesize-40(sp) - - /* Clear descriptor regs */ - move t0, zero - move t1, zero - move t2, zero - move t3, zero - move t4, zero - move t5, zero - move t6, zero - move t7, zero - move s0, zero - move s1, zero - move s2, zero - move s3, zero - move gp, zero - move ra, zero - - .set noreorder - - /* The saved FLAGS has the pseudo-atomic bit set. */ - li NULLREG, NIL - lw FLAGS, current_flags_register - - /* No longer in foreign call. */ - sw zero, foreign_function_call_active - - /* Load the rest of the LISP state. */ - lw ALLOC, current_dynamic_space_free_pointer - lw BSP, current_binding_stack_pointer - lw CSP, current_control_stack_pointer - lw OLDCONT, current_control_frame_pointer - - /* Check for interrupt */ - and FLAGS, (0xffff^(1<<flag_Atomic)) - and v0, FLAGS, (1<<flag_Interrupted) - beq v0, zero, 1f - nop - - /* We were interrupted. Hit the trap. */ - break trap_PendingInterrupt -1: - - .set reorder - - /* Pass in args */ - move CNAME, $4 - move LEXENV, $5 - move CONT, $6 - sll NARGS, $7, 2 - lw A0, 0(CONT) - lw A1, 4(CONT) - lw A2, 8(CONT) - lw A3, 12(CONT) - lw A4, 16(CONT) - lw A5, 20(CONT) - - /* Calculate LRA */ - la LRA, lra + type_OtherPointer - - /* Indirect closure */ - lw CODE, 4-1(LEXENV) - - /* Jump into lisp land. */ - addu $2, CODE, 6*4 - type_FunctionPointer - j $2 - - .set noreorder - - .align 3 -lra: - .word type_ReturnPcHeader - - /* Multiple value return spot, clear stack */ - move CSP, OLDCONT - nop - - /* Pass one return value back to C land. */ - move v0, A0 - - /* Set pseudo-atomic flag. */ - or FLAGS, (1<<flag_Atomic) - - /* Save LISP registers. */ - sw ALLOC, current_dynamic_space_free_pointer - sw BSP, current_binding_stack_pointer - sw CSP, current_control_stack_pointer - sw CONT, current_control_frame_pointer - sw FLAGS, current_flags_register - - /* Back in foreign function call */ - li t0, 1 - sw t0, foreign_function_call_active - - /* Check for interrupt */ - and FLAGS, (0xffff^(1<<flag_Atomic)) - and v1, FLAGS, (1<<flag_Interrupted) - beq v1, zero, 1f - nop - - /* We were interrupted. Hit the trap. */ - break trap_PendingInterrupt -1: - - .set reorder - - /* Restore C regs */ - lw ra, framesize(sp) - lw s8, framesize-4(sp) - lw gp, framesize-8(sp) - lw s7, framesize-12(sp) - lw s6, framesize-16(sp) - lw s5, framesize-20(sp) - lw s4, framesize-24(sp) - lw s3, framesize-28(sp) - lw s2, framesize-32(sp) - lw s1, framesize-36(sp) - lw s0, framesize-40(sp) - - /* Restore C stack. */ - addu sp, framesize - - /* Back we go. */ - j ra - - .end call_into_lisp - -/* - * Transfering control from Lisp into C - */ - .text - .globl call_into_c - .ent call_into_c -call_into_c: - /* Set up a stack frame. */ - move OLDCONT, CONT - move CONT, CSP - addu CSP, CONT, 32 - sw OLDCONT, 0(CONT) - sw LRA, 4(CONT) - sw CODE, 8(CONT) - - /* Note: the C stack is already set up. */ - - /* Set the pseudo-atomic flag. */ - .set noreorder - or FLAGS, (1<<flag_Atomic) - - /* Save lisp state. */ - sw ALLOC, current_dynamic_space_free_pointer - sw BSP, current_binding_stack_pointer - sw CSP, current_control_stack_pointer - sw CONT, current_control_frame_pointer - sw FLAGS, current_flags_register - - /* Mark us as in C land. */ - li t0, 1 - sw t0, foreign_function_call_active - - /* Restore GP */ - lw gp, saved_global_pointer - - /* Were we interrupted? */ - and FLAGS, (0xffff^(1<<flag_Atomic)) - and v1, FLAGS, (1<<flag_Interrupted) - beq v1, zero, 1f - nop - - /* We were interrupted. Hit the trap. */ - break trap_PendingInterrupt -1: - - .set reorder - - /* Get first 4 args. */ - lw a0, 0(sp) - lw a1, 4(sp) - lw a2, 8(sp) - lw a3, 12(sp) - - /* Into C land we go. */ - jal v0 - - /* Clear unsaved descriptor regs */ - move t0, zero - move t1, zero - move t2, zero - move t3, zero - move t4, zero - move t5, zero - move t6, zero - move t7, zero - move gp, zero - move ra, zero - - .set noreorder - - /* Restore FLAGS (which set the pseudo-atomic flag) */ - lw FLAGS, current_flags_register - - /* Mark us at in Lisp land. */ - sw zero, foreign_function_call_active - - /* Restore other lisp state. */ - lw ALLOC, current_dynamic_space_free_pointer - lw BSP, current_binding_stack_pointer - - /* Check for interrupt */ - and FLAGS, (0xffff^(1<<flag_Atomic)) - and a0, FLAGS, (1<<flag_Interrupted) - beq a0, zero, 1f - nop - - /* We were interrupted. Hit the trap. */ - break trap_PendingInterrupt -1: - - .set reorder - - /* Restore LRA & CODE (they may have been GC'ed) */ - lw CODE, 8(CONT) - lw LRA, 4(CONT) - - /* Reset the lisp stack. */ - /* Note: OLDCONT and CONT are in saved regs. */ - move CSP, CONT - move CONT, OLDCONT - - /* Return to LISP. */ - addu a0, LRA, 4-type_OtherPointer - j a0 - - .end call_into_c diff --git a/ldb/monitor.c b/ldb/monitor.c deleted file mode 100644 index eba74d6d2f1924395cc89dc1d0a36466e5b410bc..0000000000000000000000000000000000000000 --- a/ldb/monitor.c +++ /dev/null @@ -1,520 +0,0 @@ -/* $Header */ - -#include <stdio.h> -#include <setjmp.h> -#include <sys/time.h> -#include <sys/resource.h> -#include <signal.h> -#include "ldb.h" -#include "lisp.h" -#include "globals.h" -#include "vars.h" -#include "parse.h" -#include "interrupt.h" -#include "lispregs.h" - -static void call_cmd(), dump_cmd(), print_cmd(), quit(), help(); -static void flush_cmd(), search_cmd(), regs_cmd(), exit_cmd(), throw_cmd(); -static void timed_call_cmd(), gc_cmd(), print_context_cmd(); -static void backtrace_cmd(); - -static struct cmd { - char *cmd, *help; - void (*fn)(); -} Cmds[] = { - {"help", "Display this info", help}, - {"?", NULL, help}, - {"backtrace", "backtrace up to N frames", backtrace_cmd}, - {"call", "call FUNCTION with ARG1, ARG2, ...", call_cmd}, - {"context", "print interrupt context number I.", print_context_cmd}, - {"dump", "dump memory starting at ADDRESS for COUNT words.", dump_cmd}, - {"d", NULL, dump_cmd}, - {"exit", "Exit this instance of the monitor.", exit_cmd}, - {"flush", "flush all temp variables.", flush_cmd}, - {"gc", "collect garbage (caveat collector).", gc_cmd}, - {"print", "print object at ADDRESS.", print_cmd}, - {"p", NULL, print_cmd}, - {"quit", "quit.", quit}, - {"regs", "display current lisp regs.", regs_cmd}, - {"search", "search for TYPE starting at ADDRESS for a max of COUNT words.", search_cmd}, - {"s", NULL, search_cmd}, - {"throw", "Throw to the top level monitor.", throw_cmd}, - {"time", "call FUNCTION with ARG1, ARG2, ... and time it.", timed_call_cmd}, - {NULL, NULL, NULL} -}; - - -static jmp_buf topbuf; -static jmp_buf curbuf; -static int level = 0; - - -static int visable(c) -unsigned char c; -{ - if (c < ' ' || c > '~') - return ' '; - else - return c; -} - -static void dump_cmd(ptr) -char **ptr; -{ - static char *lastaddr = 0; - static int lastcount = 20; - - char *addr = lastaddr; - int count = lastcount, displacement; - - if (more_p(ptr)) { - addr = parse_addr(ptr); - - if (more_p(ptr)) - count = parse_number(ptr); - } - - if (count == 0) { - printf("COUNT must be non-zero.\n"); - return; - } - - lastcount = count; - - if (count > 0) - displacement = 4; - else { - displacement = -4; - count = -count; - } - - while (count-- > 0) { - printf("0x%08x: ", addr); - if (valid_addr(addr)) { - unsigned long *lptr = (unsigned long *)addr; - unsigned short *sptr = (unsigned short *)addr; - unsigned char *cptr = (unsigned char *)addr; - - printf("0x%08x 0x%04x 0x%04x 0x%02x 0x%02x 0x%02x 0x%02x %c%c%c%c\n", lptr[0], sptr[0], sptr[1], cptr[0], cptr[1], cptr[2], cptr[3], visable(cptr[0]), visable(cptr[1]), visable(cptr[2]), visable(cptr[3])); - } - else - printf("invalid address\n"); - - addr += displacement; - } - - lastaddr = addr; -} - -static void print_cmd(ptr) -char **ptr; -{ - lispobj obj = parse_lispobj(ptr); - - print(obj); -} - -static void regs_cmd(ptr) -char **ptr; -{ - printf("DYNAMIC\t=\t0x%08x\n", current_dynamic_space); - printf("ALLOC\t=\t0x%08x\n", current_dynamic_space_free_pointer); - printf("CSP\t=\t0x%08x\n", current_control_stack_pointer); - printf("FP\t=\t0x%08x\n", current_control_frame_pointer); - printf("BSP\t=\t0x%08x\n", current_binding_stack_pointer); - printf("FLAGS\t=\t0x%08x\n", current_flags_register); -} - -static void search_cmd(ptr) -char **ptr; -{ - static int lastval = 0, lastcount = 0; - static lispobj *start = 0, *end = 0; - int val, count; - lispobj *addr, obj; - - if (more_p(ptr)) { - val = parse_number(ptr); - if (val < 0 || val > 0xff) { - printf("Can only search for single bytes.\n"); - return; - } - if (more_p(ptr)) { - addr = (lispobj *)PTR((long)parse_addr(ptr)); - if (more_p(ptr)) { - count = parse_number(ptr); - } - else { - /* Speced value and address, but no count. Only one. */ - count = -1; - } - } - else { - /* Speced a value, but no address, so search same range. */ - addr = start; - count = lastcount; - } - } - else { - /* Speced nothing, search again for val. */ - val = lastval; - addr = end; - count = lastcount; - } - - lastval = val; - start = end = addr; - lastcount = count; - - printf("searching for 0x%x at 0x%x\n", val, end); - - while (search_for_type(val, &end, &count)) { - printf("found 0x%x at 0x%x:\n", val, end); - obj = *end; - addr = end; - end += 2; - if (TypeOf(obj) == type_FunctionHeader) - print((long)addr | type_FunctionPointer); - else if (LowtagOf(obj) == type_OtherImmediate0 || LowtagOf(obj) == type_OtherImmediate1) - print((long)addr | type_OtherPointer); - else - print(addr); - if (count == -1) - return; - } -} - -static void call_cmd(ptr) -char **ptr; -{ - extern lispobj call_into_lisp(); - - int start_level = level; - - lispobj call_name = parse_lispobj(ptr); - lispobj function, result, arg, *args; - int numargs; - - if (LowtagOf(call_name) == type_OtherPointer) { - struct symbol *sym = (struct symbol *)PTR(call_name); - - if (TypeOf(sym->header) == type_SymbolHeader) { - function = sym->function; - if (LowtagOf(function) != type_FunctionPointer) { - printf("undefined function: ``%s''\n", (char *)PTR(sym->name) + 8); - return; - } - } - else { - printf("0x%x is not a function pointer.\n", call_name); - return; - } - } - else if (LowtagOf(call_name) != type_FunctionPointer) { - printf("0x%x is not a function pointer.\n", call_name); - return; - } - else - function = call_name; - - numargs = 0; - args = current_control_stack_pointer; - while (more_p(ptr)) { - current_control_stack_pointer++; - current_control_stack_pointer[-1] = parse_lispobj(ptr); - numargs++; - } - - result = call_into_lisp(call_name, function, args, numargs); - - print(result); - - if (start_level != level) { - printf("Back to level %d\n", start_level); - level = start_level; - } -} - -static double tv_diff(x, y) -struct timeval *x, *y; -{ - return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) - - ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6)); -} - -static void timed_call_cmd(ptr) -char **ptr; -{ - extern lispobj call_into_lisp(); - - lispobj args[16]; - int start_level = level; - - lispobj call_name = parse_lispobj(ptr); - lispobj function, result, arg, *argptr; - int numargs; - struct timeval start_tv, stop_tv; - struct rusage start_rusage, stop_rusage; - double real_time, system_time, user_time; - - if (LowtagOf(call_name) == type_OtherPointer) { - struct symbol *sym = (struct symbol *)PTR(call_name); - - if (TypeOf(sym->header) == type_SymbolHeader) { - function = sym->function; - if (LowtagOf(function) != type_FunctionPointer) { - printf("undefined function: ``%s''\n", (char *)PTR(sym->name) + 8); - return; - } - } - else { - printf("0x%x is not a function pointer.\n", call_name); - return; - } - } - else if (LowtagOf(call_name) != type_FunctionPointer) { - printf("0x%x is not a function pointer.\n", call_name); - return; - } - else - function = call_name; - - numargs = 0; - argptr = args; - while (more_p(ptr)) { - *argptr++ = parse_lispobj(ptr); - numargs++; - } - while (argptr < args + 6) - *argptr++ = NIL; - - getrusage(RUSAGE_SELF, &start_rusage); - gettimeofday(&start_tv, (struct timezone *) 0); - result = call_into_lisp(call_name, function, args, numargs); - gettimeofday(&stop_tv, (struct timezone *) 0); - getrusage(RUSAGE_SELF, &stop_rusage); - - print(result); - - real_time = tv_diff(&stop_tv, &start_tv) * 1000.0; - user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime) * - 1000.0; - system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime) * - 1000.0; - - printf("Call took:\n"); - printf("%20.8f msec of real time\n", real_time); - printf("%20.8f msec of user time,\n", user_time); - printf("%20.8f msec of system time.\n", system_time); - - if (start_level != level) { - printf("Back to level %d\n", start_level); - level = start_level; - } -} - -static void flush_cmd() -{ - flush_vars(); -} - -static void quit() -{ - char buf[10]; - - printf("Really quit? [n] "); - fflush(stdout); - fgets(buf, sizeof(buf), stdin); - if (buf[0] == 'y' || buf[0] == 'Y') - exit(0); -} - -static void help() -{ - struct cmd *cmd; - - for (cmd = Cmds; cmd->cmd != NULL; cmd++) - if (cmd->help != NULL) - printf("%s\t%s\n", cmd->cmd, cmd->help); -} - -static void throw_cmd() -{ - void throw_to_top(); - char buf[10]; - - printf("Really throw? [n] "); - fflush(stdout); - fgets(buf, sizeof(buf), stdin); - if (buf[0] == 'y' || buf[0] == 'Y') - throw_to_top(0); -} - -static int done; - -static void exit_cmd() -{ - done = TRUE; -} - -static void gc_cmd() -{ - collect_garbage(); -} - -static void print_context(context) -struct sigcontext *context; -{ - int i; - - for (i = 0; i < 32; i++) { - printf("%s:\t", lisp_register_names[i]); - brief_print((lispobj) context->sc_regs[i]); - } - printf("PC:\t\t 0x%08x\n", context->sc_pc); -} - -static void print_context_cmd(ptr) -char **ptr; -{ - int free; - - free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2; - - if (more_p(ptr)) { - int index; - - index = parse_number(ptr); - - if ((index >= 0) && (index < free)) { - printf("There are %d interrupt contexts.\n", free); - printf("Printing context %d\n", index); - print_context(lisp_interrupt_contexts[index]); - } else { - printf("There aren't that many/few contexts.\n"); - printf("There are %d interrupt contexts.\n", free); - } - } else { - if (free == 0) - printf("There are no interrupt contexts!\n"); - else { - printf("There are %d interrupt contexts.\n", free); - printf("Printing context %d\n", free - 1); - print_context(lisp_interrupt_contexts[free - 1]); - } - } -} - -static void backtrace_cmd(ptr) -char **ptr; -{ - void backtrace(); - int n; - - if (more_p(ptr)) - n = parse_number(ptr); - else - n = 100; - - printf("Backtrace:\n"); - backtrace(n); -} - -static void sub_monitor(csp, fp, bsp) -lispobj *csp, *fp, *bsp; -{ - extern char *egets(); - struct cmd *cmd, *found; - char *line, *ptr, *token; - int ambig; - lispobj *new; - - while (!done) { - if ((new = current_control_stack_pointer) != csp) { - printf("CSP changed from 0x%x to 0x%x; Restoring.\n", csp, new); - current_control_stack_pointer = csp; - } - if ((new = current_control_frame_pointer) != fp) { - printf("FP changed from 0x%x to 0x%x; Restoring.\n", fp, new); - current_control_frame_pointer = csp; - } - if ((new = current_binding_stack_pointer) != bsp) { - printf("BSP changed from 0x%x to 0x%x; Restoring.\n", bsp, new); - current_binding_stack_pointer = bsp; - } - - printf("ldb> "); - fflush(stdout); - line = egets(); - if (line == NULL) { - putchar('\n'); - continue; - } - ptr = line; - if ((token = parse_token(&ptr)) == NULL) - continue; - ambig = 0; - found = NULL; - for (cmd = Cmds; cmd->cmd != NULL; cmd++) { - if (strcmp(token, cmd->cmd) == 0) { - found = cmd; - ambig = 0; - break; - } - else if (strncmp(token, cmd->cmd, strlen(token)) == 0) { - if (found) - ambig = 1; - else - found = cmd; - } - } - if (ambig) - printf("``%s'' is ambiguous.\n", token); - else if (found == NULL) - printf("unknown command: ``%s''\n", token); - else { - reset_printer(); - (*found->fn)(&ptr); - } - } -} - -void monitor() -{ - jmp_buf oldbuf; - lispobj *csp, *fp, *bsp; - - csp = current_control_stack_pointer; - fp = current_control_frame_pointer; - bsp = current_binding_stack_pointer; - - bcopy(curbuf, oldbuf, sizeof(oldbuf)); - - if (level == 0) { - setjmp(topbuf); - level = 0; - } - - level++; - printf("LDB monitor (level=%d)\n", level); - - setjmp(curbuf); - - sub_monitor(csp, fp, bsp); - - done = FALSE; - - bcopy(oldbuf, curbuf, sizeof(curbuf)); - - level--; -} - -void throw_to_monitor() -{ - longjmp(curbuf, 1); -} - -void throw_to_top() -{ - longjmp(topbuf, 1); -} diff --git a/ldb/pager.c b/ldb/pager.c deleted file mode 100644 index 14089d5fd75ad461d88471ce3a16cc51f93523fd..0000000000000000000000000000000000000000 --- a/ldb/pager.c +++ /dev/null @@ -1,548 +0,0 @@ -/* - * Mach Memory Manager for GC Support - * - * Written by Christopher Hoover - */ - -#include <stdio.h> -#include <mach.h> -#include <mach/message.h> -#include <mach/mig_errors.h> -#include <cthreads.h> -#include "pager.h" - -static port_t pager_port; -static port_set_name_t pager_port_set; - - -/* Pager Object Registry */ - -static pager_object_t *pager_objects = NULL_PAGER_OBJECT; -static mutex_t pager_objects_mutex; - -static pager_object_t * -allocate_pager_object() -{ - pager_object_t *object; - - object = (pager_object_t *) malloc(sizeof(pager_object_t)); - - if (object == NULL_PAGER_OBJECT) - return NULL_PAGER_OBJECT; - - mutex_lock(pager_objects_mutex); - - object->next = pager_objects; - object->prev = NULL_PAGER_OBJECT; - - if (pager_objects != NULL_PAGER_OBJECT) - pager_objects->prev = object; - - pager_objects = object; - - mutex_unlock(pager_objects_mutex); - - return object; -} - -static void -deallocate_pager_object(object) -pager_object_t *object; -{ - mutex_lock(pager_objects_mutex); - - if (object->prev == NULL_PAGER_OBJECT) { - /* Deleting item at head of list */ - pager_objects = object->next; - if (pager_objects != NULL_PAGER_OBJECT) - pager_objects->prev = NULL_PAGER_OBJECT; - } else { - pager_object_t *prev; - pager_object_t *next; - - prev = object->prev; - next = object->next; - - prev->next = next; - if (next != NULL_PAGER_OBJECT) - next->prev = prev; - } - - mutex_unlock(pager_objects_mutex); - - (void) free((char *) object); -} - -static pager_object_t * -find_pager_object(memory_object) -memory_object_t memory_object; -{ - pager_object_t *p; - - mutex_lock(pager_objects_mutex); - - for (p = pager_objects; p != NULL_PAGER_OBJECT; p = p->next) - if (p->object == memory_object) - break; - - mutex_unlock(pager_objects_mutex); - - return p; -} - - -/* Memory Object Allocation */ - -static kern_return_t -pager_allocate_memory_object(memory_object, address, size) -memory_object_t *memory_object; -vm_address_t address; -vm_size_t size; -{ - kern_return_t kr; - pager_object_t *p; - port_t port; - memory_object_t object; - - pagerlog("pager_allocate_memory_object(memory_object, size = 0x%08x)\n", - size); - - if (size != round_page(size)) { - kr = KERN_INVALID_ARGUMENT; - goto e0; - } - - - p = allocate_pager_object(); - if (p == NULL_PAGER_OBJECT) { - kr = KERN_RESOURCE_SHORTAGE; - goto e0; - } - - kr = port_allocate(task_self(), &port); - if (kr != KERN_SUCCESS) - goto e1; - - object = (memory_object_t) port; - - kr = port_set_add(task_self(), pager_port_set, port); - if (kr != KERN_SUCCESS) - goto e2; - - p->object = object; - p->control = (memory_object_control_t) PORT_NULL; - p->name = (memory_object_name_t) PORT_NULL; - p->size = size; - p->backing_store = address; - - *memory_object = object; - - pagerlog("Allocated memory object %d. Backing store: addr = 0x%08x, length = 0x%08x\n", - port, address, size); - - return KERN_SUCCESS; - - e2: - (void) port_deallocate(port); - e1: - deallocate_pager_object(p); - e0: - return kr; -} - -static kern_return_t -pager_deallocate_memory_object(memory_object) -memory_object_t memory_object; -{ - pager_object_t *object; - kern_return_t kr0, kr1, kr2, kr3; - - pagerlog("pager_deallocate_memory_object(memory_object = %d)\n", - memory_object); - - /* Find the pager object associated with this memory object. */ - object = find_pager_object(memory_object); - if (object == NULL_PAGER_OBJECT) - return KERN_INVALID_ARGUMENT; - - /* Roll through these ignoring errors until later. */ - kr0 = port_deallocate(task_self(), (port_t) object->object); - kr1 = port_deallocate(task_self(), (port_t) object->control); - kr2 = port_deallocate(task_self(), (port_t) object->name); - kr3 = vm_deallocate(task_self(), object->backing_store, - object->size); - - deallocate_pager_object(object); - - if (kr0 != KERN_SUCCESS) - return kr0; - else if (kr1 != KERN_SUCCESS) - return kr1; - else if (kr2 != KERN_SUCCESS) - return kr2; - else if (kr3 != KERN_SUCCESS) - return kr3; - else - return KERN_SUCCESS; - -} - - -/* Calls from the kernel */ - -kern_return_t -memory_object_init(memory_object, memory_control, memory_object_name, - memory_object_page_size) -memory_object_t memory_object; -memory_object_control_t memory_control; -memory_object_name_t memory_object_name; -vm_size_t memory_object_page_size; -{ - kern_return_t; - pager_object_t *object; - - pagerlog("memory_object_init(memory_object = %d, memory_control = %d, memory_object_name = %d, memory_object_pager_size = 0x%0x)\n", - memory_object, memory_control, memory_object_name, - memory_object_page_size); - - /* Find the pager object associated with this memory object. */ - object = find_pager_object(memory_object); - if (object == NULL_PAGER_OBJECT) { - pagerlog("No pager object for memory object!\n"); - return KERN_FAILURE; - } - - /* Record the interesting information. */ - object->control = memory_control; - object->name = memory_object_name; - - /* Handshake with kernel. */ - - /* ### May want to turn caching on ... probably won't be */ - /* useful though. */ - SYSCALL_OR_LOSE(memory_object_set_attributes(memory_control, - TRUE, FALSE, - MEMORY_OBJECT_COPY_DELAY)); - - return KERN_SUCCESS; -} - -kern_return_t -memory_object_terminate(memory_object, memory_control, memory_object_name) -memory_object_t memory_object; -memory_object_control_t memory_control; -memory_object_name_t memory_object_name; -{ - pager_object_t *object; - - pagerlog("memory_object_terminate(memory_object = %d, memory_control = %d, memory_object_name = %d)\n", - memory_object, memory_control, memory_object_name); - - /* Find the pager object associated with this memory object. */ - object = find_pager_object(memory_object); - if (object == NULL_PAGER_OBJECT) { - pagerlog("No pager object for memory object!\n"); - return KERN_FAILURE; - } - - SYSCALL_OR_LOSE(pager_deallocate_memory_object(memory_object)); - - return KERN_SUCCESS; -} - -kern_return_t -memory_object_data_request(memory_object, memory_control, offset, length, - desired_access) -memory_object_t memory_object; -memory_object_control_t memory_control; -vm_offset_t offset; -vm_size_t length; -vm_prot_t desired_access; -{ - pager_object_t *object; - - pagerlog("memory_object_data_request(memory_object = %d, memory_control = %d, offset = 0x%08x, length = 0x%08x, desired access = 0x%0x)\n", - memory_object, memory_control, offset, length, desired_access); - - /* Find the pager object associated with this memory object. */ - object = find_pager_object(memory_object); - if (object == NULL_PAGER_OBJECT) { - pagerlog("No pager object for memory object!\n"); - return KERN_FAILURE; - } - - if ((offset + length) <= object->size) { - /* ### The lock value is something we want to play with. */ - SYSCALL_OR_LOSE(memory_object_data_provided(memory_control, - offset, - (object->backing_store + - offset), - length, VM_PROT_NONE)); - } else { - /* Out of bounds. */ - pagerlog("Out of bounds memory request\n"); - SYSCALL_OR_LOSE(memory_object_data_error(memory_control, - offset, length, - KERN_INVALID_ADDRESS)); - } - return KERN_SUCCESS; -} - -kern_return_t -memory_object_data_write(memory_object, memory_control, offset, data, dataCnt) -memory_object_t memory_object; -memory_object_control_t memory_control; -vm_offset_t offset; -pointer_t data; -unsigned int dataCnt; -{ - pager_object_t *object; - - pagerlog("memory_object_data_write(memory_object = %d, memory_control = %d, offset = 0x%08x, data = 0x%08x, dataCnt = 0x%08x)\n", - memory_object, memory_control, offset, data, dataCnt); - - /* ### Stick recording mechanism in this routine. */ - - /* Find the pager object associated with this memory object. */ - object = find_pager_object(memory_object); - if (object == NULL_PAGER_OBJECT) { - pagerlog("No pager object for memory object!\n"); - return KERN_FAILURE; - } - - SYSCALL_OR_LOSE(vm_copy(task_self(), data, dataCnt, - object->backing_store + offset)); - SYSCALL_OR_LOSE(vm_deallocate(task_self(), data, dataCnt)); - - return KERN_SUCCESS; -} - -kern_return_t -memory_object_copy(old_memory_object, old_memory_control, offset, length, - new_memory_object) -memory_object_t old_memory_object; -memory_object_control_t old_memory_control; -vm_offset_t offset; -vm_size_t length; -memory_object_t new_memory_object; -{ - pagerlog("memory_object_copy(old_memory_object = %d, old_memory_control = %d, offset = 0x%08x, length = 0x%08x, new_memory_object = %d)\n", - old_memory_object, old_memory_control, offset, length, - new_memory_object); - - pagerlog("Received memory_object_copy() RPC???\n"); - - return KERN_SUCCESS; -} - -kern_return_t -memory_object_data_unlock(memory_object, memory_control, offset, length, - desired_access) -memory_object_t memory_object; -memory_object_control_t memory_control; -vm_offset_t offset; -vm_size_t length; -vm_prot_t desired_access; -{ - pagerlog("memory_object_data_unlock(memory_object = %d, memory_control = %d, offset = 0x%08x, length = 0x%08x, desired access = 0x%0x)\n", - memory_object, memory_control, offset, length, desired_access); - - return KERN_SUCCESS; -} - -kern_return_t memory_object_lock_completed(memory_object, memory_control, - offset, length) -memory_object_t memory_object; -memory_object_control_t memory_control; -vm_offset_t offset; -vm_size_t length; -{ - pagerlog("memory_object_lock_completed(memory_object = %d, memory_control = %d, offset = 0x%08x, length = 0x%08x)\n", - memory_object, memory_control, offset, length); - - return KERN_SUCCESS; -} - - -/* Server Loop */ - -typedef struct { - msg_header_t head; - msg_type_t return_code_type; - kern_return_t return_code; -} reply_t; - -static -pager_serve_requests() -{ - struct { - msg_header_t header; - char data[MSG_SIZE_MAX - sizeof(msg_header_t)]; - } in_msg, out_msg; - - while (1) { - kern_return_t kr; - boolean_t won; - - in_msg.header.msg_local_port = pager_port_set; - in_msg.header.msg_size = sizeof(in_msg); - - kr = msg_receive(&in_msg.header, MSG_OPTION_NONE, 0); - if (kr != RCV_SUCCESS) { - pagerlog("msg_receive() lost. kr = %d.\n", kr); - continue; - } - -#if DEBUG_MESSAGE - pagerlog("Message received on port %d\n", - in_msg.header.msg_local_port); -#endif - - won = memory_object_server(&in_msg.header, &out_msg.header); - if (!won) { - pagerlog("memory_objectserver() lost.\n"); - continue; - } - if ((((reply_t *) &out_msg)->return_code != MIG_NO_REPLY) && - ((out_msg.header.msg_remote_port != PORT_NULL))) { - kr = msg_send(&out_msg.header, MSG_OPTION_NONE, 0); - pagerlog("msg_send() lost. kr = %d.\n", kr); - } - } -} - - -/* Mach Routine Emulation */ - -kern_return_t -pager_vm_allocate(task, address, size, anywhere) -task_t task; -vm_address_t *address; -vm_size_t size; -boolean_t anywhere; -{ - kern_return_t kr; - memory_object_t object; - vm_address_t backing_store; - - pagerlog("pager_vm_allocate(*address = 0x%08x, size = 0x%08x, anywhere = %d)\n", - *address, size, anywhere); - - if (task != task_self()) - return KERN_INVALID_ARGUMENT; - - /* Emulate vm_allocate() ... */ - - if (size == 0) { - *address = 0; - return KERN_SUCCESS; - } - - *address = trunc_page(*address); - size = round_page(size); - - kr = vm_allocate(task_self(), &backing_store, size, TRUE); - if (kr != KERN_SUCCESS) - goto e0; - - /* Now get a memory_object */ - kr = pager_allocate_memory_object(&object, backing_store, size); - if (kr != KERN_SUCCESS) - goto e0; - - kr = vm_map(task_self(), address, size, 0, anywhere, - object, 0, FALSE, VM_PROT_ALL, VM_PROT_ALL, - VM_INHERIT_COPY); - if (kr != KERN_SUCCESS) - goto e1; - - return KERN_SUCCESS; - - e1: - (void) pager_deallocate_memory_object(object); - e0: - return kr; -} - -kern_return_t -pager_vm_deallocate(task, address, size) -task_t task; -vm_address_t address; -vm_size_t size; -{ - pagerlog("pager_vm_deallocate(address = 0x%08x, size = 0x%08x)\n", - address, size); - - if (task != task_self()) - return KERN_INVALID_ARGUMENT; - - return vm_deallocate(task_self(), address, size); -} - -kern_return_t -pager_map_fd(fd, offset, address, anywhere, size) -int fd; -vm_offset_t offset; -vm_address_t *address; -boolean_t anywhere; -vm_size_t size; -{ - kern_return_t kr; - memory_object_t object; - vm_address_t backing_store; - - pagerlog("pager_map_fd(fd = %d, offset = 0x%08x, *address = 0x%08x, anywhere = %d, size = 0x%08x)\n", - fd, offset, *address, anywhere, size); - - kr = map_fd(fd, offset, &backing_store, TRUE, size); - if (kr != KERN_SUCCESS) - goto e0; - - /* Now get a memory_object */ - kr = pager_allocate_memory_object(&object, backing_store, size); - if (kr != KERN_SUCCESS) - goto e0; - - (void) vm_deallocate(task_self(), *address, size); - kr = vm_map(task_self(), address, size, 0, anywhere, - object, 0, FALSE, VM_PROT_ALL, VM_PROT_ALL, - VM_INHERIT_COPY); - if (kr != KERN_SUCCESS) - goto e1; - - return KERN_SUCCESS; - - e1: - (void) pager_deallocate_memory_object(object); - e0: - return kr; -} - - -/* Initialization */ - -static -pager_thread(arg) -any_t arg; -{ - pagerlog("pager_thread() started.\n"); - - pager_serve_requests(); -} - -pager_init() -{ - pager_objects_mutex = mutex_alloc(); - - pagerlog("*** lisp pager log start ***\n"); - - SYSCALL_OR_LOSE(port_allocate(task_self(), &pager_port)); - pagerlog("pager_port = %d\n", pager_port); - - SYSCALL_OR_LOSE(port_set_allocate(task_self(), &pager_port_set)); - pagerlog("pager_port_set = %d\n", pager_port_set); - - SYSCALL_OR_LOSE(port_set_add(task_self(), pager_port_set, pager_port)); - - cthread_detach(cthread_fork(pager_thread, (any_t) 0)); -} diff --git a/ldb/pager.h b/ldb/pager.h deleted file mode 100644 index 5a6de401823cc27bfc7aa4eea4751710a4bc0cb6..0000000000000000000000000000000000000000 --- a/ldb/pager.h +++ /dev/null @@ -1,43 +0,0 @@ -/* - * pager.h - */ - -#if !defined(_PAGER_H_INCLUDED_) -#define _PAGER_H_INCLUDED_ - -typedef struct pager_object { - memory_object_t object; - memory_object_control_t control; - memory_object_name_t name; - vm_size_t size; - vm_address_t backing_store; - struct pager_object *prev; - struct pager_object *next; -} pager_object_t; - -#define NULL_PAGER_OBJECT ((pager_object_t *) 0) - -#define SYSCALL_OR_LOSE(syscall) { \ - kern_return_t kr; \ - \ - if ((kr = (syscall)) != KERN_SUCCESS) { \ - fprintf(stderr, "ERROR:\n"); \ - fprintf(stderr, "In file \"%s\", line %d:", \ - __FILE__, __LINE__); \ - mach_error("", kr); \ - exit(1); \ - } \ -} - -#define SYSCALL_OR_WARN(syscall) { \ - kern_return_t kr; \ - \ - if ((kr = (syscall)) != KERN_SUCCESS) { \ - fprintf(stderr, "WARNING:\n"); \ - fprintf(stderr, "In file \"%s\", line %d:", \ - __FILE__, __LINE__); \ - mach_error("", kr); \ - } \ -} - -#endif diff --git a/ldb/pagerlog.c b/ldb/pagerlog.c deleted file mode 100644 index 59a9cd5698e786a2480bf676d74cee00ca251e70..0000000000000000000000000000000000000000 --- a/ldb/pagerlog.c +++ /dev/null @@ -1,38 +0,0 @@ -/* - * pager log facility - */ - -#include <stdio.h> -#include <varargs.h> - -#define PAGER_LOGFILE "./pager.log" - -static initialized = 0; -static FILE *logfile; - -static void -initialize_pagerlog() -{ - logfile = fopen(PAGER_LOGFILE, "w+"); - if (logfile == (FILE *) NULL) { - fprintf(stderr, "pagerlog: cannot open %s\n", PAGER_LOGFILE); - exit(1); - } - setlinebuf(logfile); - initialized = 1; -} - -/*VARARGS1*/ -pagerlog(fmt, va_alist) -char *fmt; -va_dcl -{ - va_list pvar; - - if (!initialized) - initialize_pagerlog(); - - va_start(pvar); - vfprintf(logfile, fmt, pvar); - va_end(pvar); -} diff --git a/ldb/parse.c b/ldb/parse.c deleted file mode 100644 index bb19fc06f05944d2997c4d781cbf360d310b6d3a..0000000000000000000000000000000000000000 --- a/ldb/parse.c +++ /dev/null @@ -1,347 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/parse.c,v 1.4 1990/05/12 16:41:58 ch Exp $ */ -#include <stdio.h> -#include <ctype.h> -#include <signal.h> -#include <strings.h> - -#include "ldb.h" -#include "lisp.h" -#include "globals.h" -#include "vars.h" -#include "parse.h" -#include "interrupt.h" -#include "lispregs.h" - -static void skip_ws(ptr) -char **ptr; -{ - while (**ptr <= ' ' && **ptr != '\0') - (*ptr)++; -} - -static boolean string_to_long(token, value) -char *token; -long *value; -{ - int base, digit; - long num; - char *ptr; - - if (token == 0) - return FALSE; - - if (token[0] == '0') - if (token[1] == 'x') { - base = 16; - token += 2; - } - else { - base = 8; - token++; - } - else if (token[0] == '#') { - switch (token[1]) { - case 'x': - case 'X': - base = 16; - token += 2; - break; - case 'o': - case 'O': - base = 8; - token += 2; - break; - default: - return FALSE; - } - } - else - base = 10; - - num = 0; - ptr = token; - while (*ptr != '\0') { - if (*ptr >= 'a' && *ptr <= 'f') - digit = *ptr + 10 - 'a'; - else if (*ptr >= 'A' && *ptr <= 'F') - digit = *ptr + 10 - 'A'; - else if (*ptr >= '0' && *ptr <= '9') - digit = *ptr - '0'; - else - return FALSE; - if (digit < 0 || digit >= base) - return FALSE; - - ptr++; - num = num * base + digit; - } - - *value = num; - return TRUE; -} - -static boolean lookup_variable(name, result) -char *name; -lispobj *result; -{ - struct var *var = lookup_by_name(name); - - if (var == NULL) - return FALSE; - else { - *result = var_value(var); - return TRUE; - } -} - - -boolean more_p(ptr) -char **ptr; -{ - skip_ws(ptr); - - if (**ptr == '\0') - return FALSE; - else - return TRUE; -} - -char *parse_token(ptr) -char **ptr; -{ - char *token; - - skip_ws(ptr); - - if (**ptr == '\0') - return NULL; - - token = *ptr; - - while (**ptr > ' ') - (*ptr)++; - - if (**ptr != '\0') { - **ptr = '\0'; - (*ptr)++; - } - - return token; -} - -#if 0 -static boolean number_p(token) -char *token; -{ - char *okay; - - if (token == NULL) - return FALSE; - - okay = "abcdefABCDEF987654321d0"; - - if (token[0] == '0') - if (token[1] == 'x' || token[1] == 'X') - token += 2; - else { - token++; - okay += 14; - } - else if (token[0] == '#') { - switch (token[1]) { - case 'x': - case 'X': - break; - case 'o': - case 'O': - okay += 14; - break; - default: - return FALSE; - } - } - else - okay += 12; - - while (*token != '\0') - if (index(okay, *token++) == NULL) - return FALSE; - return TRUE; -} -#endif - -long parse_number(ptr) -char **ptr; -{ - char *token = parse_token(ptr); - long result; - - if (token == NULL) { - printf("Expected a number.\n"); - throw_to_monitor(); - } - else if (string_to_long(token, &result)) - return result; - else { - printf("Invalid number: ``%s''\n", token); - throw_to_monitor(); - } -} - -char *parse_addr(ptr) -char **ptr; -{ - char *token = parse_token(ptr); - long result; - - if (token == NULL) { - printf("Expected an address.\n"); - throw_to_monitor(); - } - else if (token[0] == '$') { - if (!lookup_variable(token+1, (lispobj *)&result)) { - printf("Unknown variable: ``%s''\n", token); - throw_to_monitor(); - } - result &= ~7; - } - else { - if (!string_to_long(token, &result)) { - printf("Invalid number: ``%s''\n", token); - throw_to_monitor(); - } - result &= ~3; - } - - if (!valid_addr(result)) { - printf("Invalid address: 0x%x\n", result); - throw_to_monitor(); - } - - return (char *)result; -} - -static boolean lookup_symbol(name, result) -char *name; -lispobj *result; -{ - int count; - - /* Search read only space */ - *result = (lispobj) read_only_space; - count = ((lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER) - - read_only_space); - if (search_for_symbol(name, result, &count)) { - *result |= type_OtherPointer; - return TRUE; - } - - /* Search static space */ - *result = (lispobj) static_space; - count = ((lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER) - - static_space); - if (search_for_symbol(name, result, &count)) { - *result |= type_OtherPointer; - return TRUE; - } - - /* Search dynamic space */ - *result = (lispobj) current_dynamic_space; - count = current_dynamic_space_free_pointer - current_dynamic_space; - if (search_for_symbol(name, result, &count)) { - *result |= type_OtherPointer; - return TRUE; - } - - return FALSE; -} - -static int -parse_regnum(s) -char *s; -{ - if ((s[1] == 'R') || (s[1] == 'r')) { - int regnum; - - if (s[2] == '\0') - return -1; - - /* skip the $R part and call atoi on the number */ - regnum = atoi(s + 2); - if ((regnum >= 0) && (regnum < NREGS)) - return regnum; - else - return -1; - } else { - int i; - - for (i = 0; i < NREGS ; i++) - if (strcasecmp(s + 1, lisp_register_names[i]) == 0) - return i; - - return -1; - } -} - -lispobj parse_lispobj(ptr) -char **ptr; -{ - char *token = parse_token(ptr); - long pointer; - lispobj result; - - if (token == NULL) { - printf("Expected an object.\n"); - throw_to_monitor(); - } else if (token[0] == '$') { - if (isalpha(token[1])) { - int free; - int regnum; - struct sigcontext *context; - - free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2; - - if (free == 0) { - printf("Variable ``%s'' is not valid -- there is no current interrupt context.\n", token); - throw_to_monitor(); - } - - context = lisp_interrupt_contexts[free - 1]; - - regnum = parse_regnum(token); - if (regnum < 0) { - printf("Bogus register: ``%s''\n", token); - throw_to_monitor(); - } - - result = context->sc_regs[regnum]; - } else if (!lookup_variable(token+1, &result)) { - printf("Unknown variable: ``%s''\n", token); - throw_to_monitor(); - } - } else if (token[0] == '@') { - if (string_to_long(token+1, &pointer)) { - pointer &= ~3; - if (valid_addr(pointer)) - result = *(lispobj *)pointer; - else { - printf("Invalid address: ``%s''\n", token+1); - throw_to_monitor(); - } - } - else { - printf("Invalid address: ``%s''\n", token+1); - throw_to_monitor(); - } - } - else if (string_to_long(token, (long *)&result)) - ; - else if (lookup_symbol(token, &result)) - ; - else { - printf("Invalid lisp object: ``%s''\n", token); - throw_to_monitor(); - } - - return result; -} diff --git a/ldb/parse.h b/ldb/parse.h deleted file mode 100644 index ebd096bd104a97156378ae35e998d1078c36bce8..0000000000000000000000000000000000000000 --- a/ldb/parse.h +++ /dev/null @@ -1,9 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/parse.h,v 1.1 1990/02/24 19:37:27 wlott Exp $ */ - -/* All parse routines take a char ** as their only argument */ - -boolean more_p(); -char *parse_token(); -lispobj parse_lispobj(); -char *parse_addr(); -long parse_number(); diff --git a/ldb/print.c b/ldb/print.c deleted file mode 100644 index 4cefd3e398572948a1e4b2e90a1eb1ce747f550c..0000000000000000000000000000000000000000 --- a/ldb/print.c +++ /dev/null @@ -1,557 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/print.c,v 1.11 1990/05/13 22:49:09 ch Exp $ */ -#include <stdio.h> - -#include "ldb.h" -#include "print.h" -#include "lisp.h" -#include "vars.h" - -static int max_lines = 20, cur_lines = 0; -static int max_depth = 5, brief_depth = 2, cur_depth = 0; -static int max_length = 5; -static boolean dont_decend = FALSE, skip_newline = FALSE; -static cur_clock = 0; - -static void print_obj(); - -#define NEWLINE if (continue_p(TRUE)) newline(NULL); else return; - -char *lowtag_Names[] = { - "even fixnum", - "function pointer", - "other immediate [0]", - "list pointer", - "odd fixnum", - "structure pointer", - "other immediate [1]", - "other pointer" -}; - -char *subtype_Names[] = { - "unused 0", - "unused 1", - "bignum", - "ratio", - "single float", - "double float", - "complex", - "simple-array", - "simple-string", - "simple-bit-vector", - "simple-vector", - "(simple-array (unsigned-byte 2) (*))", - "(simple-array (unsigned-byte 4) (*))", - "(simple-array (unsigned-byte 8) (*))", - "(simple-array (unsigned-byte 16) (*))", - "(simple-array (unsigned-byte 32) (*))", - "(simple-array single-float (*))", - "(simple-array double-float (*))", - "complex-string", - "complex-bit-vector", - "(array * (*))", - "array", - "code header", - "function header", - "closure function header", - "return PC header", - "closure header", - "value cell header", - "symbol header", - "character", - "SAP", - "unbound marker", - "weak pointer" -}; - -static void indent(in) -int in; -{ - static char *spaces = " "; - - while (in > 64) { - fputs(spaces, stdout); - in -= 64; - } - if (in != 0) - fputs(spaces + 64 - in, stdout); -} - -static boolean continue_p(newline) -boolean newline; -{ - char buffer[256]; - - if (cur_depth >= max_depth || dont_decend) - return FALSE; - - if (newline) { - if (skip_newline) - skip_newline = FALSE; - else - putchar('\n'); - - if (cur_lines >= max_lines) { - printf("More? [y] "); - fflush(stdout); - - gets(buffer); - - if (buffer[0] == 'n' || buffer[0] == 'N') - throw_to_monitor(); - else - cur_lines = 0; - } - } - - return TRUE; -} - -static void newline(label) -char *label; -{ - cur_lines++; - if (label != NULL) - fputs(label, stdout); - putchar('\t'); - indent(cur_depth * 2); -} - - -static void brief_fixnum(obj) -lispobj obj; -{ - printf("%d", ((long)obj)>>2); -} - -static void print_fixnum(obj) -lispobj obj; -{ - printf(": %d", ((long)obj)>>2); -} - -static void brief_otherimm(obj) -lispobj obj; -{ - int type, c, idx; - char buffer[10]; - - type = TypeOf(obj); - switch (type) { - case type_BaseCharacter: - c = (obj>>8)&0xff; - switch (c) { - case '\0': - printf("#\\Null"); - break; - case '\n': - printf("#\\Newline"); - break; - case '\b': - printf("#\\Backspace"); - break; - case '\177': - printf("#\\Delete"); - break; - default: - strcpy(buffer, "#\\"); - if (c >= 128) { - strcat(buffer, "m-"); - c -= 128; - } - if (c < 32) { - strcat(buffer, "c-"); - c += '@'; - } - printf("%s%c", buffer, c); - break; - } - break; - - case type_UnboundMarker: - printf("<unbound marker>"); - break; - - default: - idx = type >> 2; - if (idx < (sizeof(subtype_Names) / sizeof(char *))) - printf("%s", subtype_Names[idx]); - else - printf("unknown type (0x%0x)", type); - break; - } -} - -static void print_otherimm(obj) -lispobj obj; -{ - int type, c, idx; - - type = TypeOf(obj); - idx = type >> 2; - - if (idx < (sizeof(subtype_Names) / sizeof(char *))) - printf(", %s", subtype_Names[idx]); - else - printf(", unknown type (0x%0x)", type); - - switch (TypeOf(obj)) { - case type_BaseCharacter: - printf(": "); - brief_otherimm(obj); - break; - - case type_Sap: - case type_UnboundMarker: - break; - - default: - printf(": data=%d", (obj>>8)&0xffffff); - break; - } -} - -static void brief_list(obj) -lispobj obj; -{ - int space = FALSE; - int length = 0; - - if (!valid_addr(obj)) - printf("(invalid address)"); - else if (obj == NIL) - printf("NIL"); - else { - putchar('('); - while (LowtagOf(obj) == type_ListPointer) { - struct cons *cons = (struct cons *)PTR(obj); - - if (space) - putchar(' '); - if (++length >= max_length) { - printf("..."); - obj = NIL; - break; - } - print_obj(NULL, cons->car); - obj = cons->cdr; - space = TRUE; - if (obj == NIL) - break; - } - if (obj != NIL) { - printf(" . "); - print_obj(NULL, obj); - } - putchar(')'); - } -} - -static void print_list(obj) -lispobj obj; -{ - if (!valid_addr(obj)) - printf("(invalid address)"); - else if (obj == NIL) - printf(" (NIL)"); - else { - struct cons *cons = (struct cons *)PTR(obj); - - print_obj("car: ", cons->car); - print_obj("cdr: ", cons->cdr); - } -} - -static void brief_struct(obj) -lispobj obj; -{ - printf("structure"); -} - -static void print_struct(obj) -lispobj obj; -{ - printf("Structure mumble mumble."); -} - -static void brief_otherptr(obj) -lispobj obj; -{ - lispobj *ptr, header; - int type; - struct symbol *symbol; - struct vector *vector; - char *charptr; - - ptr = (lispobj *) PTR(obj); - - if (!valid_addr(obj)) { - printf("(invalid address)"); - return; - } - - header = *ptr; - type = TypeOf(header); - switch (type) { - case type_SymbolHeader: - symbol = (struct symbol *)ptr; - vector = (struct vector *)PTR(symbol->name); - for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) { - if (*charptr == '"') - putchar('\\'); - putchar(*charptr); - } - break; - - case type_SimpleString: - vector = (struct vector *)ptr; - putchar('"'); - for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) { - if (*charptr == '"') - putchar('\\'); - putchar(*charptr); - } - putchar('"'); - break; - - default: - printf("#<ptr to "); - brief_otherimm(header); - putchar('>'); - } -} - -static void print_slots(slots, count, ptr) -char **slots; -int count; -long *ptr; -{ - while (count-- > 0) - if (*slots) - print_obj(*slots++, *ptr++); - else - print_obj("???: ", *ptr++); -} - -static char *symbol_slots[] = {"value: ", "function: ", "plist: ", "name: ", "package: ", NULL}; -static char *ratio_slots[] = {"numer: ", "denom: ", NULL}; -static char *complex_slots[] = {"real: ", "imag: ", NULL}; -static char *code_slots[] = {"words: ", "entry: ", "debug: ", NULL}; -static char *fn_slots[] = {"self: ", "next: ", "name: ", "arglist: ", "type: ", NULL}; -static char *closure_slots[] = {"fn: ", NULL}; -static char *weak_pointer_slots[] = {"value: ", NULL}; - -static void print_otherptr(obj) -lispobj obj; -{ - if (!valid_addr(obj)) - printf("(invalid address)"); - else { - unsigned long *ptr; - unsigned long header; - unsigned long length; - int count, type, index; - boolean raw; - char *cptr, buffer[16]; - - ptr = (unsigned long *) PTR(obj); - if (ptr == (unsigned long *) NULL) { - printf(" (NULL Pointer)"); - return; - } - - header = *ptr++; - length = (*ptr) >> 2; - count = header>>8; - type = TypeOf(header); - - print_obj("header: ", header); - if (LowtagOf(header) != type_OtherImmediate0 && LowtagOf(header) != type_OtherImmediate1) { - NEWLINE; - printf("(invalid header object)"); - return; - } - - switch (type) { - case type_Bignum: - ptr += count; - NEWLINE; - printf("0x"); - while (count-- > 0) - printf("%08x", *--ptr); - break; - - case type_Ratio: - print_slots(ratio_slots, count, ptr); - break; - - case type_Complex: - print_slots(complex_slots, count, ptr); - break; - - case type_SymbolHeader: - print_slots(symbol_slots, count, ptr); - break; - - case type_SingleFloat: - NEWLINE; - printf("%f", *(float *)ptr); - break; - - case type_DoubleFloat: - NEWLINE; - printf("%lf", *(double *)ptr); - break; - - case type_SimpleString: - NEWLINE; - cptr = (char *)(ptr+1); - putchar('\"'); - while (length-- > 0) - putchar(*cptr++); - putchar('\"'); - break; - - case type_SimpleVector: - NEWLINE; - printf("length = %d", length); - ptr++; - index = 0; - while (length-- > 0) { - sprintf(buffer, "%d: ", index++); - print_obj(buffer, *ptr++); - } - break; - - case type_SimpleArray: - case type_SimpleBitVector: - case type_SimpleArrayUnsignedByte2: - case type_SimpleArrayUnsignedByte4: - case type_SimpleArrayUnsignedByte8: - case type_SimpleArrayUnsignedByte16: - case type_SimpleArrayUnsignedByte32: - case type_SimpleArraySingleFloat: - case type_SimpleArrayDoubleFloat: - case type_ComplexString: - case type_ComplexBitVector: - case type_ComplexVector: - case type_ComplexArray: - break; - - case type_CodeHeader: - print_slots(code_slots, count-1, ptr); - break; - - case type_FunctionHeader: - case type_ClosureFunctionHeader: - print_slots(fn_slots, 5, ptr); - break; - - case type_ReturnPcHeader: - print_obj("code: ", obj - (count * 4)); - break; - - case type_ClosureHeader: - print_slots(closure_slots, count, ptr); - break; - - case type_Sap: - NEWLINE; - printf("0x%08x", *ptr); - break; - - case type_WeakPointer: - print_slots(weak_pointer_slots, 1, ptr); - break; - - case type_BaseCharacter: - case type_UnboundMarker: - NEWLINE; - printf("pointer to an immediate?"); - break; - } - } -} - -static void print_obj(prefix, obj) -char *prefix; -lispobj obj; -{ - static void (*verbose_fns[])() = {print_fixnum, print_otherptr, print_otherimm, print_list, print_fixnum, print_struct, print_otherimm, print_otherptr}; - static void (*brief_fns[])() = {brief_fixnum, brief_otherptr, brief_otherimm, brief_list, brief_fixnum, brief_struct, brief_otherimm, brief_otherptr}; - int type = LowtagOf(obj); - struct var *var = lookup_by_obj(obj); - char buffer[256]; - boolean verbose = cur_depth < brief_depth; - - - if (!continue_p(verbose)) - return; - - if (var != NULL && var_clock(var) == cur_clock) - dont_decend = TRUE; - - if (var == NULL && (obj & type_FunctionPointer & type_ListPointer & type_StructurePointer & type_OtherPointer) != 0) - var = define_var(NULL, obj, FALSE); - - if (var != NULL) - var_setclock(var, cur_clock); - - cur_depth++; - if (verbose) { - if (var != NULL) { - sprintf(buffer, "$%s=", var_name(var)); - newline(buffer); - } - else - newline(NULL); - printf("%s0x%08x: ", prefix, obj); - if (cur_depth < brief_depth) { - fputs(lowtag_Names[type], stdout); - (*verbose_fns[type])(obj); - } - else - (*brief_fns[type])(obj); - } - else { - if (dont_decend) - printf("$%s", var_name(var)); - else { - if (var != NULL) - printf("$%s=", var_name(var)); - (*brief_fns[type])(obj); - } - } - cur_depth--; - dont_decend = FALSE; -} - -void reset_printer() -{ - cur_clock++; - cur_lines = 0; - dont_decend = FALSE; -} - -void print(obj) -lispobj obj; -{ - skip_newline = TRUE; - cur_depth = 0; - max_depth = 5; - max_lines = 20; - - print_obj("", obj); - - putchar('\n'); -} - -void brief_print(obj) -lispobj obj; -{ - skip_newline = TRUE; - max_depth = 1; - max_lines = 5000; - - print_obj("", obj); - putchar('\n'); -} diff --git a/ldb/print.h b/ldb/print.h deleted file mode 100644 index c66202e00c3f976117f1a8f66b79529411ae7b80..0000000000000000000000000000000000000000 --- a/ldb/print.h +++ /dev/null @@ -1,5 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/print.h,v 1.1 1990/02/24 19:37:30 wlott Exp $ */ - -extern char *lowtag_Names[], *subtype_Names[]; - -extern void print(); diff --git a/ldb/regnames.c b/ldb/regnames.c deleted file mode 100644 index ef5f1f58c30960a23a973caa329d592bd11321bf..0000000000000000000000000000000000000000 --- a/ldb/regnames.c +++ /dev/null @@ -1,42 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/regnames.c,v 1.1 1990/03/29 21:03:00 ch Exp $ */ - -#include "lispregs.h" - -char *lisp_register_names[] = { - "ZERO", - "LIP", - "NL0", - "NL1", - "NL2", - "NL3", - "NL4", - "NARGS", - "A0", - "A1", - "A2", - "A3", - "A4", - "A5", - "CNAME", - "LEXENV", - "ARGS", - "OCONT", - "LRA", - "L0", - "NULL", - "BSP", - "CONT", - "CSP", - "FLAGS", - "ALLOC", - "K0", - "K1", - "L1", - "NSP", - "CODE", - "L2" -}; - - - - diff --git a/ldb/search.c b/ldb/search.c deleted file mode 100644 index f887e9291a6bb3bb1235dde82a37de0eee7c2041..0000000000000000000000000000000000000000 --- a/ldb/search.c +++ /dev/null @@ -1,43 +0,0 @@ - -#include "lisp.h" -#include "ldb.h" - -boolean search_for_type(type, start, count) -int type; -lispobj **start; -int *count; -{ - lispobj obj, *addr; - - while ((*count == -1 || (*count > 0)) && valid_addr(*start)) { - obj = **start; - addr = *start; - if (*count != -1) - *count -= 2; - - if (TypeOf(obj) == type) - return TRUE; - - (*start) += 2; - } - return FALSE; -} - - -boolean search_for_symbol(name, start, count) -char *name; -lispobj **start; -int *count; -{ - struct symbol *symbol; - struct vector *symbol_name; - - while (search_for_type(type_SymbolHeader, start, count)) { - symbol = (struct symbol *)PTR((lispobj)*start); - symbol_name = (struct vector *)PTR(symbol->name); - if (valid_addr(symbol_name) && TypeOf(symbol_name->header) == type_SimpleString && strcmp((char *)symbol_name->data, name) == 0) - return TRUE; - (*start) += 2; - } - return FALSE; -} diff --git a/ldb/test.c b/ldb/test.c deleted file mode 100644 index 08e0b33689f246982bec31dc0cc681518a5fa096..0000000000000000000000000000000000000000 --- a/ldb/test.c +++ /dev/null @@ -1,189 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/test.c,v 1.5 1990/05/26 01:23:30 ch Exp $ */ -/* Extra random routines for testing stuff. */ - -#include <signal.h> -#include <mips/cpu.h> - -#include "lisp.h" -#include "ldb.h" - -static char *signames[] = { - "<Unused>", "SIGHUP", "SIGINT", "SIGQUIT", "SIGILL", "SIGTRAP", - "SIGIOT", "SIGEMT", "SIGFPE", "SIGKILL", "SIGBUS", "SIGSEGV", - "SIGSYS", "SIGPIPE", "SIGALRM", "SIGTERM", "SIGURG", "SIGSTOP", - "SIGTSTP", "SIGCONT", "SIGCHLD", "SIGTTIN", "SIGTTOU", "SIGIO", - "SIGXCPU", "SIGXFSZ", "SIGVTALRM", "SIGPROF", "SIGWINCH", - "SIGUSR1", "SIGUSR2" -}; - -static char *errors[] = ERRORS; - - -signal_handler(signal, code, context) -int signal, code; -struct sigcontext *context; -{ - int mask; - unsigned long *ptr, bad_inst; - char *cptr; - - printf("Hit with %s, code = %d, context = 0x%x\n", signames[signal], code, context); - - if (context->sc_cause & CAUSE_BD) - ptr = (unsigned long *)(context->sc_pc + 4); - else - ptr = (unsigned long *)(context->sc_pc); - bad_inst = *ptr; - - if ((bad_inst >> 26) == 0 && (bad_inst & 0x3f) == 0xd) { - /* It was a break. */ - switch (code) { - case trap_Halt: - printf("%primitive halt called; the party is over.\n"); - break; - - case trap_PendingInterrupt: - printf("Pending interrupt trap? This should not happen.\n"); - break; - - case trap_Error: - case trap_Cerror: - cptr = (char *)(ptr+1); - printf("Error: %s\n", errors[*cptr]); - while (*++cptr != 0) - printf(" R%d: 0x%x\n", *cptr, context->sc_regs[*cptr]); - if (code == trap_Cerror) { - printf("Hit a break. Use ``exit'' to continue.\n"); - if (context->sc_cause & CAUSE_BD) - emulate_branch(context, *(unsigned long *)context->sc_pc); - else - context->sc_pc += 4; - } - break; - - default: - printf("Unknown trap type.\n"); - break; - } - } - - mask = sigsetmask(0); - - monitor(); - - sigsetmask(mask); -} - - - -#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2) - -static sigfpe_handler(signal, code, context) -int signal, code; -struct sigcontext *context; -{ - unsigned long bad_inst; - unsigned int op, rs, rt, rd, funct, dest; - int immed; - long result; - - if (context->sc_cause & CAUSE_BD) - bad_inst = *(unsigned long *)(context->sc_pc + 4); - else - bad_inst = *(unsigned long *)(context->sc_pc); - - op = (bad_inst >> 26) & 0x3f; - rs = (bad_inst >> 21) & 0x1f; - rt = (bad_inst >> 16) & 0x1f; - rd = (bad_inst >> 11) & 0x1f; - funct = bad_inst & 0x3f; - immed = (((int)(bad_inst & 0xffff)) << 16) >> 16; - - switch (op) { - case 0x0: /* SPECIAL */ - switch (funct) { - case 0x20: /* ADD */ - result = FIXNUM_VALUE(context->sc_regs[rs]) + FIXNUM_VALUE(context->sc_regs[rt]); - dest = rd; - break; - - case 0x22: /* SUB */ - result = FIXNUM_VALUE(context->sc_regs[rs]) - FIXNUM_VALUE(context->sc_regs[rt]); - dest = rd; - break; - - default: - signal_handler(signal, code, context); - return; - } - break; - - case 0x8: /* ADDI */ - result = FIXNUM_VALUE(context->sc_regs[rs]) + (immed>>2); - dest = rt; - break; - - default: - signal_handler(signal, code, context); - return; - } - - context->sc_regs[dest] = alloc_number(result); - - /* Skip the offending instruction */ - if (context->sc_cause & CAUSE_BD) - emulate_branch(context, *(unsigned long *)context->sc_pc); - else - context->sc_pc += 4; -} - - - -static sigsegv_handler(signal, code, context) -int signal, code; -struct sigcontext *context; -{ -#if 0 - if (bogus_page == guard_page) { - unprotext(guard_page); - if ((!foreign_function_call_active) && - (context->sc_regs[FLAGS] & (1<<flag_Atomic))) { - pending_signal = signal; - pending_code = code; - pending_mask = context->sc_mask; - context->sc_mask |= BLOCKABLE; - context->sc_regs[FLAGS] |= (1<<flag_Interrupted); - } - /* ### Fix this */ - SetSymbolValue(GC_TRIGGER_HIT, T); - } - else -#endif -} - - - -test_init() -{ - extern int throw_to_top(), throw_to_monitor(); - - install_handler(SIGINT, signal_handler); - install_handler(SIGQUIT, throw_to_top); - install_handler(SIGTRAP, signal_handler); - install_handler(SIGFPE, sigfpe_handler); -} - - -cacheflush() -{ - /* This is supposed to be defined, but is not. */ -} - - -lispobj debug_print(string) -lispobj string; -{ - printf("%s\n", ((struct vector *)PTR(string))->data); - - return NIL; -} diff --git a/ldb/validate.c b/ldb/validate.c deleted file mode 100644 index 37e07549995abbab4775f5fd0443ecefcf90115b..0000000000000000000000000000000000000000 --- a/ldb/validate.c +++ /dev/null @@ -1,37 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/validate.c,v 1.2 1990/03/29 21:15:22 ch Exp $ */ - -#include <stdio.h> -#include "lisp.h" -#include "globals.h" -#include "validate.h" - -validate() -{ - printf("Validating memory ..."); - fflush(stdout); - - /* Read only space */ - read_only_space = (lispobj *) READ_ONLY_SPACE_START; - os_validate(read_only_space, READ_ONLY_SPACE_SIZE); - - /* Static Space */ - static_space = (lispobj *) STATIC_SPACE_START; - os_validate(static_space, STATIC_SPACE_SIZE); - - /* Dynamic 0 Space */ - dynamic_0_space = (lispobj *) DYNAMIC_0_SPACE_START; - os_validate(dynamic_0_space, DYNAMIC_SPACE_SIZE); - current_dynamic_space = dynamic_0_space; - - dynamic_1_space = (lispobj *) DYNAMIC_1_SPACE_START; - - /* Control Stack */ - control_stack = (lispobj *) CONTROL_STACK_START; - os_validate(control_stack, CONTROL_STACK_SIZE); - - /* Binding Stack */ - binding_stack = (lispobj *) BINDING_STACK_START; - os_validate(binding_stack, BINDING_STACK_SIZE); - - printf(" done.\n"); -} diff --git a/ldb/validate.h b/ldb/validate.h deleted file mode 100644 index 8e161bfb11b86ff46b9a1a55778d9a33fcf2dd2b..0000000000000000000000000000000000000000 --- a/ldb/validate.h +++ /dev/null @@ -1,22 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/validate.h,v 1.2 1990/04/05 00:48:37 wlott Exp $ */ - -#if !defined(_INCLUDE_VALIDATE_H_) -#define _INCLUDE_VALIDATE_H_ - -#define READ_ONLY_SPACE_START (0x20000000) -#define READ_ONLY_SPACE_SIZE (0x01000000) - -#define STATIC_SPACE_START (0x30000000) -#define STATIC_SPACE_SIZE (0x01000000) - -#define DYNAMIC_0_SPACE_START (0x40000000) -#define DYNAMIC_1_SPACE_START (0x48000000) -#define DYNAMIC_SPACE_SIZE (0x08000000) - -#define CONTROL_STACK_START (0x50000000) -#define CONTROL_STACK_SIZE (0x00100000) - -#define BINDING_STACK_START (0x60000000) -#define BINDING_STACK_SIZE (0x00100000) - -#endif diff --git a/ldb/vars.c b/ldb/vars.c deleted file mode 100644 index d7b689d15e2116427bc27e96ad69b3da73ce02f0..0000000000000000000000000000000000000000 --- a/ldb/vars.c +++ /dev/null @@ -1,184 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/vars.c,v 1.1 1990/02/24 19:37:32 wlott Exp $ */ -#include <stdio.h> - -#include "ldb.h" -#include "lisp.h" -#include "vars.h" - -#define NAME_BUCKETS 31 -#define OBJ_BUCKETS 31 - -static struct var *NameHash[NAME_BUCKETS], *ObjHash[OBJ_BUCKETS]; -static int tempcntr = 1; - -struct var { - lispobj obj, (*update_fn)(); - char *name; - long clock; - boolean map_back, permanent; - - struct var *nnext; /* Next in name list */ - struct var *onext; /* Next in object list */ -}; - -static int hash_name(name) -unsigned char *name; -{ - unsigned long value = 0; - - while (*name != '\0') { - value = (value << 1) ^ *name++; - value = (value & (1-(1<<24))) ^ (value >> 24); - } - - return value % NAME_BUCKETS; -} - -static int hash_obj(obj) -lispobj obj; -{ - return (long)obj % OBJ_BUCKETS; -} - - -void flush_vars() -{ - int index; - struct var *var, *next, *perm = NULL; - - /* Note: all vars in the object hash table also appear in the name hash table, so if we free everything in the name hash table, we free everything in the object hash table. */ - - for (index = 0; index < NAME_BUCKETS; index++) - for (var = NameHash[index]; var != NULL; var = next) { - next = var->nnext; - if (var->permanent) { - var->nnext = perm; - perm = var; - } - else { - free(var->name); - free(var); - } - } - bzero(NameHash, sizeof(NameHash)); - bzero(ObjHash, sizeof(ObjHash)); - tempcntr = 1; - - for (var = perm; var != NULL; var = next) { - next = var->nnext; - index = hash_name(var->name); - var->nnext = NameHash[index]; - NameHash[index] = var; - if (var->map_back) { - index = hash_obj(var->obj); - var->onext = ObjHash[index]; - ObjHash[index] = var; - } - } -} - -struct var *lookup_by_name(name) -char *name; -{ - struct var *var; - - for (var = NameHash[hash_name(name)]; var != NULL; var = var->nnext) - if (strcmp(var->name, name) == 0) - return var; - return NULL; -} - -struct var *lookup_by_obj(obj) -lispobj obj; -{ - struct var *var; - - for (var = ObjHash[hash_obj(obj)]; var != NULL; var = var->onext) - if (var->obj == obj) - return var; - return NULL; -} - -static struct var *make_var(name, perm) -char *name; -boolean perm; -{ - struct var *var = (struct var *)malloc(sizeof(struct var)); - char buffer[256]; - int index; - - if (name == NULL) { - sprintf(buffer, "%d", tempcntr++); - name = buffer; - } - var->name = (char *)malloc(strlen(name)+1); - strcpy(var->name, name); - var->clock = 0; - var->permanent = perm; - var->map_back = FALSE; - - index = hash_name(name); - var->nnext = NameHash[index]; - NameHash[index] = var; - - return var; -} - -struct var *define_var(name, obj, perm) -char *name; -lispobj obj; -boolean perm; -{ - struct var *var = make_var(name, perm); - int index; - - var->obj = obj; - - if (lookup_by_obj(obj) == NULL) { - var->map_back = TRUE; - index = hash_obj(obj); - var->onext = ObjHash[index]; - ObjHash[index] = var; - } - - return var; -} - -struct var *define_dynamic_var(name, updatefn, perm) -char *name; -lispobj (*updatefn)(); -boolean perm; -{ - struct var *var = make_var(name, perm); - - var->update_fn = updatefn; - - return var; -} - -char *var_name(var) -struct var *var; -{ - return var->name; -} - -lispobj var_value(var) -struct var *var; -{ - if (var->update_fn != NULL) - var->obj = (*var->update_fn)(var); - return var->obj; -} - -long var_clock(var) -struct var *var; -{ - return var->clock; -} - -void var_setclock(var, val) -struct var *var; -long val; -{ - var->clock = val; -} diff --git a/ldb/vars.h b/ldb/vars.h deleted file mode 100644 index c83eb90a176282715251c704ed27315b41f6c475..0000000000000000000000000000000000000000 --- a/ldb/vars.h +++ /dev/null @@ -1,13 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/vars.h,v 1.1 1990/02/24 19:37:33 wlott Exp $ */ - - -extern void flush_vars(); -extern struct var *lookup_by_name(/* name */); -extern struct var *lookup_by_obj(/* obj */); -extern struct var *define_var(/* name, obj, perm */); -extern struct var *define_dynamic_var(/* name, update_fn, perm */); - -extern char *var_name(); -extern lispobj var_value(); -extern long var_clock(); -extern void var_setclock(); diff --git a/ldb/version.c b/ldb/version.c deleted file mode 100644 index 6ecb66060a5d9b93c6e2e9b9624d3be5258ece42..0000000000000000000000000000000000000000 --- a/ldb/version.c +++ /dev/null @@ -1,2 +0,0 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/version.c,v 1.1 1990/02/24 19:37:34 wlott Exp $ */ -int version = VERSION; diff --git a/tools/comcom.lisp b/tools/comcom.lisp deleted file mode 100644 index 2e541f3c66ac7557807400c74241d32c194817b4..0000000000000000000000000000000000000000 --- a/tools/comcom.lisp +++ /dev/null @@ -1,157 +0,0 @@ -;;; -*- Package: User -*- -;;; -(in-package "USER") - -(c::%proclaim '(optimize (speed 2) (space 2) (c::brevity 2))) -(setq *print-pretty* nil) - -(with-compiler-log-file ("c:compile-compiler.log") - -(unless *new-compile* - (comf "code:fdefinition") - (load "code:extensions.lisp") - (comf "c:globaldb" :load t) - (unless (boundp 'ext::*info-environment*) - (c::globaldb-init)) - - (comf "c:patch") - - (comf "code:macros" :load t) - (comf "code:extensions" :bootstrap-macros :both) - (load "code:extensions.fasl") - (comf "code:struct" :load t) - (comf "c:macros" :load t :bootstrap-macros :both)) - -(when *new-compile* - (comf "code:globals" :always-once t) ; For global variables. - (comf "code:struct" :always-once t) ; For structures. - (comf "c:globals" :always-once t) - (comf "c:proclaim" :always-once t)) ; For COOKIE structure. - -(comf "c:type" :always-once *new-compile*) -(comf "c:rt/vm-type") -(comf "c:type-init") -(comf "c:sset" :always-once *new-compile*) -(comf "c:node" :always-once *new-compile*) -(comf "c:ctype") -#-new-compiler -(comf "c:knownfun" :always-once *new-compile*) -(comf "c:vop" :always-once *new-compile*) -(comf "c:alloc") -(comf "c:fndb") -(comf "c:main") - -#-new-compiler -(unless *new-compile* - (comf "c:proclaim" :load t)) - -(comf "c:ir1tran") -(comf "c:ir1util" :bootstrap-macros :both) -(comf "c:ir1opt") -(comf "c:ir1final") -(comf "c:srctran") -(comf "c:seqtran") -(comf "c:typetran") -(comf "c:locall") -(comf "c:dfo") -(comf "c:checkgen") -(comf "c:constraint") -(comf "c:envanal") -(comf "c:rt/parms") - -(comf "c:vmdef" :load t :bootstrap-macros :both) - -(comf "c:tn" :bootstrap-macros :both) -(comf "c:bit-util") -(comf "c:life") - -(comf "c:assembler" - :load t - :bootstrap-macros :both - :always-once *new-compile*) - -(comf "code:debug-info" - :load t - :bootstrap-macros :both - :always-once *new-compile*) - -(comf "c:rt/assem-insts" :load t) - - -(when *new-compile* - (comf "c:eval-comp") - (comf "c:eval" :bootstrap-macros :both) - (let ((c:*compile-time-define-macros* nil)) - (comf "c:macros" :load t))) - - -(comf "c:aliencomp") -(comf "c:debug-dump") - -(unless *new-compile* - (comf "code:constants" :load t :proceed t) - (comf "assem:rompconst" :load t :proceed t) - (comf "assem:assembler") - (comf "c:fop")) - -(comf "c:rt/assem-macs" :load t :bootstrap-macros :both) - -(comf "c:rt/dump") - -(when *new-compile* - (comf "c:rt/core")) - -(comf "c:rt/vm" :always-once *new-compile*) -(comf "c:rt/move") -(comf "c:rt/char") -(comf "c:rt/miscop") -(comf "c:rt/subprim") -(comf "c:rt/values") -(comf "c:rt/memory") -(comf "c:rt/cell") -(comf "c:rt/call") -(comf "c:rt/nlx") -(comf "c:rt/print") -(comf "c:rt/array") -(comf "c:rt/pred") -(comf "c:rt/type-vops") -(comf "c:rt/arith") -(comf "c:rt/system") -(comf "c:pseudo-vops") -(comf "c:gtn") -(comf "c:ltn") -(comf "c:stack") -(comf "c:control") -(comf "c:entry") -(comf "c:ir2tran") -(comf "c:represent") -(comf "c:rt/vm-tran") -(comf "c:pack") -(comf "c:codegen") -(comf "c:debug") - -#-new-compiler -(unless *new-compile* - (comf "c:rt/genesis")) - -#+new-compiler -(comf "c:rt/genesis") - -(unless *new-compile* - (comf "code:defstruct") - (comf "code:error") - (comf "code:defrecord") - (comf "code:defmacro") - (comf "code:alieneval") - (comf "code:c-call") - (comf "code:salterror") - (comf "code:sysmacs") - (comf "code:machdef") - (comf "code:mmlispdefs") - (comf "icode:machdefs") - (comf "icode:netnamedefs") - (comf "c:globaldb" :output-file "c:boot-globaldb.fasl" - :bootstrap-macros :both)) - - -); with-compiler-error-log diff --git a/tools/hemcom.lisp b/tools/hemcom.lisp deleted file mode 100644 index e8ccd4b874fae984767396c89460106337c5f4fa..0000000000000000000000000000000000000000 --- a/tools/hemcom.lisp +++ /dev/null @@ -1,149 +0,0 @@ -;;; -;;; This file compiles all of Hemlock. -;;; - -(when (ext:get-command-line-switch "slave") - (error "Cannot compile Hemlock in a slave due to its clobbering needed - typescript routines by renaming the package.")) - - -;;; Blast the old packages in case they are around. We do this solely to -;;; prove Hemlock can compile cleanly without its having to exist already. -;;; -(when (find-package "ED") - (rename-package (find-package "ED") "OLD-ED")) -;;; -(when (find-package "HI") - (rename-package (find-package "HI") "OLD-HI")) - - -;;; Stuff to set up the packages Hemlock uses. -;;; -(in-package "HEMLOCK-INTERNALS" - :nicknames '("HI") - :use '("LISP" "EXTENSIONS" "SYSTEM")) -;;; -(in-package "HEMLOCK" - :nicknames '("ED") - :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM")) -;;; -(in-package "SYSTEM") -(export '(%sp-byte-blt %sp-find-character %sp-find-character-with-attribute - %sp-reverse-find-character-with-attribute)) - -(in-package "HEMLOCK-INTERNALS") - - -(pushnew :command-bits *features*) -(pushnew :buffered-lines *features*) - -(defparameter the-log-file "hem:lossage.log") - -(when (probe-file the-log-file) - (delete-file the-log-file)) - -(defun cf (file) - (write-line file) - (finish-output nil) - (let ((*error-output* (open the-log-file - :direction :output - :if-exists :append - :if-does-not-exist :create))) - (unwind-protect - (progn - (compile-file file :error-file nil) - (terpri *error-output*) (terpri *error-output*)) - (close *error-output*)))) - -(cf "hem:struct.lisp") -(cf "hem:struct-ed.lisp") -(cf "hem:rompsite.lisp") -(cf "hem:charmacs.lisp") -;; keytran and keytrandefs used to be in rompsite, but they are too big now. -;; They also need to go after charmacs due to the funny characters named. -(cf "hem:keytran.lisp") -(cf "hem:keytrandefs.lisp") -(cf "hem:macros.lisp") -(cf "hem:line.lisp") -(cf "hem:ring.lisp") -(cf "hem:table.lisp") -(cf "hem:htext1.lisp") -(cf "hem:htext2.lisp") -(cf "hem:htext3.lisp") -(cf "hem:htext4.lisp") -(cf "hem:search1.lisp") -(cf "hem:search2.lisp") -(cf "hem:linimage.lisp") -(cf "hem:cursor.lisp") -(cf "hem:syntax.lisp") -(cf "hem:winimage.lisp") -(cf "hem:hunk-draw.lisp") -;(cf "hem:bit-stream.lisp") -(cf "hem:termcap.lisp") -(cf "hem:display.lisp") -(cf "hem:bit-display.lisp") -(cf "hem:tty-disp-rt.lisp") -(cf "hem:tty-display.lisp") -;(cf "hem:tty-stream.lisp") -(cf "hem:pop-up-stream.lisp") -(cf "hem:screen.lisp") -(cf "hem:bit-screen.lisp") -(cf "hem:tty-screen.lisp") -(cf "hem:window.lisp") -(cf "hem:font.lisp") -(cf "hem:interp.lisp") -(cf "hem:vars.lisp") -(cf "hem:buffer.lisp") -(cf "hem:files.lisp") -(cf "hem:streams.lisp") -(cf "hem:echo.lisp") -(cf "hem:main.lisp") -(cf "hem:echocoms.lisp") -(cf "hem:defsyn.lisp") -(cf "hem:command.lisp") -(cf "hem:morecoms.lisp") -(cf "hem:undo.lisp") -(cf "hem:killcoms.lisp") -(cf "hem:searchcoms.lisp") -(cf "hem:filecoms.lisp") -(cf "hem:indent.lisp") -(cf "hem:lispmode.lisp") -(cf "hem:comments.lisp") -(cf "hem:fill.lisp") -(cf "hem:text.lisp") -(cf "hem:doccoms.lisp") -(cf "hem:srccom.lisp") -(cf "hem:group.lisp") -(cf "hem:spell-rt.lisp") -(cf "hem:spell-corr.lisp") -(cf "hem:spell-aug.lisp") -(cf "hem:spell-build.lisp") -(cf "hem:spellcoms.lisp") -(cf "hem:abbrev.lisp") -(cf "hem:overwrite.lisp") -(cf "hem:gosmacs.lisp") -(cf "hem:ts-buf.lisp") -(cf "hem:ts-stream.lisp") -(cf "hem:eval-server.lisp") -(cf "hem:lispbuf.lisp") -(cf "hem:lispeval.lisp") -(cf "hem:kbdmac.lisp") -(cf "hem:icom.lisp") -(cf "hem:hi-integrity.lisp") -(cf "hem:ed-integrity.lisp") -(cf "hem:scribe.lisp") -(cf "hem:pascal.lisp") -(cf "hem:edit-defs.lisp") -(cf "hem:auto-save.lisp") -(cf "hem:register.lisp") -(cf "hem:xcoms.lisp") -(cf "hem:unixcoms.lisp") -(cf "hem:mh.lisp") -(cf "hem:highlight.lisp") -(cf "hem:dired.lisp") -(cf "hem:diredcoms.lisp") -(cf "hem:bufed.lisp") -(cf "hem:lisp-lib.lisp") -(cf "hem:completion.lisp") -(cf "hem:shell.lisp") -(cf "hem:bindings.lisp") diff --git a/tools/setup.lisp b/tools/setup.lisp deleted file mode 100644 index 405c6cda574969a87d98a09a549645181422ad12..0000000000000000000000000000000000000000 --- a/tools/setup.lisp +++ /dev/null @@ -1,317 +0,0 @@ -;;; -*- Package: USER -*- -;;; -;;; Set up package environment and search lists for compiler. Also some -;;; compilation utilities. -;;; -(in-package "USER") - -#+new-compiler -(proclaim '(optimize (debug-info 2))) - -(in-package "EXT") -(export '(debug *gc-verbose*)) - -(in-package "EVAL") -(export '(internal-eval interpreted-function-p - interpreted-function-lambda-expression - interpreted-function-closure - interpreted-function-name - interpreted-function-arglist - make-interpreted-function)) -#-new-compiler -(import '*eval-stack-top* (find-package "LISP")) - -#-new-compiler -(defmacro indirect-value (value-cell) - `(car ,value-cell)) - -#-new-compiler -(defmacro eval-stack-local (fp offset) - `(svref *eval-stack* (+ ,fp ,offset))) - - -#-new-compiler -(in-package "C" :use '("EXTENSIONS" "SYSTEM" "LISP")) - -#-new-compiler -(export '(compile-for-eval lambda-eval-info-frame-size - lambda-eval-info-args-passed lambda-eval-info-entries - entry-node-info-st-top entry-node-info-nlx-tag - *compile-time-define-macros*)) - -#-new-compiler -(setq clc::*peep-enable* t) -#-new-compiler -(setq clc::*inline-enable* t) -#-new-compiler -(setq ext:*safe-defstruct-accessors* nil) - -#-new-compiler -(import '(lisp::boolean lisp::enumeration)) - -;;; ### system patch... -#-new-compiler -(load "/../fred/usr/ram/hash.fasl") - -(defun zap-sym (name pkg) - (let ((found (find-symbol name (find-package pkg)))) - (when (and found - (eq (symbol-package found) (find-package pkg))) - (unintern found pkg)))) - -#-new-compiler -(progn - (zap-sym "ABORT" "C") - (zap-sym "CONCAT-PNAMES" "LISP") - (zap-sym "ARG" "LISP") - (zap-sym "VAR" "LISP") - (zap-sym "ONCE-ONLY" "COMPILER")) - -#-new-compiler -(let ((sym (find-symbol "%CHARACTER-TYPE" (find-package "SYSTEM")))) - (when sym - (makunbound sym) - (unintern sym (find-package "SYSTEM")))) - - -#-new-compiler -(in-package "EXTENSIONS") -#-new-compiler -(export '(info clear-info define-info-class define-info-type)) -#-new-compiler -(export '(ignorable truly-the maybe-inline)) - -#-new-compiler -(export '(lisp::with-compilation-unit lisp::debug-info) "LISP") - -#-new-compiler -(export '(system::%g-vector-structure-name-slot - system::find-if-in-closure - system::*file-input-handlers*) - "SYSTEM") - -#-new-compiler -(let ((found (find-symbol "CONCAT-PNAMES" (find-package "LISP")))) - (when found - (unintern found (find-package "LISP")))) - -#-new-compiler -(in-package "DEBUG") -#-new-compiler -(export '(var arg)) - - -(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::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 frame-debug-function - frame-code-location eval-in-frame return-from-frame frame-catches - frame-number frame frame-p - - do-blocks debug-function-lambda-list 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 - - do-debug-block-locations debug-block-successors debug-block - debug-block-p debug-block-elsewhere-p - - make-breakpoint activate-breakpoint deactivate-breakpoint - breakpoint-hook-function breakpoint-info breakpoint-kind - breakpoint-what breakpoint breakpoint-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 code-location-p - unknown-code-location unknown-code-location-p - - 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)) - - -#-new-compiler -(in-package "LISP") -#-new-compiler -(import '( - ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size - ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien - check<= check= %alien-indirect %bind-aligned-sap - naturalize-integer deport-integer naturalize-boolean deport-boolean - sap-ref-8 sap-ref-16 sap-ref-32 - signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 int-sap sap-int - %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32 - %set-alien-access %standard-char-p %string-char-p - - *alien-eval-when* make-alien alien-type alien-size alien-address - copy-alien dispose-alien defalien alien-value - alien-bind defoperator alien-index alien-indirect - bits bytes words long-words port perq-string - boolean defenumeration enumeration - system-area-pointer pointer alien alien-access - alien-assign alien-sap define-alien-stack - with-stack-alien null-terminated-string c-procedure - unstructured record-size - ) - (find-package "C")) - -(export 'function-lambda-expression) - -;;; Hack to prevent SETF from expanding these macros out of the environment, -;;; since these are functions in the new system. -;;; -#-new-compiler -(dolist (x '(sap-ref-8 sap-ref-16 sap-ref-32)) - (fmakunbound x)) - -(in-package "C") -(define-condition parse-unknown-type (condition) - (specifier)) - -(in-package "USER") - -;;; Hack until real definition exists: -;;; -#-new-compiler -(defmacro with-compilation-unit (glue &rest body) - (declare (ignore glue)) - `(let ((lisp::*in-compilation-unit* t)) - (declare (special lisp::*in-compilation-unit*)) - ,@body)) -;;; -;;; So the real WCU won't die in bootstrap env. -#-new-compiler -(defvar lisp::*in-compilation-unit* nil) -#-new-compiler -(defun c::print-summary (a b) - (declare (ignore a b))) - - -#-new-compiler -(setq lisp::*maximum-interpreter-error-checking* nil) - - -;;;; Compile utility: - -;;; Switches: -;;; -(defvar *interactive* nil) ; Batch compilation mode? -(defvar *new-compile* t) ; Use new compiler? - -(setq *bytes-consed-between-gcs* 1500000) - -(setq *gc-notify-before* - #'(lambda (&rest foo) - (cond (*interactive* - (apply #'lisp::default-gc-notify-before foo)) - (t - (write-char #\. *terminal-io*) - (force-output *terminal-io*))))) - -(setq *gc-notify-after* - #'(lambda (&rest foo) - (when *interactive* - (apply #'lisp::default-gc-notify-after foo)))) - - -(defvar *log-file* nil) -(defvar *last-file-position*) -(defvar *compiled-files* (make-hash-table :test #'equal)) - - -(defmacro with-compiler-log-file ((name) &body forms) - `(if *interactive* - (with-compilation-unit () - ,@forms) - (let ((*log-file* (open ,name :direction :output - :if-exists :append - :if-does-not-exist :create))) - (unwind-protect - (let ((*error-output* *log-file*) - (*last-file-position* (file-position *log-file*))) - (with-compilation-unit () - ,@forms)) - (close *log-file*))))) - - -(proclaim '(special lisp::*bootstrap-defmacro*)) - -(defun comf (name &key always-once proceed load output-file - ((:bootstrap-macros lisp::*bootstrap-defmacro*) nil)) - #+new-compiler - (declare (ignore always-once)) - (when (and *log-file* - (> (- (file-position *log-file*) *last-file-position*) 10000)) - (setq *last-file-position* (file-position *log-file*)) - (force-output *log-file*)) - - (let* ((src (pathname (concatenate 'string name ".lisp"))) - (obj (if output-file - (pathname output-file) - (make-pathname :defaults src - :type (if *new-compile* "nfasl" "fasl")))) - (compiler #+new-compiler #'compile-file - #-new-compiler (if *new-compile* - #'c::ncompile-file - #'compile-file)) - (obj-pn (probe-file obj))) - - (unless (and obj-pn - (>= (file-write-date obj-pn) (file-write-date src)) - #+nil - (equalp (pathname-directory - (lisp::sub-probe-file (first (search-list src)))) - (pathname-directory obj-pn)) - #-new-compiler - (or (gethash src *compiled-files*) - (not always-once))) - (write-line name) - (format *error-output* "~2&Start time: ~A, compiling ~A.~%" - (ext:format-universal-time nil (get-universal-time)) - name) - (cond - (*interactive* - (funcall compiler src :error-file nil :output-file obj) - (when load - (load name :verbose t))) - (t - (handler-bind ((error #'(lambda (condition) - (format *error-output* "~2&~A~2&" - condition) - (when proceed - (format *error-output* "Proceeding...~%") - (continue)) - (format *error-output* "Aborting...~%") - (handler-case - (let ((*debug-io* *error-output*)) - (debug:backtrace)) - (error (condition) - (declare (ignore condition)) - (format t "Error in backtrace!~%"))) - (format t "Error abort.~%") - (return-from comf)))) - (funcall compiler src :error-file nil :output-file obj) - (when load - (load name :verbose t))))) - (setf (gethash src *compiled-files*) t)) - - ;; Only set after compilation so that it can be bound around the call. - (setq lisp::*bootstrap-defmacro* nil))) diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp deleted file mode 100644 index 8e19dca68c0ce1f7f3961acc5a5fc5d2b1185843..0000000000000000000000000000000000000000 --- a/tools/worldcom.lisp +++ /dev/null @@ -1,138 +0,0 @@ -;;; -*- Package: User; Log: code.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). -;;; ********************************************************************** - -(in-package "USER") - -(c::%proclaim '(optimize (speed 2) (space 2) (c::brevity 2))) -(setq *print-pretty* nil) - -(with-compiler-log-file ("code:compile-lisp.log") - -;;; these guys need to be first. - -(comf "code:globals" :always-once t) ; For global variables. -(comf "code:struct" :always-once t) ; For structures. - -;;; these guys can supposedly come in any order, but not really. -;;; some are put at the end so macros don't run interpreted and stuff. - -(comf "code:serve-event") -(comf "code:lispinit") -(comf "code:error") -(comf "code:alieneval") -(comf "code:stream") -(comf "code:arith") -(comf "code:array") -(comf "code:backq") -(comf "code:c-call") -(comf "code:char") -(comf "code:list") -;(comf "code:clx-ext") -(comf "code:commandline") -(comf "code:eval") -(comf "code:debug-info") -(comf "code:debug-int") -(comf "code:debug") -(comf "code:trace") -(comf "code:extensions") -(comf "code:fd-stream") -(comf "code:fdefinition") -(comf "code:filesys") -(comf "code:format") -(comf "code:hash") -(comf "code:lfloatcon") -(comf "code:load") -(comf "code:miscop") -(comf "code:package") -(comf "code:rompstrops") -(comf "code:pred") -(comf "code:print") -(comf "code:provide") -(comf "code:query") -(comf "code:rand") -(comf "code:reader") -(comf "code:rompnum") -(comf "code:salterror") -(comf "code:save") -(comf "code:search-list") -(comf "code:seq") -(comf "code:sharpm") -(comf "code:sort") -(comf "code:type-boot") -(comf "code:run-program") -(comf "code:spirrat") -(comf "code:xp") -(comf "code:xp-patch") -(comf "code:pprint") -(comf "code:string") -(comf "code:subtypep") -(comf "code:symbol") -(comf "code:syscall") -(comf "code:sysmacs") -(comf "code:time") -(comf "code:foreign") -(comf "c:proclaim") -(comf "c:knownfun") - -;;; Later so that miscellaneous structures are defined (not crucial, but nice.) -(comf "code:describe") -;(comf "code:inspect") -(comf "code:tty-inspect") - -(comf "code:purify") -(comf "code:gc") -(comf "code:misc") -(comf "code:format-time") -(comf "code:parse-time") - -(comf "code:internet") -(comf "code:wire") -(comf "code:remote") - -(comf "assem:ropdefs") -(comf "assem:rompconst") -(comf "assem:disassemble") -#+new-compiler -(comf "assem:assem") -#+new-compiler -(comf "assem:assembler") - -(comf "code:machdef") -(comf "code:mmlispdefs") -(comf "icode:machdefs") -(comf "icode:netnamedefs") - -(let ((system:*alien-eval-when* '(compile eval))) - (unless (probe-file "icode:machuser.nfasl") - (load "icode:machmsgdefs.lisp") - (comf "icode:machuser")) - - (unless (probe-file "icode:netnameuser.nfasl") - (load "icode:netnamemsgdefs.lisp") - (comf "icode:netnameuser"))) - -(comf "code:constants") - -;;; Compile basic macros that we assume are already in the compilation -;;; environment. We inhibit compile-time definition to prevent these functions -;;; from becoming interpreted. In some cases, this is necessary for -;;; compilation to work at all, since the expander functions are lazily -;;; converted: we could go into an infinite recursion trying to convert the -;;; definition of a macro which uses itself. -;;; -(let ((c:*compile-time-define-macros* nil)) - (comf "code:defstruct") - (comf "code:defmacro") - (comf "code:macros") - (comf "code:defrecord") - - (comf "c:globaldb")) - -); with-compiler-log-file diff --git a/tools/worldload.lisp b/tools/worldload.lisp deleted file mode 100644 index bbf868902efccdcdafe8db5c1277647819fd7f8e..0000000000000000000000000000000000000000 --- a/tools/worldload.lisp +++ /dev/null @@ -1,169 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.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). -;;; ********************************************************************** -;;; -;;; This file loads the parts of the system that aren't cold loaded and saves -;;; the resulting core image. It writes "lisp.core" in the DEFAULT-DIRECTORY. -;;; - - -#| Can't eval conditionals now... -;;; Setup some packages. -;;; -(unless (eq *package* (find-package "USER")) - (error "Set *package* to the User package and try again.")) -|# - -(in-package "CLOS" :nicknames '("PCL")) -(in-package "USER" :use '("LISP" "EXTENSIONS" "CONDITIONS" "DEBUG" "CLOS")) -(in-package "HEMLOCK") -(in-package "LISP") -#| -;;; Must load this here, instead of before loading this file, otherwise -;;; SEARCH-LIST is unknown. -;;; -(load "/afs/cs/project/clisp/new-compiler/logical-names.lisp") -|# -;;; Get some data on this core. -;;; -(write-string "What is the current lisp-implementation-version? ") -(force-output) -(set '*lisp-implementation-version* (read-line)) -(write-string "What is the compiler version? ") -(force-output) -(set 'compiler-version (read-line)) -(write-string "What is the Hemlock version? ") -(force-output) -(set '*hemlock-version* (read-line)) - -;;; -;;; Keep us entertained... -(setq *load-verbose* t) - -(export 'ed) - -(load "code:lfloatcon") -(load "code:spirrat") -(load "code:foreign") -(load "code:format-time") -(load "code:parse-time") -;(load "code:xp-patch") -(load "assem:ropdefs") -(load "assem:rompconst") -(load "assem:disassemble") - - -(load "c:loadcom.lisp") - -(setq lisp::original-lisp-environment NIL) - - -;;; Load the symbol table information for the Lisp start up code. -;;; Used by CLX for the C routine to connect to the X11 server. -;;; -(load-foreign nil) - -;;; This has to occur after the call to LOAD-FOREIGN. -;;; -(load "code:run-program") - -#| -;;; CLX. -;;; -(load "clx:defsystem") -(load-clx (pathname "clx:")) - -;;; A hack to fix a bug in the X11 R3 server. This should go away when -;;; the server is fixed. -;;; -(load "/afs/cs/project/clisp/systems-work/font-patch") -|# - -;;; Stick these after LOAD-FORIEGN but before Hemlock. -;;; -(load "code:internet") -(load "code:wire") -(load "code:remote") - -#| -;;; Hemlock. -;;; -(load "hem:rompsite") ;Contains site-init stuff called at load time. -(load "hem:load-hem.lisp") -(hi::build-hemlock) - -;;; Setup definition editing defaults to look in the stable AFS directory. -;;; The first translation says what we want most clearly, but we require -;;; the others due to symbol links. -;;; -(ed::add-definition-dir-translation "/afs/cs/project/clisp/systems-work/" - "/afs/cs/project/clisp/systems/") -(ed::add-definition-dir-translation "/afs/cs/project/clisp-1/systems-work/" - "/afs/cs/project/clisp/systems/") -(ed::add-definition-dir-translation - "/afs/cs.cmu.edu/project/clisp-1/systems-work/" - "/afs/cs/project/clisp/systems/") -(ed::add-definition-dir-translation - "/afs/cs.cmu.edu/project/clisp/systems-work/" - "/afs/cs/project/clisp/systems/") - -;;; For some interim time, translate old compilation directories to the new -;;; working directories. Do it for symbolic links and actual paths. -;;; -(ed::add-definition-dir-translation "/usr/lisp/" - "/afs/cs/project/clisp/systems/") -(ed::add-definition-dir-translation "/usr1/lisp/" - "/afs/cs/project/clisp/systems/") -(ed::add-definition-dir-translation "/usr2/lisp/" - "/afs/cs/project/clisp/systems/") - - -;;; PCL. -;;; -(load "pcl:defsys") -(pcl::load-pcl) - -|# - -;;; Load these after PCL. -;;; -;(load "code:inspect") -(load "code:tty-inspect") - - -;;; There should be no search lists defined in a full core. -;;; -(clrhash lisp::*search-list-table*) - - -;;; Okay, build the thing! -;;; -(in-package "USER") -(progn - (setq + NIL) - (setq * NIL) - (setq ++ NIL) - (setq ** NIL) - (setq +++ NIL) - (setq *** NIL) - (setq *load-verbose* nil) - (setq *info-environment* - (list (make-info-environment :name "Working") - (compact-info-environment (car *info-environment*)))) - (save-lisp (namestring (merge-pathnames "lisp.core" (default-directory))) - :purify t - :root-structures `(ed - #|,hi::*global-command-table*|# - lisp::%top-level - extensions:save-lisp - ,lisp::fop-codes - compile-file) - :init-function #'(lambda () - (gc-on) - (abort))))