(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "PORTABLE-TOOLS" ( USE "LISP") ( NICKNAMES
"PT") ( PREFIX-NAME "PT")) BASE 10)
(il:filecreated " 8-Jan-89 18:56:15" il:{qv}<idl>next>portable-xcl-tools.\;11 11777
il:|changes| il:|to:| (il:vars il:portable-xcl-toolscoms) (il:functions make-keyword)
il:|previous| il:|date:| " 4-Dec-88 17:43:45" il:{qv}<idl>next>portable-xcl-tools.\;10)
; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:portable-xcl-toolscoms)
(il:rpaqq il:portable-xcl-toolscoms ((il:coms (il:* il:|;;| " GC invokes garbage collection") (il:functions gc)) (il:coms (il:* il:|;;| "Fast equality tests for fixnums") (il:functions fixnum-eq fixnum-assoc fixnum-member)) (il:coms (il:* il:|;;| "Eq search primitives") (il:functions memq assq)) (il:coms (il:* il:|;;| "Collection primitives") (il:functions with-collection collect)) (il:coms (il:* il:|;;| "destructuring-bind") (il:functions destructuring-bind) (il:sedit-formats destructuring-bind)) (il:coms (il:* il:|;;| "Once only") (il:functions once-only move-definition listify)) (il:coms (il:* il:|;;| "Convenience constructors") (il:functions make-vector copy-array fill-array) (il:functions make-keyword)) (il:coms (il:* il:|;;| "X pointer types") (il:types xpointer full-xpointer)) (il:coms (il:* il:|;;| "Binary I/O primitives") (il:functions read-word write-word read-pointer write-pointer skip-bytes)) (il:coms (il:* il:|;;| "Text I/O") (il:variables *default-buffer-size*) (il:functions make-string-buffer) (il:coms (il:* il:|;;| "Fast-read-line for ascii files") (il:functions cl::%array-base cl::%array-offset) (il:functions fast-read-line fast-read-string)) (il:coms (il:* il:|;;| "String pointers") (il:declare\: il:dontcopy il:doeval@compile il:donteval@load (il:files il:cmlarray-support)) (il:functions make-string-pointer adjust-string-pointer)) (il:coms (il:* il:|;;| "load-files") (il:variables *default-pathname*) (il:functions load-files))) (il:declare\: il:docopy il:donteval@load (il:p (export (quote (gc fixnum-eq fixnum-assoc fixnum-member memq assq with-collection collect destructuring-bind once-only move-definition listify make-vector copy-array fill-array make-keyword xpointer full-xpointer read-word write-word read-pointer write-pointer skip-bytes *default-buffer-size* make-string-buffer fast-read-line fast-read-string make-string-pointer adjust-string-pointer *default-pathname* load-files)) (find-package "PT")))) (xcl:file-environments "PORTABLE-XCL-TOOLS")))
(il:* il:|;;| " GC invokes garbage collection")
(defmacro gc nil (il:bquote (il:reclaim)))
(il:* il:|;;| "Fast equality tests for fixnums")
(defmacro fixnum-eq (x y) (il:bquote (eq (il:\\\, x) (il:\\\, y))))
(defmacro fixnum-assoc (key alist) (il:bquote (assoc (il:\\\, key) (il:\\\, alist) :test (function eq))))
(defmacro fixnum-member (key list) (il:bquote (member (il:\\\, key) (il:\\\, list) :test (function eq))))
(il:* il:|;;| "Eq search primitives")
(defmacro memq (item lst) (il:bquote (member (il:\\\, item) (il:\\\, lst) :test (function eq))))
(defmacro assq (key alist) (il:bquote (assoc (il:\\\, key) (il:\\\, alist) :test (function eq))))
(il:* il:|;;| "Collection primitives")
(defmacro with-collection (&body body) (il:bquote (xcl:with-collection (il:\\\,@ body))))
(defmacro collect (form) (il:bquote (xcl:collect (il:\\\, form))))
(il:* il:|;;| "destructuring-bind")
(defmacro destructuring-bind (bind-pattern value &body body) (il:bquote (xcl:destructuring-bind (il:\\\, bind-pattern) (il:\\\, value) (il:\\\,@ body))))
(sedit:def-list-format destructuring-bind :indent (1 1) :args (:keyword :lambda-list nil) :inline nil)
(il:* il:|;;| "Once only")
(defmacro once-only (vars &body body) (il:bquote (xcl:once-only (il:\\\, vars) (il:\\\,@ body))))
(defmacro move-definition (fn1 fn2) (il:bquote (il:movd (quote (il:\\\, fn1)) (quote (il:\\\, fn2)))))
(defmacro listify (x) (once-only (x) (il:bquote (if (listp (il:\\\, x)) (il:\\\, x) (list (il:\\\, x))))))
(il:* il:|;;| "Convenience constructors")
(defmacro make-vector (length &optional type initial-value) (il:bquote (xcl:make-vector (il:\\\, length) (il:\\\,@ (if (or type initial-value) (il:bquote ((il:\\\, type))))) (il:\\\,@ (if initial-value (il:bquote ((il:\\\, initial-value))))))))
(defmacro copy-array (from to) (il:bquote (xcl:copy-array (il:\\\, from) (il:\\\, to))))
(defmacro fill-array (array value) (il:bquote (xcl:fill-array (il:\\\, array) (il:\\\, value))))
(defun make-keyword (symbol) (intern (string symbol) (find-package "KEYWORD")))
(il:* il:|;;| "X pointer types")
(deftype xpointer (&optional ignore) (declare (ignore ignore)) (quote il:xpointer))
(deftype full-xpointer (&optional ignore) (declare (ignore ignore)) (quote il:fullxpointer))
(il:* il:|;;| "Binary I/O primitives")
(defun read-word (stream &optional position) (when position (file-position stream position)) (+ (il:llsh (il:\\bin stream) 8) (il:\\bin stream)))
(defun write-word (word stream &optional position) (when position (file-position stream position)) (il:\\bout stream (ldb (byte 8 8) word)) (il:\\bout stream (ldb (byte 8 0) word)) (il:* il:|;;| "return WORD") word)
(defun read-pointer (stream &optional position) (when position (file-position stream position)) (let ((value 0)) (dotimes (i 4) (setq value (+ (il:llsh value 8) (il:\\bin stream)))) value))
(defun write-pointer (pointer stream &optional position) (when position (file-position stream position)) (let ((length (integer-length pointer))) (il:\\bout stream (if (> length 24) (ldb (byte 8 24) pointer) 0)) (il:\\bout stream (if (> length 16) (ldb (byte 8 16) pointer) 0)) (il:\\bout stream (if (> length 8) (ldb (byte 8 8) pointer) 0)) (il:\\bout stream (ldb (byte 8 0) pointer))) (il:* il:|;;| "return POINTER") pointer)
(defun skip-bytes (stream number-bytes) (dotimes (i number-bytes) (il:\\bin stream)))
(il:* il:|;;| "Text I/O")
(defparameter *default-buffer-size* 10)
(defun make-string-buffer (&optional (size *default-buffer-size*)) (make-array size :element-type (quote string-char) :extendable t :fill-pointer 0))
(il:* il:|;;| "Fast-read-line for ascii files")
(defmacro cl::%array-base (array) (il:bquote (il:%array-base (il:\\\, array))))
(defmacro cl::%array-offset (array) (il:bquote (il:%array-offset (il:\\\, array))))
(defun fast-read-line (stream &optional (buffer (make-array *default-buffer-size* :element-type (quote string-char) :extendable t :fill-pointer 0)) case) (il:* il:|;;| "Like read-line but uses the buffer provided (should be an extendable string-char (thin, 8bit string) array with zero offset and fill-pointer). Assumes ASCII characters only.") (let ((eof-marker (- (file-length stream) (file-position stream))) (c-code nil) (array-size (array-total-size buffer)) (array-base (cl::%array-base buffer)) (i 0) (case-spread (- (char-code #\a) (char-code #\A)))) (loop (when (or (eq i eof-marker) (eq (setq c-code (il:\\bin stream)) (char-code #\Newline))) (setf (fill-pointer buffer) i) (return buffer)) (ecase case ((nil) nil) (:downcase (if (<= (char-code #\A) c-code (char-code #\Z)) (incf c-code case-spread))) (:upcase (if (<= (char-code #\a) c-code (char-code #\z)) (decf c-code case-spread)))) (il:\\putbasebyte array-base i c-code) (setq i (1+ i)) (when (eq i array-size) (il:* il:|;;| "extend buffer") (adjust-array buffer (truncate (* 1.5 array-size)) :element-type (quote string-char)) (setq array-size (array-total-size buffer)) (setq array-base (cl::%array-base buffer))))))
(defun fast-read-string (stream position length &optional (buffer (make-array *default-buffer-size* :element-type (quote string-char) :extendable t :fill-pointer 0)) case) (il:* il:|;;| "Like read-line but uses the buffer provided (should be an extendable string-char (thin, 8bit string) array with zero offset and fill-pointer)") (file-position stream position) (let ((eof-marker (- (file-length stream) position)) (c-code nil) (array-size (array-total-size buffer)) (array-base (cl::%array-base buffer)) (i 0) (case-spread (- (char-code #\a) (char-code #\A)))) (loop (when (or (eq i eof-marker) (eq i length)) (setf (fill-pointer buffer) i) (return buffer)) (setq c-code (il:\\bin stream)) (ecase case ((nil) nil) (:downcase (if (<= (char-code #\A) c-code (char-code #\Z)) (incf c-code case-spread))) (:upcase (if (<= (char-code #\a) c-code (char-code #\z)) (decf c-code case-spread)))) (il:\\putbasebyte array-base i c-code) (setq i (1+ i)) (when (eq i array-size) (il:* il:|;;| "extend buffer") (adjust-array buffer (truncate (* 1.5 array-size)) :element-type (quote string-char)) (setq array-size (array-total-size buffer)) (setq array-base (cl::%array-base buffer))))))
(il:* il:|;;| "String pointers")
(il:declare\: il:dontcopy il:doeval@compile il:donteval@load
(il:filesload il:cmlarray-support)
)
(defun make-string-pointer (string &optional (start 0) (end (length string))) (il:* il:|;;| "Make a vector offset into string. Start and end are relative to array-offset. ") (let ((size (- end start))) (if (> size (array-total-size string)) (error "Size out of bounds: ~s" size)) (il:%make-oned-array size (quote string-char) nil (il:%fat-string-array-p string) nil nil (cl::%array-base string) (+ (cl::%array-offset string) start))))
(defun adjust-string-pointer (pointer string start end) (il:* il:|;;| "Adjusts POINTER to be the substring of STRING between START and END. START and END are relative to the array-offset of STRING.") (if (not (eq (cl::%array-base pointer) (cl::%array-base string))) (error "~s does not point to ~s" pointer string)) (let ((size (- end start))) (if (> size (array-total-size string)) (error "Size out of bounds: ~s" size)) (il:uninterruptably (il:replace (il:array-header il:offset) il:of pointer il:with (+ (cl::%array-offset string) start)) (il:replace (il:array-header il:fill-pointer) il:of pointer il:with size) (il:replace (il:array-header il:total-size) il:of pointer il:with size)) pointer))
(il:* il:|;;| "load-files")
(defvar *default-pathname* nil)
(defun load-files (file-lst &key (from *default-pathname*) (how :sysload)) (if from (let ((directory (make-pathname :host (pathname-host from) :device (pathname-device from) :directory (pathname-directory from)))) (if (or (eq how :source) (eq how :prop)) (dolist (f file-lst) (let ((file (merge-pathnames f directory))) (if (probe-file file) (il:load file (quote il:prop)) (warn "File ~s does not exist~%" (namestring file))))) (let ((extensions (mapcar (function (lambda (ext) (merge-pathnames directory (make-pathname :type ext)))) (quote ("DFASL" "LCOM"))))) (dolist (f file-lst) (unless (dolist (extension extensions) (let ((file (merge-pathnames f extension))) (when (probe-file file) (load file :loadflg how) (return t)))) (warn "File ~s does not exist~%" (namestring (merge-pathnames directory f)))))))) (warn "FROM not supplied~%")))
(il:declare\: il:docopy il:donteval@load
(export (quote (gc fixnum-eq fixnum-assoc fixnum-member memq assq with-collection collect destructuring-bind once-only move-definition listify make-vector copy-array fill-array make-keyword xpointer full-xpointer read-word write-word read-pointer write-pointer skip-bytes *default-buffer-size* make-string-buffer fast-read-line fast-read-string make-string-pointer adjust-string-pointer *default-pathname* load-files)) (find-package "PT"))
)
(xcl:define-file-environment "PORTABLE-XCL-TOOLS" :package (xcl:defpackage "PORTABLE-TOOLS" (:use "LISP") (:nicknames "PT") (:prefix-name "PT")) :readtable "XCL" :base 10 :compiler :compile-file)
(il:putprops il:portable-xcl-tools il:copyright ("Xerox Corporation" 1988 1989))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop