;;; -*- Mode: LISP; Mode: paredit; Package: :USER; BASE: 10; Syntax: ANSI-Common-Lisp; ;-*- ;;; ;;; Personal CMUCL configuration file ;;; (C) 2004-2009 Madhu . All Rights Reserved. ;;; Status: Experimental. DO NOT REDISTRIBUTE ;;; ;;; Time-stamp: <2009-09-24 16:01:50 IST> ;;; Touched: Wed Dec 19 11:22:21 2001 ;;; (in-package "CL-USER") #+cmu (eval-when (:compile-toplevel) (setq c::top-level-lambda-max 0)) #+cmu (case (c:backend-fasl-file-version c:*target-backend*) (#x19a) (#x19c) (#x19d) (#x19e) (#x19f) (#x20a) (t (cerror "Continue." "Which version of CMUCL?"))) #+scl (case (c:backend-fasl-file-version c:*target-backend*) (16910848 ) ; 1.2.10 (16910592 ) ; 1.2.9.1 (16911104 ) ; 1.2.11 (t (cerror "Continue." "Which version of SCL?"))) #+(and nil cmu) (let* ((foo (with-output-to-string (str) (funcall (sixth (GETF *HERALD-ITEMS* :COMMON-LISP)) str))) (core (subseq foo 11 (position #\Newline foo))) (core-path (truename LISP::*CMUCL-CORE-PATH*)) (lisp-path (truename LISP::*COMMAND-LINE-UTILITY-NAME*))) (assert (equal core-path (truename core))) (warn "(core core-path lisp-path) = ~S" (list core core-path lisp-path))) ;;; ---------------------------------------------------------------------- ;;; ;;; PATHNAME UTILS - PORTABLE ;;; ;;; (defun pathname-to-list (pathname) "PATHNAME is an absolute pathname. Return a new list of string components. If PATHNAME is a file, the last element will be the file-namestring of PATHNAME. Otherwise it will be last directory component" (declare (type pathname pathname)) (let ((components (pathname-directory pathname)) (name (file-namestring pathname))) (assert (eq (pop components) :absolute)) (append components (if name (if (string/= name "") (list name)))))) (defun within-directory-p (target directory) "Return NON-NIL if TARGET is contained within DIRECTORY. TARGET and DIRECTORY are absolute pathnames." (let* ((dir (pathname-to-list target)) (dlen (length dir)) (parent (pathname-to-list directory)) (plen (length parent))) (unless (> plen dlen) ;;madhu: XXX case (not (mismatch parent (butlast dir (- dlen plen)) :test #'string-equal))))) (defun wildify (root &rest components) "COMPONENTS are directory components. Returns a WILD PATHNAME" (merge-pathnames (make-pathname :name :wild :type :wild :version :wild :directory (append '(:relative) components) :host nil) root nil)) #+nil (directory (wildify (user-homedir-pathname))) (defun directory-pathname (p) "Return a directory pathname with NULL name version and type components." (let ((n (file-namestring p))) (cond (n (make-pathname :name nil :type nil :version nil :directory (append (pathname-directory p) (list n)) :defaults p)) (T (pathname p))))) (defun define-default-logical-pathname-translations (host directory) (let ((translations (list (list "*.*.*" (wildify directory)) (list "**;*.*.*" (wildify directory :wild-inferiors)))) (original-translations (ignore-errors (logical-pathname-translations host)))) (if original-translations (if (equalp original-translations translations) (return-from define-default-logical-pathname-translations nil) (cerror "Change." "Translations defined for host ~A:~&~S New Translations: ~A~&" host original-translations translations))) (format t "~&Setting up translation for ~S: ~S.~%" host translations) (setf (logical-pathname-translations host) translations))) (export '(pathname-to-list within-directory-p wildify directory-pathname define-default-logical-pathname-translations)) ;;; ---------------------------------------------------------------------- ;;; ;;; SEARCHLIST SHENNANIGANS (CMUCL) ;;; ;;; #+cmu (progn (defun setup-search-lists-unpacked (cmudir) "Set up search lists for library: modules: and target: when running a cmucl distribution from an unpacked location at CMUDIR. The lisp binary is usually at CMUDIR/bin/lisp." (setf (ext:search-list "trunk:") (list (truename cmudir)) (ext:search-list "library:") '(#P"trunk:lib/cmucl/lib/" #P"trunk:lib/") (ext:search-list "modules:") '(#P"library:subsystems/") (ext:search-list "target:") '(#P"trunk:/src/")) T) (defun setup-search-lists-compiled (cmudir targetname) " TARGETNAME is a string denoting the directory component of the target. Set up search lists for library: modules:: when running a cmucl distribution from an compiled location based on the target: search path. The lisp binary is usually at target:/lisp/lisp." (setf (ext:search-list "trunk:") (list (truename cmudir)) (ext:search-list "target:") (mapcar (lambda (x) (pathname (concatenate 'string "trunk:" x "/"))) (list "src" targetname)) (ext:search-list "modules:") (list "target:pcl/" "target:clx/" "target:hemlock/" "target:interface/") (ext:search-list "library:") (list "target:/motif/server/" "target:hemlock/") (ext:search-list "ext-formats:") (list "target:pcl/simple-streams/external-formats/")) T) (defun show-search-lists () (loop for path being each hash-key in LISP::*SEARCH-LISTS* using (hash-value sl) for x = (concatenate 'string path ":") when (LISP::SEARCH-LIST-DEFINED sl) ;; NOTE: cannot use (ext:search-list-defined-p x) here because ;; it errors out when x names a logical pathname do (format t "~T~A~T~T~T~S~&" x (ext:search-list x)) and collect (cons path (mapcar #'(lambda (directory) (make-pathname :host (pathname-host "") :directory (cons :absolute directory))) (lisp::search-list-expansions sl))) else collect path into undefined initially (format t "~&Defined *SEARCH-LISTS*:~%") finally (format t "~%Undefined *SEARCH-LISTS*:~%~T ~S." undefined))) #+nil (setup-search-lists-unpacked "/usr/local/") #-rhea (setup-search-lists-compiled "home:cmu/" "glibc22") #+rhea (setup-search-lists-unpacked "home:scratch/cmucl/") ;;; ;;; (unless (ext:search-list-defined-p "fasl:") (setf (ext:search-list "fasl:") (list #-rhea #p"/var/local/fasl/" #+rhea #p"/scratch/madhu/fasl/" ))) ;;; ;;; ;;; (defmacro nconcf (list lists) "NCONCS LISTS to the place denoted by the form LIST." `(setf ,list (nconc ,list ,lists))) (defun add-to-search-list (search-host &rest paths) (dolist (dir paths) (unless (find dir (ext:search-list search-host) :test #'equal) (nconcf (ext:search-list search-host) (list dir))))) (defmacro with-added-paths ((&rest paths) &body body) "Execute BODY in an environment where the paths: search list is modified temporarily to include given PATHS." `(let ((list (ext:search-list "path:"))) (unwind-protect (progn (setf (ext:search-list "path:") (append ',paths list)) ,@body) (setf (ext:search-list "path:") list)))) (export '(with-added-paths add-to-search-list))) ;;; ---------------------------------------------------------------------- ;;; ;;; (defvar *log-ignored-errors* t) (defun maybe-log-ignored-errors (c) (case *log-ignored-errors* ((t) (format t "~&IGNORING-ERROR:") (etypecase c (simple-condition (apply 'format t (simple-condition-format-control c) (simple-condition-format-arguments c))) (error (format t "~S" c))) (format t "~&")) ((:break) (with-simple-restart (continue "IGNORING-ERRORS: Continue from BREAK.") (error c))))) (defmacro ignoring-errors (&body form) `(handler-case (progn ,@form) (error (c) (maybe-log-ignored-errors c)))) (defmacro continuing-from-errors ((&rest condition-types) &body body) "CONDITION-TYPES is a list of CONDITION-MATCHERs which specify the conditions which we handle by invoking the CONTINUE restart automatically. If CONDITION-TYPES is NIL, include ERROR. To disable handling any conditions, use CONDITION-TYPE (:NONE). condition-types = (condition-matcher*); condition-matcher = condition-type | (condition-type fmt*); A CONDITION-TYPE is a symbol denoting a condition. FMT is a string which is tested against the SIMPLE-CONDITION-FORMAT-CONTROL of the condition being handled: we continue from the error only if there is a prefix match. If multiple FMT strings are supplied, we continue from the error if any one of them match." (cond ((endp condition-types) (setq condition-types '(error))) (t (setq condition-types (remove :none condition-types)))) (let ((handlers (loop for elem in condition-types for (x test) = (cond ((consp elem) (check-type (car elem) symbol "Expect a symbol denoting a conditon.") (list (car elem) (if (endp (cdr elem)) t `(or ,@(loop for x in (cdr elem) do (check-type x string "Expect a format control string.") collect `(prefixp ,x (simple-condition-format-control x))))))) (t (list elem t))) collect `(,x (lambda (x &aux r) (when ,test (when (setq r (find-restart 'continue x)) (maybe-log-ignored-errors x) (format t "Invoking restart ~S~&" r) (invoke-restart r)))))))) `(handler-bind ,handlers ,@body))) #+nil (continuing-from-errors ((error "Redefining class ~S incompatibly with the current")) (defstruct foo a b c) (defstruct foo a b c d)) ;;; ---------------------------------------------------------------------- ;;; ;;; BINARY-DIRECTORY. (LC-LITE) (progn (defvar *binary-directory-fasl-root* "fasl:" "Root Directory of fasl files.") ;XXX (defvar *binary-directory-pattern* (or #+scl (list "binary-scl") #+cmu (list "binary-cmucl") #+lispworks (list "binary-lispworks") #+allegro (list "binary-allegro") #+clisp (list "binary-clisp") #+sbcl (list "binary-sbcl") (cerror "Continue" "Unknown implementation.")) "List of strings denoting directory components under fasl root.") (defvar *binary-directory-version* (or #+scl (list (let* ((backend (c:backend-name c:*target-backend*)) (version (c:backend-fasl-file-version c:*target-backend*))) (format nil "scl-~A-~D.~D.~D.~D" backend (ldb (byte 8 24) version) (ldb (byte 8 16) version) (ldb (byte 8 8) version) (ldb (byte 8 0) version)))) #+(and nil cmu) (list (format nil "~(~x~)" (c:backend-fasl-file-version c:*target-backend*))) (list (lisp-implementation-version))) "List of strings denoting directory components under implementation's fasl root.") (defun binary-directory (pathname &rest dirnames) (when (or #+allegro (excl::logical-pathname-p (pathname pathname)) #+(or clisp lispworks) (system::logical-pathname-p (pathname pathname)) #+cmu (LISP::LOGICAL-PATHNAME-P (pathname pathname))) (setq pathname (translate-logical-pathname pathname))) (let* ((pathname-directory (pathname-directory pathname)) (last (if (endp (cdr pathname-directory)) nil (last pathname-directory)))) #+cmu (when (lisp::search-list-p (car last)) ;handle "host:/skt.lisp" (assert (lisp::search-list-defined (cadr pathname-directory))) (setq last nil)) (let ((p (make-pathname :name nil :type nil :version nil :directory (append (pathname-directory *binary-directory-fasl-root*) last *binary-directory-pattern* dirnames *binary-directory-version*)))) p))) (defvar *binary-directory-ensure-directories-exist* t) (defvar *binary-directory-source-file-types* '("lisp" "l" "cl" "lsp")) (defun lc (pathname &key library-p force (source-directory *default-pathname-defaults*) (source-file-types *binary-directory-source-file-types*) (create-directories *binary-directory-ensure-directories-exist*) binary-directory dry-run) "Compile and load pathnanme. CREATE-DIRECTORIES has no effect during DRY-RUN." (prog* ((*default-pathname-defaults* source-directory) (source-truename (or (probe-file pathname) (when (null (pathname-type pathname)) (some (lambda (source-file-type) (probe-file (make-pathname :type source-file-type :defaults pathname))) source-file-types)))) (binary-directory (or binary-directory (and source-truename (binary-directory source-truename)) (binary-directory pathname))) (fasl (let ((purported-fasl (compile-file-pathname (or source-truename pathname)))) (make-pathname :name (if library-p (concatenate 'string (pathname-name purported-fasl) "-library") (pathname-name purported-fasl)) :version (pathname-version purported-fasl) :type (pathname-type purported-fasl) :defaults binary-directory)))) (if dry-run (return (values fasl source-truename))) retry (unless source-truename (error "Could not find source file: ~A" pathname)) (if create-directories (ensure-directories-exist fasl)) (when (or force (< (or (handler-case (file-write-date fasl) (error (e) (format t "Error: file-write-date: ~A: ~A." fasl e) 0)) 0) (file-write-date source-truename))) (print (list 'compile-file source-truename :output-file fasl)) (multiple-value-bind (output-truename warnings-p failure-p) (compile-file source-truename :output-file fasl) (if failure-p ;XXX (format t "LC: compile-file returned: ~A." (list output-truename warnings-p failure-p)) (assert (equal (truename fasl) (truename output-truename)))))) (print (list 'load fasl)) load-fasl (restart-case (load fasl) (delete-fasl-and-retry () :report (lambda (stream) (format stream "Delete ~A and retry compilation." fasl)) :test (lambda (condition) (declare (ignore condition)) (probe-file fasl)) (delete-file fasl) (go retry))))) (setf (symbol-function 'lc-lite) #'lc) (export '(binary-directory lc))) #+cmu (defun crumple (source-pathname &key (source-file-type "c") (object-file-type "so") (cc "/usr/local/bin/gcc") (cflags (list "-g" "-shared")) (force nil) &aux (path (truename source-pathname))) "[Compile and] load C file." (assert (string= source-file-type (pathname-type path))) (let ((obj (let ((cfp (compile-file-pathname path))) ; hack! (make-pathname :name (pathname-name cfp) :type object-file-type :defaults cfp))) p) (when (or force (< (or (file-write-date obj) 0) (or (file-write-date path) (file-write-date (setq p (make-pathname :type source-file-type :defaults path))) (error "couldn't find given ~S or ~S." path p)))) (ext:run-program cc (append cflags (list "-o" (namestring obj)))) #+cmu (ext:load-foreign obj) #+lispworks (fli:register-module obj) #+allegro (load obj)))) ;;; ---------------------------------------------------------------------- ;;; ;;; #+cmu (progn (assert (eq 'unix-namestring 'unix::unix-namestring)) (export '(unix-namestring))) #+allegro (progn (defun unix-namestring (pathname) (excl::unix-namestring pathname)) (export '(unix-namestring))) #+lispworks (progn (defun unix-namestring (pathname) (system::os-namestring pathname)) (export '(unix-namestring))) ;; FIXME: CONFORM ON RETURN VALUE OF UNIX-TRUNCATE ;madhu 080829 #+cmu (progn (defun unix-truncate (name length) (unix:unix-truncate name length)) (export '(unix-truncate))) #+allegro (progn (defun unix-truncate (name length) (excl.osi:os-truncate name length)) (export '(unix-truncate))) #+(and lispworks unix) (progn (fli:define-foreign-function (unix-truncate "truncate" :source) ((path (:reference-pass :ef-mb-string)) (offset :int)) :result-type :int) (export '(unix-truncate))) #+(and lispworks unix) (defun perror (fmt &rest args) (let ((errno (lw::errno-value))) (funcall 'error "~?: ~A(~D).~&" fmt args (lw:get-unix-error errno) errno))) ;;; ---------------------------------------------------------------------- ;;; ;;; CLI ;;; #+allegro (defun quit () (excl:exit)) #+(or scl cmu clisp) (defun pwd () (ext:default-directory)) #+lispworks (defun pwd nil (HCL::get-working-directory)) #+allegro (defun pwd () (excl::current-directory)) #+allegro (defun cd (&optional directory) (excl::chdir (or directory (user-homedir-pathname)))) #+clisp (defvar *original-cd* #'ext:cd) #+clisp (defun user::cd (&optional directory) (funcall *original-cd* (or directory (user-homedir-pathname)))) ;; lispworks cd macro accepts symbols as a directory designator and so can't ;; be used in macros. #+lispworks (eval-when (load eval compile) (shadow 'cd)) #+lispworks (defun cd (&optional directory) (change-directory (or directory (user-homedir-pathname)))) #+(or cmu scl) (defun cd (&optional (gross-dir (unix-namestring (car (ext:search-list "home:"))))) (and (pathnamep gross-dir) (setq gross-dir (unix-namestring gross-dir))) (when (/= (length gross-dir) 0) (if (char= (char gross-dir 0) #\~) (let ((p (position #\/ gross-dir))) (unless (or (null p) (= p 1)) (warn "~~unimplemented/")) (when p (cd) (cd (subseq gross-dir (1+ p))))) (unix:unix-chdir gross-dir))) (pwd)) #+cmu (defun ps () (mp::show-processes)) #+(or cmu scl) (defun delete-directory (path) (unix:unix-rmdir (unix::unix-namestring path))) (let ((dirstack nil)) (defun pushd (&optional dir n) ; TODO (push (pwd) dirstack) (if dir (cd dir) (cd))) (defun popd (&optional n) (cd (pop dirstack)))) #+nil ;TODO (export '(pwd cd ps delete-directory pushd popd)) ;;; ;;; ;;; (defmacro in-directory (directory &body forms) (let ((cwd (gensym))) `(let ((,cwd (pwd)) #+allegro (*default-pathname-defaults* #p"")) (unwind-protect (progn (cd ,directory) ,@forms) (cd ,cwd))))) (export '(in-directory)) ;;; ---------------------------------------------------------------------- ;;; ;;; ENVIRONMENT VARIABLES: (GETENV SETENV) ;;; #+cmu (progn (alien:def-alien-routine ("getenv" unix-getenv) c-call:c-string (name c-call:c-string)) (alien:def-alien-routine ("setenv" unix-setenv) c-call:int (name c-call:c-string) (value c-call:c-string) (overwrite c-call:int)) (alien:def-alien-routine ("unsetenv" unix-unsetenv) c-call:void (name c-call:c-string)) (defun getenv (var) (cdr (assoc (intern var "KEYWORD") ext:*environment-list*))) (defun setenv (var value) (let* ((item (intern var "KEYWORD")) (cons (assoc item ext:*environment-list*))) (cond (cons (setf (cdr cons) value)) (t (setq cons (cons item value)) (push cons ext:*environment-list*) value)))) (export '(unix-getenv unix-setenv unix-unsetenv))) #+lispworks (eval-when (load eval compile) (shadow '(getenv setenv))) #+lispworks (progn (defun getenv (x) (environment-variable x)) (defun setenv (x v) (setf (environment-variable x) v))) #+clisp (eval-when (load eval compile) ;FIXME: CLISP gets it right (mapcar 'unintern '(cl-user::getenv cl-user::setenv)) (shadow '(getenv setenv))) #+clisp (progn (defun getenv (x) (ext:getenv x)) (defun setenv (x v) (setf (ext:getenv x) v))) #+allegro (progn (defun getenv (x) (sys:getenv x)) (defun setenv (x v) (if v (setf (sys:getenv x) v) (excl.osi:unsetenv x)))) (defsetf getenv (var) (value) `(setenv ,var ,value)) (export '(getenv setenv)) ;;; ---------------------------------------------------------------------- ;;; ;;; ENVIRONMENT VAR UTILS - PORTABLE ;;; (defmacro with-env-vars ((&rest bindings) &body body) (loop for (var env-val) in bindings for x = (gensym) for env-var = (etypecase var (keyword (symbol-name var)) (string var)) collect `(,x (getenv ,env-var)) into old-bindings collect `(setenv ,env-var ,env-val) into do-forms collect `(setenv ,env-var ,x) into undo-forms finally (return `(let ,old-bindings (unwind-protect (progn ,@do-forms ,@body) ,@undo-forms))))) (defun add-to-env (env item &optional (separator (or #+unix ":" #+mswindows ";" ":")) at-beginning-p &key (test #'string-equal) force) "ENV is a string environment variable. Appends string ITEM to the expansion of ENV seperated by SEPARATOR. If AT-BEGINNING-P is non-NIL prepend it. NOTE ITEM is not added if it is already present. Use FORCE in addition to AT-BEGINNING-P to prepend a string even if it is present in the expansion, but not at the beginning." (let ((old (getenv env))) (assert (stringp old) nil "Env variable ~S isnt defined: ~S." env old) (let ((pos (search item old :test test))) (cond (at-beginning-p (when (or (null pos) (and force (not (zerop pos)))) (setenv env (concatenate 'string item separator old)))) (t (unless pos (setenv env (concatenate 'string old separator item)))))))) (export '(add-to-env with-env-vars)) #|| (user:getenv "SHELL") (user:getenv "PATH") (user:add-to-env "PATH" "c:/msys/1.0/bin") (user:getenv "FOO") (progn (user:setenv "FOO" "BAR;CAR") (assert (string= (user:getenv "FOO") "BAR;CAR")) (user:add-to-env "FOO" "VAR" ";") (assert (string= (user:getenv "FOO") "BAR;CAR;VAR")) (user:add-to-env "FOO" "VAR" ";" t) (assert (string= (user:getenv "FOO") "BAR;CAR;VAR")) (user:add-to-env "FOO" "TAR" ";" t) (assert (string= (user:getenv "FOO") "TAR;BAR;CAR;VAR")) (user:setenv "FOO" nil)) (with-env-vars ((:GIT_COMMITTER_DATE "TIMESTAMP") (:GIT_AUTHOR_DATE "timestamp")) '*environment-list*) ||# ;;; ---------------------------------------------------------------------- ;;; ;;; DATE TIME UTILITIES - PORTABLE ;;; (defun convert-zone-string (zone) "Internal. Convert ZONE of the form +/- NNNN to a common lisp time zone." (let ((num (parse-integer zone))) (multiple-value-bind (hours minutes) (truncate num 100) (let ((lisp-zone (- (+ hours (/ minutes 60))))) (assert (rationalp lisp-zone)) lisp-zone)))) (defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) (defun date (&key (stream *standard-output*) (utime (get-universal-time)) tz uutime) (when uutime (when utime (warn "ignoring UTIME using UUTIME")) (setq utime (+ +unix-epoch+ uutime))) (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (when daylight-p (decf zone)) ; check (format stream "~a ~a ~2,' d ~2,'0d:~2,'0d:~2,'0d ~4d ~?" (ecase day (0 "Mon") (1 "Tue") (2 "Wed") (3 "Thu") (4 "Fri") (5 "Sat") (6 "Sun")) (ecase month (1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun") (7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov") (12 "Dec")) date hour minute second year "~:[+~;-~]~2,'0d~2,'0d" (multiple-value-bind (hour min) (truncate zone 1) (list (plusp zone) (abs hour) (* 60 (abs min))))))) (defun iso-8601-date (&key (stream nil) (utime (get-universal-time)) (tz nil) (suppress-time-p nil) (suppress-tz-p t)) "Format current datetime (for Common Lisp time-zone TZ) on STREAM." (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (declare (ignore day)) (if daylight-p (decf zone)) ; check (format stream "~4,'0D-~2,'0D-~2,'0D~:[ ~2,'0D:~2,'0D:~2,'0D~:[ ~C~2,'0D~2,'0D~;~]~;~]" ; year month date suppress-time-p hour minute second suppress-tz-p (if (plusp zone) #\- #\+) (abs (truncate zone)) (truncate (* 60 (mod zone 1)))))) (defun yymmddhhmm (&key (stream nil) (utime (get-universal-time)) tz) "[[CC]YY]MMDDhhmm[.ss] for touch(1)." (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (declare (ignorable daylight-p day zone)) (format stream "~4d~2,'0d~2,'0d~2,'0d~2,'0d.~2,'0d" year month date hour minute second))) (defun yymmdd (&key stream (utime (get-universal-time)) tz) (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (declare (ignorable daylight-p zone second minute hour day)) (format stream "~d~2,'0d~2,'0d" year month date))) ;; Eg. World Times fluff ;; Mon Dec 4 09:46:07 2000 ;; (defvar TimeZoneMap2000.gif-codes '(("Z" 0) ("A" 1) ("B" 2) ("C" 3) ("C*" 7/2) ("D" 4) ("D*" 9/2) ("E" 5) ("E*" 11/2) ("F" 6) ("F*" 13/2) ("G" 7) ("H" 8) ("I" 9) ("I*" 19/2) ("J" 10) ("K" 11) ("K*" 21/2) ("L" 12) ("L*" 23/2) ("M" 13) ("M*" 14) ("N" -1) ("O" -2) ("P" -3) ("P*" -7/2) ("Q" -4) ("R" -5) ("S" -6) ("T" -7) ("U" -8) ("U*" -17/2) ("V" -9) ("V*" -19/2) ("W" -10) ("X" -11) ("Y" -12))) (defvar TimeZoneMap2000.gif-cities '((("Honolulu" "Hawaii") "W") (("Anchorage" "Alaska") "V") (("Los Angeles" "California") "U") (("Denver" "Colorado") "T") (("Chicago" "Illinois") "S") (("New York" "America") "R") (("Caracas" "Venezuela") "Q") (("London" "United Kingdom") "Z") (("Paris" "France") "A") (("Buenos Aires" "Argentina") "P") (("Hong Kong" "China") "H") (("Tokyo" "Japan") "I") (("Brisbane" "Australia") "K") (("Sydney" "Australia") "K") (("Bangkok" "Thailand") "G") (("Moscow" "Russia") "G") (("Karachi" "Pakistan") "E") (("Calcutta" "Asia") "E*"))) (defun world-times (&key (utime (get-universal-time)) (stream t)) (loop for ((place city) code) in TimeZoneMap2000.gif-cities for cons = (assoc code TimeZoneMap2000.gif-codes :test #'string=) do (format stream "~&~30:<~a/~a~>~t" place city) (date :stream stream :utime utime :tz (- (cadr cons))))) (export '(date iso-8601-date date touchdate yymmdd world-times convert-zone-string)) (defun universal-time (unix-time) "Return the Common Lisp universal time in seconds of the given unix time." (+ unix-time +unix-epoch+)) (export '(+unix-epoch+ universal-time)) #+nil (assert (= user:+unix-epoch+ 2208988800)) ;;; ---------------------------------------------------------------------- ;;; ;;; RUN2 SUB-PROCESS INTERFACE ;;; ;;; Madhu [Sat Mar 12 08:26:25 2005 +0530] ;;; #+cmu (progn (defvar *process* nil) (define-symbol-macro $stdin (ext::process-input *process*)) (define-symbol-macro $stdout (ext::process-output *process*)) (define-symbol-macro $stderr (ext::process-error *process*)) (define-symbol-macro $pty (ext::process-pty *process*)) (defvar *last-command* nil) (defvar *last-command-error-stream* (make-string-output-stream)) (defvar *last-command-error-string* nil) (defun last-command-status (&optional (stream *standard-output*)) (format stream "Last command: `~{~A~^ ~}'~%" *last-command*) (format stream "Last command output: `~A'~%" ;TODO *last-command-error-string*) (cond ((EXT:process-p *process*) (format stream "Process: ~A. Status: ~A. Exit Code: ~A.~%" *process* (EXT:process-status *process*) (EXT:process-exit-code *process*))) (t (format stream "Invalid process: ~A~%" *process*)))) (defvar *default-settings** (list :wait t :input nil :output (load-time-value cl:*standard-output*) :pty nil :error :output)) ;; XXX :error is hokey (defmacro with-defaults ((&rest plist &key (wait t) (input nil) (error :output) (output 'cl:*standard-output*) (pty nil)) &body body) "Binds *DEFAULT-SETTINGS**. See EXT:RUN-PROGRAM" (declare (ignorable wait input output pty error)) `(let ((*default-settings** (nconc (list ,@plist) *default-settings**))) ,@body)) (defun run2 (command &rest args) "Get defaults from *DEFAULT-SETTINGS**. See EXT::RUN-PROGRAM" (macrolet ((default (x) `(getf *default-settings** ,x))) (if *process* (ext:process-kill *process* 9)) (get-output-stream-string *last-command-error-stream*) (let* ((output (default :output)) (error (default :error)) (error-stream (case error (:output (cond ((null output) *last-command-error-stream*) ;XXX ((streamp output) (make-broadcast-stream *last-command-error-stream* output)) (t (warn "RUN2: Ignoring :ERROR :OUTPUT") *last-command-error-stream*))) ((nil) nil) ((streamp error) (make-broadcast-stream *last-command-error-stream* error)) (t (warn "RUN2: Ignoring :ERROR ~S" error) *last-command-error-stream*)))) (setq *last-command* (cons command args) *process* (EXT:run-program command args :wait (default :wait) :error error-stream :input (default :input) :output output :pty (default :pty)) *last-command-error-string* (get-output-stream-string *last-command-error-stream*)))) (case (ext:process-status *process*) (:exited (if (zerop (ext:process-exit-code *process*)) t (cerror "Continue from RUN2" "`~{~A~^ ~}' aborted with an error~@[:~%~A~]~%" *last-command* (unless (string= "" *last-command-error-string*) *last-command-error-string*)))) (:signaled (cerror "Continue from RUN2" "`~{~A~^ ~}' killed with signal ~A~@[ (core dumped)].~%" *last-command* (ext:process-exit-code *process*) (ext:process-core-dumped *process*))))) (export '(with-defaults run2 $stdin $stdout $stderr last-command-status))) #+lispworks (progn (defvar *last-command* nil) (defvar *default-settings** (list :wait t :output (load-time-value cl:*standard-output*))) (defmacro with-defaults ((&rest plist &key (output 'cl:*standard-output*) (wait t)) &body body) (declare (ignorable output wait)) `(let ((*default-settings** (nconc (list ,@plist) *default-settings**))) ,@body)) ;; (prefix system::*call-system-showing-output-prefix*) ;; XXX Make sure sh.exe is in PATH (defun run2 (command &rest args) (macrolet ((default (x) `(getf *default-settings** ,x))) (system::call-system-showing-output (setq *last-command* (or ;FIXME #+mswindows (cons command args) #-mswindows (list "/bin/sh" "-c" (format nil "~A ~{~S~^ ~}" command args)) (reduce (lambda (a b) (concatenate 'string a " " b)) args :initial-value command))) :current-directory nil :prefix nil :show-cmd nil :output-stream (default :output) :wait (default :wait) :shell-type #+mswindows "sh.exe" #-mswindows "/bin/sh" :kill-process-on-abort nil :extra-environ nil))) (export '(with-defaults run2))) #+clisp (progn ;; madhu 050611 clisp wont let you pass in a stream. create new streams each ;; time. no :pty. To support pass-in streams bind *terminal-io* before ;; calling. Not worth fighting design (defvar *process* nil) (defvar $stdin nil) (defvar $stdout nil) (defvar $pty nil) (defvar *default-settings** `(:wait t :input nil :output :terminal)) (defmacro with-defaults (alist &body body) `(let ((*default-settings** (nconc (list ,@alist) *default-settings**))) ,@body)) (defun run2 (command &rest args) (macrolet ((default (x) `(getf *default-settings** ,x))) (if $stdin (close $stdin) (setf $stdin nil)) (if $stdout (close $stdout) (setf $stdout nil)) (if $pty (close $pty) (setf $pty nil)) (let ((input (default :input)) (output (default :output))) (etypecase output (symbol (ecase output ((:terminal :stream nil)))) (string) (stream (error "Not supported."))) (etypecase input (symbol (ecase input ((:terminal :stream nil)))) (string) (stream (error "Not supported."))) ;; check the fucking clisp contract (setf *process* (ext:run-program command ;; :may-exec t :arguments args :wait (default :wait) :input input :output output)) (cond ((and (eq input :stream) (eq output :stream)) (assert (= (length *process*) 3)) (map nil (lambda (stream) (assert (streamp stream))) *process*) (setf $pty (first *process*) $stdin (second *process*) $stdout (third *process*))) ((eq input :stream) (assert (streamp *process*)) (setf $stdin *process* $stdout nil $pty nil)) ((eq output :stream) (assert (streamp *process*)) (setf $stdout *process* $stdout nil $pty nil)) (t (warn "~S" (list input output (default :error) (default :wait))) (setf $stdin nil $stdout nil $pty nil))))) (export '(run2 with-defaults)))) #+allegro (progn ;; NOTE allegro 8.1 won't let you pass any streams except fd streams and its ;; own terminal io. We let this be for input streams. for output streams the ;; workaround to support the API is ugly: (defstruct my-process command input input-stream output output-stream error error-stream frob-output-stream frob-error-stream status exit-code pid signal) (defun my-process-reap (*process*) (when (my-process-pid *process*) (multiple-value-bind (exit-code pid signal) (sys:reap-os-subprocess :pid (my-process-pid *process*) :wait t) (when exit-code (assert (= pid (my-process-pid *process*))) (warn "reaped ~S: new exit-code ~S ~@[pid ~S~] ~@[signal ~S~]." *process* exit-code pid signal) (setf (my-process-exit-code *process*) exit-code (my-process-signal *process*) signal (my-process-status *process*) (if signal :signalled :exited)))))) (defun my-process-clear (*process*) (setf (my-process-command *process*) nil (my-process-input *process*) nil (my-process-input-stream *process*) nil (my-process-output *process*) nil (my-process-output-stream *process*) nil (my-process-error *process*) nil (my-process-error-stream *process*) nil (my-process-frob-output-stream *process*) nil (my-process-frob-error-stream *process*) nil (my-process-status *process*) nil (my-process-exit-code *process*) nil (my-process-signal *process*) nil)) (defun my-process-close-streams (*process*) "Close created streams." (let (input-p closed-input output-p closed-output error-p closed-error) (when (streamp (my-process-input-stream *process*)) (ecase (my-process-input *process*) (:user-supplied) (:created (setq input-p t) (setq closed-input (close (my-process-input-stream *process*)))))) (when (streamp (my-process-output-stream *process*)) (ecase (my-process-output *process*) (:user-supplied) (:created (setq output-p t) (setq closed-output (close (my-process-output-stream *process*)))))) (when (streamp (my-process-error *process*)) (ecase (my-process-error *process*) (:user-supplied) (:created (setq error-p t) (setq closed-output (close (my-process-error *process*)))))) (when (or input-p output-p error-p) (warn "closed streams: ~S ~@[input: ~S~] ~@[output: ~S~] ~@[error: ~S~]" *process* (if input-p (list closed-input)) (if output-p (list closed-output)) (if error-p (list closed-error)))))) (defun my-process-set-command (*process* command args) (setf (my-process-command *process*) (or ;;#-mswindows ;;(apply 'vector (cons command args)) ;;#+mswindows (format nil "~A ~{~S~^ ~}" command args)))) (defvar *default-settings** (list :wait t :input nil :output (load-time-value cl:*standard-output*) :error :output)) (defmacro with-defaults ((&rest plist &key (wait t) (input nil) (error :output) (output 'cl:*standard-output*)) &body body) (declare (ignorable wait input output error)) `(let ((*default-settings** (nconc (list ,@plist) *default-settings**))) ,@body)) (defvar *process* (make-my-process)) (defun xfer1 (input-stream &optional (output-stream *standard-output*)) (do ((ch (read-char input-stream nil nil) (read-char input-stream nil nil))) ((null ch) (finish-output output-stream)) (write-char ch output-stream))) (defun run2 (command &rest args &aux frob-output frob-error) (declare (optimize (debug 3))) (macrolet ((default (x) `(getf *default-settings** ,x))) (when *process* (my-process-reap *process*) (my-process-close-streams *process*) (my-process-clear *process*)) (my-process-set-command *process* command args) (let ((input (default :input)) (output (default :output)) (error (default :error))) (multiple-value-bind (process-input process-output process-error process-pid) (excl:run-shell-command (my-process-command *process*) :wait nil :separate-streams t :input input :output (if (streamp output) (if (excl.osi::stream-to-fd output) output (setq frob-output :stream)) output) :error-output (if (streamp error) (if (excl.osi::stream-to-fd error) error (setq frob-error :stream)) error)) (setf (my-process-pid *process*) process-pid (my-process-status *process*) :launched) (cond (frob-output (assert (streamp process-output)) (warn "Frobbing process output stream ~S to ~S" process-output output) (setf (my-process-output *process*) :created (my-process-output-stream *process*) process-output (my-process-frob-output-stream *process*) output)) ((eq output :stream) (assert (streamp process-output)) (warn "User requested output :stream. Giving ~S" process-output) (setf (my-process-output *process*) :created (my-process-output-stream *process*) process-output)) (t (assert (null process-output)) (warn "User supplied output: ~S. No stream created." output) (setf (my-process-output *process*) :user-supplied (my-process-output-stream *process*) output))) (cond (frob-error (assert (streamp process-error)) (warn "Frobbing process error stream ~S to ~S" process-error error) (setf (my-process-error *process*) :created) (setf (my-process-error-stream *process*) process-error (my-process-frob-error-stream *process*) error)) ((eq error :stream) (assert (streamp process-error)) (warn "User requested error :stream. Giving ~S" process-error) (setf (my-process-error *process*) :created (my-process-error-stream *process*) process-error)) ((eq error :output) (assert (null process-error)) (warn "User redirected error to output. No stream created" error) (assert (null (my-process-error *process*))) (assert (null (my-process-error-stream *process*)))) (t (assert (null process-error)) (warn "User supplied error stream: ~S. No stream created." error) (setf (my-process-error *process*) :user-supplied (my-process-error-stream *process*) error))) (cond (process-input (assert (eq input :stream)) (warn "User supplied input :stream. Giving ~S" process-input) (setf (my-process-input *process*) :created (my-process-input-stream *process*) process-input)) (t (warn "User supplied input stream ~S used." input) (setf (my-process-input *process*) :user-supplied (my-process-input-stream *process*) input))) (assert (default :wait)) ; anything else untested. (when (default :wait) (when frob-error (xfer1 process-error error)) (when frob-output (xfer1 process-output output))) (warn "WAITing for process to be reaped.") (my-process-reap *process*)))) #+nil *process*) ;FINISHME (export '(with-defaults run2))) #+nil (progn (ensure-directories-exist "/tmp/xyz/foo/bar/" :verbose t) (touch "/tmp/xyz/foo/dummy0.txt") (ensure-directories-exist "/tmp/xyz/foo/emptydir/" :verbose t) (in-directory "/tmp/xyz/foo/bar/" (run2 "ln" "-s" "dummy0.txt" "link0.txt")) (user:in-directory "/tmp/xyz/foo/" (run2 "ln" "-s" "__" "badlink.txt")) (user:in-directory "/tmp/xyz/foo/bar/" (run2 "ln" "-s" "../../foo")) (last-command-status)) ;; ;; TODO: SUBPROCESS RUN PROGRAM ASYNCH OUTPUT TESTS ;; #+nil (defun sink (stream) (loop for c = (ignore-errors (lisp::read-char-no-hang stream nil stream)) while c if (eq c stream) return nil else do (format t "~a" c))) #+nil (defun read-line-no-hang (&optional (stream *standard-input*) (eof-errorp t) eof-value) (loop for c = (lisp::read-char-no-hang stream eof-errorp stream) while c if (eq c stream) return (values (if chars (coerce chars 'string) eof-value) t) else if (eql c #\Newline) return (values (coerce chars 'string) nil) else collect c into chars finally (return (values (coerce chars 'string) t)))) #+nil (defun pipe1 (stream &optional (output-stream t)) "Pipe characters from STREAM to OUTPUT-STREAM, while they come. A NIL value for OUTPUT-STREAM indicates a string must be returned. A T value stands for *STANDARD-OUTPUT*" (flet ((pipe (stream output-stream) (loop for c = (ignore-errors (lisp::read-char-no-hang stream nil stream)) while c if (eq c stream) return nil else do (format output-stream "~a" c)))) (if (null output-stream) (with-output-to-string (x) (pipe stream x)) (pipe stream output-stream)))) #+nil (defun %parse-ldd-line (line) (let ((tomatch "=> ")) (let ((pos1 (search "=>" line))) (when pos1 (incf pos1 (length tomatch)) (let ((pos2 (position #\space line :from-end t))) (when pos2 (subseq line pos1 pos2))))))) #+nil (defun ldddu (filename) "ldd | du -sck | sort -rn" (let (*process* $deps) (with-defaults (:output :stream) (run2 "ldd" filename) (when *process* (setq $deps (cons filename (loop for line = (read-line-no-hang $stdout) while line collect (%parse-ldd-line line)))) (with-output-to-string (stream) (let (*process*) (with-defaults (:output :stream) (apply 'run2 "du" "-sDck" $deps) (when *process* (with-defaults (:input $stdout :output stream) (let (*process*) (run2 "sort" "-rn"))))))))))) #+nil (ldddu "/usr/local/bin/xpdf") ;; ;; ;; #+nil (defun bunzip (pathname) "Reads PATHNAME. Yields user::$stdout to read from." (with-open-file (stream pathname) (with-defaults (:input stream :output :stream :wait nil) (run2 "bzip2" "-dc" "-")))) #+nil (defun bzip (pathname) "Supersedes PATHNAME. Yields user::$stdin to write to." (with-open-file (stream pathname :direction :output :if-exists :supersede) (with-defaults (:input :stream :output stream :wait nil) (run2 "bzip2" "-c" "-")))) ;;; ---------------------------------------------------------------------- ;;; ;;; WITH-OPEN-PIPE: ALTERNATIVE TO RUN2 ;;; #+cmu (defmacro with-open-pipe ((stream command &key (shell-type "/bin/sh")) &body body) `(let* ((.proc. (ext:run-program ,shell-type (list "-c" ,command) :input :stream :output :stream :wait nil ;; if we block, stream never gets a ;; chance to read. :error *error-output*)) (,stream (make-two-way-stream (ext:process-output .proc.) (ext:process-input .proc.)))) (unwind-protect (progn ,@body) (close ,stream) (ext:process-close .proc.)))) #+lispworks (defmacro with-open-pipe ((stream command &key (shell-type "/bin/sh")) &body body) `(with-open-stream (,stream (sys:open-pipe ,command :shell-type ,shell-type #+unix :error-output #+unix *error-output* :direction :io)) ,@body)) #+allegro (defmacro with-open-pipe ((stream command &key (shell-type "/bin/sh")) &body body) (let ((pid-var (gensym "PID")) (stream-var (gensym "STREAM"))) `(with-env-vars ((:SHELL ,shell-type)) (let ((,pid-var nil) (,stream-var nil)) (unwind-protect (multiple-value-bind (,stream .ignored. .pid.) (excl:run-shell-command ,command :input :stream :output :stream :separate-streams nil :wait nil) (declare (ignore .ignored.)) (setq ,pid-var .pid. ,stream-var ,stream) ,@body) (when ,pid-var (warn "reaping ~D." ,pid-var) (sys:reap-os-subprocess :pid ,pid-var :wait t)) (when ,stream-var (warn "closing ~S" ,stream-var) (close ,stream-var :abort t))))))) #+clisp ;XXX TODO chk (defmacro with-open-pipe ((stream command &key (shell-type "/bin/sh")) &body body) `(with-open-stream (,stream (ext:make-pipe-io-stream ,command)) ,@body)) (export '(with-open-pipe)) ;; ;; WITH-OPEN-PIPE EXAMPLES ;; (defun shasum (pathname) (let ((namestring (namestring pathname))) (with-open-pipe (pipe (format nil "shasum -t ~A" namestring)) (let* ((output (read-line pipe)) (pos (search namestring output))) (values (when (> pos 40) (subseq output 0 (- pos 2))) namestring))))) #+nil (shasum "/etc/passwd") ;; ;; WITH-OPEN-PIPE EXAMPLE 2: WITH-DECOMPRESSED-STREAM ;; (defvar *file-decompression-schemes* ;; scheme extensions command flags '((gzip ("gz" "z") "gzip" ("-dc")) (bzip2 ("bz2") "bzip" ("-dc")))) (defmacro with-decompressed-stream ((stream compressed-file-pathname &key decompressor flags) &body body) "DECOMPRESSOR is a string denoting the external decompressor program to be invoked. FLAGS is a list of command line switches to be passed to the external decompressor. DECOMPRESSOR can be :NONE indicating no decompression must be done. DECOMPRESSOR and FLAGS, if NULL, are inferred from the pathname-type of the given COMPRESSED-FILE-PATHNAME, from defaults specified in *FILE-DECOMPRESSION-STREAMS*. For example \"bz2\" and \"gz\" suffixes are recognized and DECOMPRESSOR defaults to \"bzip2\" and \"gzip\" respectively, and FLAGS defaults to '\(\"-dc\")." (let ((pathname-sym (gensym)) (command-sym (gensym)) (decompressor-sym (gensym)) (flags-sym (gensym))) `(let* ((,pathname-sym ,compressed-file-pathname) (,decompressor-sym ,decompressor) (,flags-sym ,flags)) (when (or (null ,decompressor-sym) (eql ,decompressor-sym :FORCE)) (let ((pathname-type (pathname-type ,pathname-sym))) (when pathname-type (loop for (scheme extensions command switches) in *FILE-DECOMPRESSION-SCHEMES* if (find pathname-type extensions :test #'string-equal) do (unless ,decompressor-sym (setq ,decompressor-sym command)) (unless ,flags-sym (setq ,flags-sym switches)))) (when (eql ,decompressor-sym :FORCE) (error "Could not infer unzip program for file ~S. ~S" ,pathname-sym (list 'type (pathname-type ,pathname-sym)))))) (let ((,command-sym (if (or (null ,decompressor-sym) (eql ,decompressor-sym :NONE)) NIL (format nil "~A ~{~A~^ ~} \"~A\"" ,decompressor-sym ,flags-sym (namestring ,pathname-sym))))) (if ,command-sym (with-open-pipe (,stream ,command-sym) ,@body) (with-open-file (,stream ,pathname-sym) ,@body)))))) (export '(with-decompressed-stream *file-decompression-schemes*)) #|| ls -al > /tmp/ls-al gzip --best /tmp/ls-al (with-decompressed-stream (stream "/tmp/ls-al.gz" :decompressor :none) (user:copy-buffered-io stream *standard-output* :element-type 'base-char)) #+clisp (with-default-file-encoding () (with-decompressed-stream (stream "/tmp/ls-al.gz" :decompressor nil) (user:copy-buffered-io stream *standard-output* :element-type 'base-char))) ||# ;;; ---------------------------------------------------------------------- ;;; ;;; STAT2 STATFILE INTERFACE: frobbing/simple-string file conversion ;;; ;;; STAT2-SIMPLE "Follows symlinks via stat(2)." ;;; STAT2 "Does not follow symlinks." ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +statbuf+ '(device inode mode nlink uid gid device-type total-size atime mtime ctime blocksize blocks))) #+cmu (defmacro stat2-helper (pathname &optional follow-symlinks &body body) (let ((pathnamevar (gensym))) `(let* ((,pathnamevar ,pathname) (namestring (unix::unix-namestring ,pathnamevar))) (unless namestring (error "~A does not exist." ,pathnamevar)) (multiple-value-bind ,(cons 'status +statbuf+) (if ,follow-symlinks (unix:unix-stat namestring) (unix:unix-lstat namestring)) (declare (special ,@+statbuf+)) (cond (status ,(if body `(progn ,@body) `(loop for x in +statbuf+ nconc (list x (symbol-value x))))) (t (let ((errno (UNIX:UNIX-ERRNO))) (assert (> errno 0)) (assert (= device errno)) (error "STAT FAILED with errno: ~D: ~A" errno (UNIX:GET-UNIX-ERROR-MSG errno))))))))) #+(and clisp syscalls unix) (defmacro stat2-helper (pathname follow-symlinks &body body) ;extra consing! `(let ((found (posix:file-stat ,pathname (not ,follow-symlinks)))) ;; CLISP behaviour as of 2.33.81 allows optional link-p for ;; file-stat to work on both regular files and symlinks. (when found (check-type found posix:file-stat) (let ((device (posix:file-stat-dev found)) (inode (posix:file-stat-ino found)) (mode (posix:file-stat-mode found)) (nlink (posix:file-stat-nlink found)) (uid (posix:file-stat-uid found)) (gid (posix:file-stat-gid found)) (device-type (posix:file-stat-rdev found)) (total-size (posix:file-stat-size found)) ;; CLISP returns times as the number of seconds since 1900-01-01 (atime (- (posix:file-stat-atime found) +unix-epoch+)) (mtime (- (posix:file-stat-mtime found) +unix-epoch+)) (ctime (- (posix:file-stat-ctime found) +unix-epoch+)) (blocksize (posix:file-stat-blksize found)) (blocks (posix:file-stat-blocks found))) (declare (special ,@+statbuf+)) (if (consp mode) (setq mode (posix:convert-mode mode))) ,(if body `(progn ,@body) `(loop for x in +statbuf+ nconc (list x (symbol-value x))))) ))) #+(and lispworks (not mswindows)) (defmacro stat2-helper (pathname follow-symlinks &body body) ;extra consing! (let ((pathnamevar (gensym)) (followsymlinksvar (gensym))) `(let ((,pathnamevar ,pathname) (,followsymlinksvar ,follow-symlinks)) (multiple-value-bind (found errno) (if ,followsymlinksvar (sys:get-file-stat ,pathnamevar) (sys::get-file-lstat ,pathnamevar)) (cond (found (check-type found system::stat) (let ((device (sys:file-stat-device found)) (inode (sys:file-stat-inode found)) (mode (sys:file-stat-mode found)) (nlink (sys:file-stat-links found)) (uid (sys:file-stat-owner-id found)) (gid (sys:file-stat-group-id found)) (device-type (sys:file-stat-device-type found)) (total-size (sys:file-stat-size found)) (atime (sys:file-stat-last-access found)) (mtime (sys:file-stat-last-modify found)) (ctime (sys:file-stat-last-change found)) (blocksize 512) ;; XXX FIXME (blocks (sys:file-stat-blocks found))) (declare (special ,@+statbuf+)) ,(if body `(progn ,@body) `(loop for x in +statbuf+ nconc (list x (symbol-value x)))))) (t (let ((errno1 (lw::errno-value))) (assert (> errno1 0)) (assert (= errno1 errno)) (error "~@[L~]STAT FAILED with errno: ~D." (not ,followsymlinksvar) errno)))))))) #+(and allegro (not mswindows)) (defmacro stat2-helper (pathname follow-symlinks &body body) ;extra consing! (let ((pathnamevar (gensym)) (followsymlinksvar (gensym))) `(let ((,pathnamevar ,pathname) (,followsymlinksvar ,follow-symlinks)) (handler-case (let ((found (if ,followsymlinksvar (excl.osi:stat ,pathnamevar) (excl.osi:lstat ,pathnamevar)))) (let ((device (excl.osi:stat-dev found)) (inode (excl.osi:stat-ino found)) (mode (excl.osi:stat-mode found)) (nlink (excl.osi:stat-nlink found)) (uid (excl.osi:stat-uid found)) (gid (excl.osi:stat-gid found)) (device-type (excl.osi:stat-rdev found)) (total-size (excl.osi:stat-size found)) (atime (- (excl.osi:stat-atime found) +unix-epoch+)) (mtime (- (excl.osi:stat-mtime found) +unix-epoch+)) (ctime (- (excl.osi:stat-ctime found) +unix-epoch+)) (blocksize 512) ;; XXX FIXME (blocks nil #+FIXME(excl.osi::stat-blocks found))) (declare (special ,@+statbuf+)) ,(if body `(progn ,@body) `(loop for x in +statbuf+ nconc (list x (symbol-value x)))))) (excl.osi:syscall-error (c) (let ((errno1 (excl.osi:syscall-error-errno c))) (assert (> errno1 0)) (excl.osi:perror errno1 "~@[L~]STAT FAILED with errno: ~D" (not ,followsymlinksvar) errno1))))))) #+nil (defmacro top-level-cond (&rest clauses) (let ((expansion (loop for (condition . body) in clauses if (eval condition) return `(progn ,@body)))) expansion)) ;; madhu 081110. CLISPBUG has a long standing bug where a top level: (unless ;; nil FORM),FORM gets evaluated on LOAD/COMPILE. (cond ((not (fboundp 'stat2-helper)) (defun stat2-helper (pathname follow-symlinks &rest body) (declare (ignore pathname follow-symlinks body)) (error "Stat not defined.")))) (defmacro stat2-simple (pathname) `(stat2-helper ,pathname t)) (defmacro stat2 (pathname &body body) `(stat2-helper ,pathname nil ,@body)) (export '(stat2 stat2-simple)) #|| (stat2-simple "/tmp/xyz/foo/bar/foo") (stat2-helper "/tmp/xyz/foo/bar/foo" nil) (directory-p #p"/tmp/xyz/foo/bar/foo/") (symbolic-link-p #p"/tmp/xyz/foo/bar/foo/") (stat2-helper #p"/tmp/xyz/foo/bar/foo/" nil) (stat2-helper "/tmp/xyz/foo/badlink.txt" nil) ||# ;;; ;;; ;;; From The stat(2) manpage ;;; (defvar S_IFMT #o170000 "bitmask for the file type bitfields") (defmacro frob-man2stat (string &rest ignored-docs) (declare (ignore ignored-docs)) (with-input-from-string (stream string) `(progn ,@(loop for sym = (let ((x (read stream nil stream))) (if (eq x stream) (loop-finish) x)) for mask = (let ((*read-base* 8)) (read stream)) for comment = (progn (peek-char t stream) (read-line stream nil)) collect (list 'defvar sym mask comment))))) (frob-man2stat "S_IFSOCK 0140000 socket S_IFLNK 0120000 symbolic link S_IFREG 0100000 regular file S_IFBLK 0060000 block device S_IFDIR 0040000 directory S_IFCHR 0020000 character device S_IFIFO 0010000 fifo S_ISUID 0004000 set UID bit S_ISGID 0002000 set GID bit (see below) S_ISVTX 0001000 sticky bit (see below) S_IRWXU 00700 mask for file owner permissions S_IRUSR 00400 owner has read permission S_IWUSR 00200 owner has write permission S_IXUSR 00100 owner has execute permission S_IRWXG 00070 mask for group permissions S_IRGRP 00040 group has read permission S_IWGRP 00020 group has write permission S_IXGRP 00010 group has execute permission S_IRWXO 00007 mask for permissions for others (not in group) S_IROTH 00004 others have read permission S_IWOTH 00002 others have write permisson S_IXOTH 00001 others have execute permission" ) " The set GID bit (S_ISGID) has several special uses: For a directory it indicates that BSD semantics is to be used for that directory: files created there inherit their group ID from the directory, not from the effective gid of the creating process, and directories created there will also get the S_ISGID bit set. For a file that does not have the group execution bit (S_IXGRP) set, it indicates mandatory file/record locking. The ‘sticky’ bit (S_ISVTX) on a directory means that a file in that directory can be renamed or deleted only by the owner of the file, by the owner of the directory, and by root." #+allegro (shadow 'symbolic-link-p) (defun symbolic-link-p (pathname &optional (stats (stat2 pathname))) (= S_IFLNK (logand S_IFMT (getf stats 'mode)))) (defun directory-p (pathname &optional (stats (stat2 pathname))) (= S_IFDIR (logand S_IFMT (getf stats 'mode)))) (defun regular-file-p (pathname &optional (stats (stat2 pathname))) (= S_IFREG (logand S_IFMT (getf stats 'mode)))) (defun executable-file-p (pathname &optional (stats (stat2 pathname))) (not (zerop (logand S_IXUSR (getf stats 'mode))))) (export '(symbolic-link-p directory-p regular-file-p executable-file-p)) #+nil (list S_IFMT S_IFLNK S_IFDIR S_IFREG) ;; => (61440 40960 16384 32768) #+nil (progn (directory-p "/tmp/xyz/") ;T (directory-p "/tmp/xyz/foo/bar/foo") ;NIL (directory-p "/tmp/xyz/foo/bar/foo/") ;T (CMUCL,CLISP, ACL) (directory-p "/tmp/xyz/foo/bar/foo/") ;NIL LWBUG FIXME (assert (not (directory-p "/tmp/xyz/foo/dummy0.txt"))) (assert (not (symbolic-link-p "/tmp/xyz/foo/dummy0.txt"))) (assert (regular-file-p "/tmp/xyz/foo/dummy0.txt")) (assert (not (directory-p "/tmp/xyz/foo/dummy0.txt"))) (assert (symbolic-link-p "/tmp/xyz/foo/badlink.txt")) (assert (not (regular-file-p "/tmp/xyz/foo/badlink.txt"))) (assert (not (directory-p "/tmp/xyz/foo/bar/foo"))) #+cmu (assert (eq (unix:unix-file-kind "/tmp/xyz/foo/bar/foo") :directory)) ;CMUBUG (assert (symbolic-link-p "/tmp/xyz/foo/bar/foo"))) ;; ;; STATFILE INTERFACE: PORTABLE EXAMPLES ;; (defun dates2 (path) (let ((stats (stat2-simple path))) (loop for x in '(atime mtime ctime) nconc (list x (iso-8601-date :utime (universal-time (getf stats x)) :stream nil))))) #+cmu (defun setdates2 (path plist) (destructuring-bind (&key ((atime atime) 0) ((mtime mtime)0) &allow-other-keys) plist (unix:unix-utimes (unix::unix-namestring (TRUENAME path)) atime 0 mtime 0))) #+(and clisp syscalls unix) ;FIXME unix-epoch? (defun setdates2 (path plist) (destructuring-bind (&key ((atime atime) 0) ((mtime mtime)0) &allow-other-keys) plist (posix:set-file-stat (namestring (truename path)) :atime atime :mtime mtime))) #+allegro (defun setdates2 (path plist) (destructuring-bind (&key ((atime atime) 0) ((mtime mtime) 0) &allow-other-keys) plist (excl.osi:utime (unix-namestring (TRUENAME path)) (+ atime +unix-epoch+) (+ mtime +unix-epoch+)))) #+(and lispworks unix) ; Xanalys (C) code by way of cl-http (progn (fli:define-c-typedef time_t :int) (fli:define-c-struct utimbuf (actime time_t) (modtime time_t)) (fli:define-foreign-function (unix-utime "utime" :source) ((name (:reference-pass :lisp-string-array)) (times (:pointer utimbuf))) :result-type :int)) #+(and lispworks win32) ; Xanalys (C) code by way of cl-http (progn (fli:define-c-struct _FILETIME (dw-low-date-time (:UNSIGNED :LONG)) (dw-high-date-time (:UNSIGNED :LONG))) (fli:define-c-typedef FILETIME (:struct _FILETIME)) (fli:define-foreign-function (set-file-time "SetFileTime") ((h-file win32:handle) (lp-creation-time (:pointer filetime)) (lp-last-access-time (:pointer filetime)) (lp-last-write-time (:pointer filetime))) :result-type win32:bool) (defconstant +windows-epoch+ 94354848000000000) (defun set-filetime-from-universal-time (utime filetime) (let ((filetime-value (+ (* utime 10000000) +windows-epoch+))) (setf (fli:foreign-slot-value filetime 'dw-high-date-time) (ash filetime-value -32)) (setf (fli:foreign-slot-value filetime 'dw-low-date-time) (logand filetime-value #xffffffff))))) #+(and lispworks (or unix win32)) (defun setdates2 (path plist &aux errno) (destructuring-bind (&key ((atime atime) 0) ((mtime mtime) 0) #+win32 ((ctime ctime) 0) ; creation time! &allow-other-keys) plist #+unix (fli:with-dynamic-foreign-objects ((buffer utimbuf)) (setf (fli:foreign-slot-value buffer 'actime) atime (fli:foreign-slot-value buffer 'modtime) mtime) (unless (zerop (unix-utime (unix-namestring (truename path)) buffer)) (error "SETDATES2 Failed on file ~A: ~A(~A)." path (lw:get-unix-error (setq errno (lw::errno-value))) errno))) #+win32 ; XXX UNTESTED (unless (with-open-file (stream (truename (unix-namestring pathname)) :direction :output :if-exists :overwrite :element-type '(unsigned-byte 8)) (set-filetime-from-universal-time (+ ctime +unix-epoch+) creation-filetime) (set-filetime-from-universal-time (+ mtime +unix-epoch+) modification-filetime) (set-filetime-from-universal-time (+ atime +unix-epoch+) access-filetime) (fli:with-dynamic-foreign-objects ((creation-filetime filetime) (modification-filetime filetime) (access-filetime filetime)) (set-file-time (io:file-stream-file-handle stream) creation-filetime access-filetime modification-filetime))) (error "SETDATES2 Failed on file ~A: ~A." path (lw:get-unix-error (setq errno (lw::errno-value))))))) ;; CLISPBUG. (cond ((not (fboundp 'setdates2)) (defun setdates2 (path plist) (warn "SETDATES2 ~A ~A: Ignored" path plist)))) (export '(setdates2)) ;; ;; (defmacro with-file-dates-preserved ((pathname) &body body) `(let ((stats (stat2-simple ,pathname))) (unwind-protect (progn ,@body) (setdates2 ,pathname stats)))) (defun touch (pathname &key (utime (get-universal-time)) (atime t) (mtime t)) "ATIME and UTIME can be universal times, Or they can be NIL (leave the time unchanged). Otherwise they default to the universal time in UTIME." (when atime (setq atime (- (if (numberp atime) atime utime) +unix-epoch+))) (when mtime (setq mtime (- (if (numberp mtime) mtime utime) +unix-epoch+))) (let (stats) (cond ((and atime mtime) (setq stats (list 'atime atime 'mtime mtime))) ((and (setq stats (stat2-simple pathname)) atime) (setf (getf stats 'atime) atime)) (mtime (setf (getf stats 'mtime) mtime)) (t (return-from touch NIL))) (unless (probe-file pathname) (with-open-file (stream pathname :direction :output ;CHECKME (LW) :if-does-not-exist :create) ())) (setdates2 pathname stats))) #+nil (touch "home:file.mac" :atime t :mtime nil) (defun unix-mtime (pathname) "Return the last modification time of PATHNAME as the number of seconds since Jan 1 1970 UTC." #+(or cmu (and lispworks (not mswindows)) (and clisp syscalls unix) allegro) (restart-case (getf (stat2 pathname) 'mtime) (continue () :report (lambda (stream) (format stream "Stat(mtime) Failed on ~A. Return 0." pathname)) 0)) #-(or cmu (and lispworks (not mswindows)) (and clisp syscalls unix) allegro) (let ((x (ignoring-errors (file-write-date pathname)))) (cond (x (- x +unix-epoch+)) (t (cerror "Return 0 and Continue." "UNIX-MTIME ~A failed." pathname) 0)))) (defsetf unix-mtime (pathname) (unix-time) #+cmu `(unix:unix-utimes (unix::unix-namestring ,pathname) ,unix-time 0 ,unix-time 0) #-cmu `(with-simple-restart (continue "Skip ~S(~S)" ,pathname ,unix-time) (with-defaults (:output *standard-output*) (run2 "touch" (namestring (truename ,pathname)) "-m" "-t" (yymmddhhmm :stream nil :tz 0 :utime (universal-time ,unix-time)))))) (export '(with-file-dates-preserved touch unix-mtime)) #+nil (defun upcase-filename (p) (merge-pathnames (string-upcase (file-namestring p)) (make-pathname :name nil :version nil :type nil :defaults p) nil)) #+nil (defun rename-spaces-in-files (pathname-list) (loop for f in pathname-list for name = (pathname-name f) for new-name = (substitute #\_ #\space name) for g = (make-pathname :name new-name :defaults f) do (rename-file f g))) ;; Sun Jul 18 04:07:39 2004 +0530 (defun mac2unix-s (instream outstream) (loop for c1 = (read-char instream nil) while c1 if (char= c1 #\Return) do (terpri outstream) else do (write-char c1 outstream))) (defun mac2unix (path) (let ((stats (stat2-simple path)) (contents (with-output-to-string (outstream) (with-open-file (instream path :direction :input) (mac2unix-s instream outstream))))) (with-open-file (outstream path :direction :output :if-exists :supersede) (write-string contents outstream)) (setdates2 path stats)) path) ;;; ---------------------------------------------------------------------- ;;; ;;; DIRECTORY TRAVERSAL ;;; ;;; PROBE-DIRECTORY -- "Returns truename of PATH if PATH denotes a directory." ;;; #+clisp (defvar *original-probe-directory* #'ext:probe-directory) #+clisp (defun user::probe-directory (p) (cond ((ignoring-errors (funcall *original-probe-directory* p)) (truename p)) ((let ((x (directory-pathname p))) (when (ignoring-errors (funcall *original-probe-directory* x)) (truename x)))))) #+clisp (assert (fboundp 'PROBE-DIRECTORY)) #+allegro (assert (eq 'probe-directory 'excl::probe-directory)) ;;CLISPBUG (cond ((not (fboundp 'probe-directory)) (defun probe-directory (path) (let ((p (probe-file path))) (when p (probe-file (directory-pathname p))))))) #|| (probe-file "/tmp/xyz/foo/bar/foo") => #P"/tmp/xyz/foo/bar/foo" => #P"/tmp/xyz/foo/" (LW) (probe-directory "/tmp/xyz") => #P"/tmp/xyz/" (LW) => #P"/tmp/xyz" (ACL) (probe-directory "/tmp/xyz/") => #P"/tmp/xyz/" (probe-directory "/tmp/xyz/foo/bar/foo") => #P"/tmp/xyz/foo/" (LW) => #P"/tmp/xyz/foo/bar/foo" (ACL) (probe-directory "/tmp/xyz/foo/bar/foo/") => #P"/tmp/xyz/foo/" (LW) => #P"/tmp/xyz/foo/bar/foo/" (probe-directory "/tmp/xyz/foo/dummy0.txt") ; NIL (probe-directory "/tmp/xyz/foo/dummy0.txt-not-there") ;NIL (probe-directory "/tmp/xyz/foo/badlink.txt") ;NIL (probe-directory "/tmp/xyz/foo/link0.txt") ;NIL (ensure-directories-exist "/tmp/zzz/foo/" :verbose t) (user:in-directory "/tmp/zzz/" (user:run2 "ln" "-svf" "foo" "bar")) (user:in-directory "/tmp/zzz/" (user:run2 "ln" "-svf" "bar" "car")) (directory-p "/tmp/zzz/car") ; NIL (directory-p "/tmp/zzz/car" (stat2-simple "/tmp/zzz/car")) ; T ||# #+nil (defun find-dired-f (p &optional f) "OBSELETE. If F returns non-NIL, the return value was collected instead of the pathname." (loop for x in (directory (make-pathname :defaults p)) if (probe-directory x) nconc (find-dired-f x f) into inferiors else collect (or (and f (funcall f x)) x) into subs finally (return (nconc subs inferiors)))) ;;; ;;; ;;; (defvar *dired-truenamep* t) (defvar *dired-truenamep-broken-on-clisp-ok* nil) (defun my-directory (pathname) "Internal Helper function for DIRED, which see." (prog (my-directory-retry) (declare (special my-directory-retry)) retry (catch 'my-directory-error (return #+lispworks ;; LINK-TRANSPARENCY: Not applicable on windows. Initial value ;; T. Setting this value to NIL gives non-ANSI behaviour, and ;; truenames are not returned. NON-EXISTENT-LINK-DESTINATIONS: ;; Initial value NIL. Setting this value to T would include symlinks ;; with invalid targets. (let ((list (directory pathname :link-transparency nil :directories nil :non-existent-link-destinations T))) (if *dired-truenamep* (delete-duplicates (map-into list (lambda (x) (or (ignoring-errors (truename x)) x)) list) :test #'equal) list)) #+cmu ;; TRUENAMEP: Initial value T. Setting this value to NIL means ;; symbolic links in the result are not expanded. FOLLOW-LINKS: ;; Initial value T. Setting this to NIL then symbolic links are not ;; followed. (let ((list (directory pathname :all nil :check-for-subdirs nil :truenamep nil :follow-links t))) (if *dired-truenamep* (delete-duplicates (map-into list (lambda (x) (or (ignoring-errors (truename x)) x)) list) :test #'equal) list)) #+clisp (progn (unless *dired-truenamep* (unless *dired-truenamep-broken-on-clisp-ok* (restart-case (assert *DIRED-TRUENAMEP* (*DIRED-TRUENAMEP*) "MY-DIRECTORY: CLISP does not support non-ANSI semantics.") (truenamep-broken-on-clisp-ok () :report "Don't show this error again in this lisp session." (setq *dired-truenamep-broken-on-clisp-ok* t))))) (delete-duplicates (nconc (directory (make-pathname :name nil :type nil :version nil :defaults pathname :directory (append (pathname-directory pathname) '(:wild))) :circle t :if-does-not-exist :keep) (directory (make-pathname :name :wild :type nil :version nil :directory (pathname-directory pathname) :defaults pathname) :circle t :if-does-not-exist :keep)) :test #'equal)) #+allegro (let* ((list1 (directory pathname :directories-are-files nil)) (list2 (directory pathname :directories-are-files t)) (files (intersection list1 list2 :test #'equal)) (dirs-as-files (set-difference list2 files :test #'equal))) #+nil (warn "list1=~S list2=~S dirs-as-files=~S" list1 list2 dirs-as-files) (nconc files (loop for x in dirs-as-files with y if (and *dired-truenamep* (symbolic-link-p x) (setq y (ignore-errors (truename x)))) collect (if *dired-truenamep* y x) else collect x))))) (when my-directory-retry (setq my-directory-retry nil) (go retry)))) #|| (let ((*DIRED-TRUENAMEP* nil)) (my-directory "/tmp/xyz/foo/")) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar" #P"/tmp/xyz/foo/dummy0.txt" #P"/tmp/xyz/foo/emptydir") (let ((*DIRED-TRUENAMEP* T)) (my-directory "/tmp/xyz/foo/")) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/dummy0.txt") (let ((*DIRED-TRUENAMEP* t)) (my-directory "/tmp/xyz/foo/bar/")) => (#P"/tmp/xyz/foo/") (let ((*DIRED-TRUENAMEP* nil)) (my-directory "/tmp/xyz/foo/bar/")) => (#P"/tmp/xyz/foo/bar/foo") (let ((*DIRED-TRUENAMEP* t)) (my-directory #p"/tmp/xyz/foo/bar/foo/bar/foo")) => (#P"/tmp/xyz/foo/") (let ((*DIRED-TRUENAMEP* nil)) (my-directory #p"/tmp/xyz/foo/bar/foo/bar/foo")) => (#P"/tmp/xyz/foo/bar/foo/bar/foo") => (#P"/tmp/xyz/foo/bar/foo/bar/foo/") ; LW ;; NOTE: LW returns ONLY directories even when DIRED-TRUENAME is NIL. ||# ;;; ;;; (defun descend-dired (path f depth maxdepth) "Internal helper function for DIRED which see." (if (etypecase maxdepth (null t) (function (funcall maxdepth path depth)) (number (< (1+ depth) maxdepth))) (dired path f (1+ depth) maxdepth) (list path))) (defvar *dired-follow-links* nil) #+lispworks ;; FIXME WORKAROUND (defun descend-dired-p (x) (if (sys::file-directory-p x) (if *dired-follow-links* (directory-pathname x) (if (not (sys::file-link-p x)) (directory-pathname x))))) ;;madhu 090911 XXX CLISP 2.44-1 BUG compiler gets the following stat2-helper ;; call wrong. #-lispworks (defun descend-dired-p (x) "Internal helper function for DIRED which see." (let ((stats (ignoring-errors (stat2-helper x *dired-follow-links*)))) (when (and stats (directory-p x stats)) (directory-pathname x)))) (defun dired (path &optional f (depth 0) maxdepth &aux p) "If F is non-NIL it should be a function that receieves 3 arguments PATHNAME DEPTH DIRECTORY-P. Maps F on each pathname encountered or collects all pathnames if F is NIL. MAXDEPTH can be NIL (no maximum depth), or a number or a function which takes a directory pathname and its descend-depth and should return non-NIL if that directory is to be descended." (loop for x in (my-directory (make-pathname :name nil :version nil :type nil :defaults path)) if (setq p (descend-dired-p x)) if f do (funcall f p depth t) (descend-dired p f depth maxdepth) else nconc (descend-dired p f depth maxdepth) and collect p else if f do (funcall f x depth nil) else collect x)) #+nil (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/" nil 0 10)) #+nil (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/" (lambda (&rest x) (format t "~&=>~S~&" x)) 0 10)) #|| (let ((*dired-truenamep* t) (*dired-follow-links* t)) (dired #p"/tmp/xyz/" nil 0 1)) => (#P"/tmp/xyz/foo/") (let ((*dired-truenamep* t) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/" nil 0 1)) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/dummy0.txt") (let ((*dired-truenamep* nil) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/" nil 0 1)) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/dummy0.txt" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/link0.txt") (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 1)) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/dummy0.txt" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/link0.txt") (let ((*dired-truenamep* t) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 1)) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/dummy0.txt") (let ((*dired-truenamep* t) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/bar/" nil 0 1)) => (#P"/tmp/xyz/foo/") (let ((*dired-truenamep* nil) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/bar/" nil 0 1)) => (#P"/tmp/xyz/foo/bar/foo/") (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/bar/" nil 0 1)) => (#P"/tmp/xyz/foo/bar/foo") (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/bar/foo/bar/foo" nil 0 10)) => (#P"/tmp/xyz/foo/bar/foo/bar/foo") (stat2-simple "/tmp/xyz/foo/bar/foo/") ;16877 (stat2-simple "/tmp/xyz/foo/bar/foo") ;16877 (CMUCL) (stat2 "/tmp/xyz/foo/bar/foo/") ;16877 (CMUCL) 41471 (LW) (stat2 "/tmp/xyz/foo/bar/foo") ;41471 (unix:unix-lstat (stat2 (probe-directory "/tmp/xyz/foo/bar/foo/")) (directory-p "/tmp/xyz/foo/bar/foo") ;NIL (LW,CMUCL) (directory-p "/tmp/xyz/foo/bar/foo/") ;NIL (LW) T (CMUCL) (symbolic-link-p "/tmp/xyz/foo/bar/foo") ;T (LW) (getf (stat2 "/tmp/xyz/foo/bar/foo/") 'mode) ;41471 (list S_IFMT S_IFREG S_IFLNK S_IFDIR) (system::file-directory-p "/tmp/xyz/foo/bar/foo/") (symbolic-link-p "/tmp/xyz/foo/bar/foo/") ;T (LW) NIL (CMUCL, ACL) (let ((*dired-follow-links* t)) (dired "/tmp/xyz/" nil 0 10)) (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 10)) (let ((*dired-truenamep* nil) (*dired-follow-links* t)) (dired "/tmp/xyz/" nil 0 10)) (let ((*dired-truenamep* nil) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/bar/foo/bar/foo" nil 0 10)) (let ((*dired-truenamep* T) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 10)) (let ((*dired-truenamep* nil) (*dired-follow-links* T)) (dired #p"/tmp/xyz/foo/" nil 0 10)) (let ((*dired-truenamep* T) (*dired-follow-links* T)) (dired #p"/tmp/xyz/foo/" nil 0 10)) ;; INVALID USAGE: (dired #p"/tmp/xyz/foo/bar/" (lambda (&rest x) (print x)) 0 10) (dired #p"/tmp/xyz/foo/bar/" nil 0 4) (dired #p"/tmp/xyz/" (lambda (&rest x) (print x)) 0 10) (dired #p"/tmp/xyz/" nil 0 10) ;;; INVALID (let ((*dired-truenamep* nil) (*dired-follow-links* T)) (dired #p"/tmp/xyz/foo/" nil 0 10)) ;;; INVALID (let ((*dired-truenamep* T) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/bar/" nil 0 10)) ;;; VALID (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 10)) (dired "/home/madhu/cmu/src/code/" nil 0 1) (dired "home:cmu/src/code" nil 0 1) (length (dired #p"home:cmu/glibc22/"))) ||# ;; ;; DIRED EXAMPLES ;; (defun ls (&optional (dir (pwd)) &key (stream *standard-output*)) "~%~{~<~%~,70:;~a~>~^~t~}~%" (declare (ignore stream)) (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (let ((p (probe-directory dir))) (mapcar (lambda (pathname) (enough-namestring pathname p)) (dired p nil 0 1))))) #|| (ls "/tmp/xyz/") (ls "/tmp/xyz/foo/") (ls "/tmp/xyz/foo/bar") (ls "/tmp/xyz/foo/bar/") (let ((*dired-truenamep* nil)) (ls "/tmp/xyz/foo/bar/")) ||# ;; cl-fad compatible: blows up on circular links. (defun walk-directory (root-directory visitor &key directories test) (flet ((f (file depth directory-p) (declare (ignorable depth)) (when directory-p (unless directories (return-from f nil))) (when (or (null test) (and test (funcall test file))) (funcall visitor file)))) (dired root-directory #'f))) #|| (walk-directory "/tmp/xyz/" #'print) (walk-directory "/tmp/xyz/" #'print :directories t) ||# (defun sort-files (path &optional (predicate #'<) &key (key (lambda (pathname) (unix-mtime pathname)) key-supplied-p) (n 10) (datep (not key-supplied-p)) (ignore-rcsdirs t) (rcsdirs '(".git" "RCS" "CVS" ".hg" ".svn" "_darcs"))) "If KEY is not specified sort files rooted under PATH by modification time. If N is non-nil limit output to N items." (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (let (clist (clength 0)) (labels ((descendp (dir depth) (declare (ignore depth)) (let ((dircomp (pathname-directory dir))) (loop for (comp . rest) on dircomp when (endp rest) if (and ignore-rcsdirs (some (lambda (x) (string= comp x)) rcsdirs)) return nil finally (return t)))) (snarf-mtime (pathname depth dirp) (declare (ignore depth)) (unless dirp (let ((x (funcall key pathname))) (cond ((or (endp clist) (or (null n) (< clength n)) (funcall predicate x (cdar (nthcdr (1- n) clist)))) (setq clist (insert-ordered (cons pathname x) clist predicate :key #'cdr)) (when n (cond ((< clength n) (incf clength)) (t (setq clist (nbutlast clist 1))))))))))) (DIRED path #'snarf-mtime 0 #'descendp)) (if datep (loop for (mfile . mtime) in clist collect (cons mfile (DATE :stream nil :utime (universal-time mtime)))) clist)))) #|| (sort-files "/tmp/xyz/") ||# (defun cache-value (key value-function indicator lookup-table &key (if-does-not-exist :create) (if-exists :check) (default nil default-supplied-p) revlookup-table (test (hash-table-test lookup-table))) "Internal. Intern KEY as a hash-key in LOOKUP-TABLE. The hash-value is a property list, which includes the specific property identified by INDICATOR which refers to the `VALUE'. VALUE-FUNCTION funcalled on KEY produces this `VALUE' which is turn interned as a hash-key in REVLOOKUP-TABLE, if the latter is non-NIL. and the hash-value is a list which contains KEY, under TEST. If IF-DOES-NOT_EXIST is CREATE and DEFAULT is supplied, it is used instead of calling VALUE-FUNCTION to produce the `VALUE'. If IF-EXISTS is CHECK, an error is signalled if DEFAULT does not match match the `VALUE'." (multiple-value-bind (value1 foundp1) (gethash key lookup-table) (unless foundp1 (when (eq if-does-not-exist :error) (error "Key ~A missing in table ~S." key lookup-table))) (let ((checksum (getf value1 indicator '%%doesnotexist))) (cond ((eq checksum '%%doesnotexist) (ecase if-does-not-exist (:soft default) (:error (error "Property ~S of key ~S not cached in table ~S." indicator key lookup-table)) (:create (let ((value2 (if default-supplied-p default (funcall value-function key)))) (setf (getf (gethash key lookup-table) indicator) value2) (when revlookup-table (pushnew key (gethash value2 revlookup-table) :test test)) value2)))) (t (ecase if-exists (:soft checksum) (:error (error "Property ~S of key ~S cached in table ~S: ~S." indicator key lookup-table checksum)) (:remf (remf (gethash key lookup-table) indicator)) ((:check :recompute) (let ((value2 (if default-supplied-p default (funcall value-function key)))) (cond ((eq if-exists :check) (assert (funcall test checksum value2) nil "Checking key ~S on property ~S: Cached value ~S differs from computed value ~S in table ~S." key indicator checksum value2 lookup-table) (when revlookup-table (assert (find key (gethash value2 revlookup-table) :test test) nil "Checking key ~S on property ~S: key missing from reverse lookup table ~S." key indicator revlookup-table))) ((eq if-exists :recompute) (setf (getf (gethash key lookup-table) indicator) ; value2) (when revlookup-table (pushnew key (gethash value2 revlookup-table) :test test)))) value2)))))))) ;; FUNKY EMACS INDENT ;; FIXME. LW requires you to probe-file before calling this function. (defun sha1sum (pathname) ;; runs external program "Return a string signature or NIL on failure." (let* ((namestring (namestring pathname)) (output (with-output-to-string (stream) (with-defaults (:output stream) (or (with-simple-restart (continue "Ignore (sha1sum).") (run2 "sha1sum" "-t" namestring)) (return-from sha1sum nil))))) (pos (search namestring output))) (values (subseq output 0 (- pos 2)) namestring))) #|| HERE (with-defaults (:output :stream) (run2 "sha1sum" "-t" "/home/madhu/.clisprc.lisp")) (list $stdin $stdout $pty) (with-output-to-string (ostream) (copy-buffered-io $stdout ostream :element-type 'character)) ||# #|| (sha1sum "/tmp/xyz/foo/dummy0.txt") => "da39a3ee5e6b4b0d3255bfef95601890afd80709", "/tmp/xyz/foo/dummy0.txt" (sha1sum #p"/tmp/xyz/foo/dummy0.txt-not-there") => "sha1sum", "/tmp/xyz/foo/dummy0.txt-not-there" ; lw ;; cmucl -> error in run-program (fdupes "/tmp/xyz/" t) ;; lw -> huge list #+cmu (handler-bind ((error (lambda (c &aux (r (find-restart 'ignore-fdupes))) (and r (invoke-restart r))))) (fdupes "/tmp/xyz/" t)) ||# (defun fdupes (root-directory &optional recurse-p) (let ((sha1-hash (make-hash-table :test #'equal)) (path-hash (make-hash-table :test #'equal)) (*dired-truenamep* NIL) (*dired-follow-links* nil)) ;cmu, lw (flet ((grok-sha1sum (pathname depth directory-p) (declare (ignore depth)) (unless directory-p (with-simple-restart (ignore-fdupes "Ignore") (assert (not (probe-directory pathname))) (cache-value pathname #'sha1sum :sha1sum path-hash :revlookup-table sha1-hash :if-does-not-exist :create :if-exists :error))))) (loop for r in (typecase root-directory (cons root-directory) (t (list root-directory))) do (dired r #'grok-sha1sum 0 (if recurse-p nil 1))) (loop for sha1sum being each hash-key of sha1-hash using (hash-value files) if (cdr files) collect files)))) #+nil (fdupes "/tmp/xyz/" t) (defun find-empty-dirs (p &optional include-non-empty-dirs-p) ;madhu 040914 "Return a list of pathnames of empty directories. If INCLUDE-NON-EMPTY-DIRS-P is non-NIL, include directories that contain only empty subdirectories (recursively), in the result." (declare (special my-directory-retry)) (let ((*dired-truenamep* NIL) (*dired-follow-links* T)) ; cmu (loop for x in (my-directory (make-pathname :name nil :type nil :version nil :defaults p)) for d = (probe-directory x) if (and d (not (ignoring-errors (symbolic-link-p x)))) collect d into dirs else count x into files finally (return (if (and (null dirs) (zerop files)) (list p) (let ((subdirs (loop for y in dirs when (find-empty-dirs y include-non-empty-dirs-p) nconc it))) (if (and include-non-empty-dirs-p (zerop files)) (if (remove-if (lambda (a) (member a subdirs :test #'equalp)) dirs) subdirs (cons p subdirs)) subdirs))))))) #+nil (find-empty-dirs #p"/tmp/xyz/") ;;; ---------------------------------------------------------------------- ;;; ;;; MISC MACROS ;;; (defun make-case-equal-forms (which &key (test 'equal) ecasep clauses) "Internal. TODO: LIFT the TEST into a FLET inside the returned body." (let* ((switch (gensym)) final matches test-fvar (test1 (labels ((f (x) (etypecase x (symbol x `(,x)) (function `(funcall ,(setq test-fvar (gensym)))) (cons (f (eval x)))))) ;XXX (f test)))) `(let ((,switch ,which) ,@(if test-fvar `((,test-fvar ,test)))) (cond ,@(loop for ((match . action) . rest) on clauses collect `(,(if (consp match) `(or ,@(loop for x in match collect `(,@test1 ,switch ',x))) (if (and (symbolp match) (or (eq match t) (eq match :otherwise))) (if ecasep (error ":OTHERWISE or T not allowed in ECASE.") (setq final 't)) (progn (push match matches) `(,@test1 ,switch ,match)))) ,@(if action action '(nil))) if (and ecasep (endp rest)) collect `(t (error "ECASE fell through. Wanted one of ~S. Got ~S." ',(reverse matches) ,switch)) if (and final (not ecasep)) do (if rest (error ":OTHERWISE or T not last clause in CASE.") (loop-finish))))))) (defmacro case-equal (which &body clauses) "Like case but uses EQUAL. Treats :OTHERWISE and T specially." (make-case-equal-forms which :test 'equal :ecasep nil :clauses clauses)) (defmacro ecase-equal (which &body clauses) "Like ecase but uses EQUAL. Treats :OTHERWISE and T specially." (make-case-equal-forms which :test 'equal :ecasep t :clauses clauses)) (defmacro super-case ((which &key (test #'eql) ecasep) &body clauses) "NOTE: May Evaluate TEST!" (make-case-equal-forms which :test test :ecasep ecasep :clauses clauses)) (export '(case-equal ecase-equal super-case)) ;;; ---------------------------------------------------------------------- ;;; ;;; QUADRANTS, MATH ACCURACIES - PORTABLE ;;; ;;; ^ ;;; | ;;; II | I ;;;pi<----+---->0 ;;; III | IV ;;; | ;;; v (defun degrees->radians (degrees) (* pi degrees 1/180)) (defun degrees-mod180 (degrees) "Returns a value which lies in [-180 180]" (if (plusp degrees) (if (> (setq degrees (mod degrees 360)) 180) (mod degrees -180) degrees) (if (< (setq degrees (mod degrees -360)) -180) (mod degrees 180) degrees))) (defun radians->degrees (radians) (degrees-mod180 (* 180 (/ pi) radians))) #+nil (radians->degrees (degrees->radians 0.0d0)) ;; ;; from pktype <26-Sep-03 03:42:39 IST, madhu> ;; (defun round-to-accuracy (value digits-after-decimal-point) "Internal. Round VALUE to DIGITS decimal places." (declare (type (integer 0 10) digits-after-decimal-point)) (let ((precision (expt 10 digits-after-decimal-point))) (if (integerp value) value (coerce (/ (round (* precision value)) precision) (type-of value))))) (defconstant $1mb 1024) (defconstant $1gb (* $1mb $1mb)) (defun mb (&rest bytes) (/ (reduce #'+ bytes) (* 1024.0 1024.0))) (defun print-human (kb &optional stream &aux (abs (abs kb))) "Return a string unless STREAM is non-NIL." (multiple-value-bind (quantity units) (if (> abs $1gb) (values (round-to-accuracy (/ kb $1gb 1.0) 2) #\G) (if (> abs $1mb) (values (round-to-accuracy (/ kb $1mb 1.0) 2) #\M) (values kb #\K))) (format stream "~A~A" quantity units))) ;;; ---------------------------------------------------------------------- ;;; ;;; LIST UTILITIES - PORTABLE ;;; (defun compose (&rest functions) ; composes functions as if by m-v-c (lambda (&rest args) (values-list (reduce #'(lambda (&optional f x) (if f (multiple-value-list (apply f x)) x)) functions :from-end t :initial-value args)))) (defun group2 (list &key (test #'eql) (key #'identity)) "Internal. Return an alist, the cdr of each element of which is a list of elements of LIST which are grouped together; while the car is the value under KEY by which they are grouped. From f1pq5c$m8o$1@registered.motzarella.org." (let ((result nil)) (dolist (el list) (let* ((entry-key (funcall key el)) (entry (assoc entry-key result :test test))) (if entry (pushnew el (cdr entry)) (push (list entry-key el) result)))) result)) (export '(compose group2)) #+nil (defun nshuffle (seq &aux (len (length seq))) (loop for i below len for j = (random len) unless (= i j) do (rotatef (elt seq i) (elt seq j))) seq) #+nil (defun shuffle-n (seq &optional (k (length seq) k-supplied-p)) "shuffle all of SEQ. Stop when k elements have been shuffled. This generalizes Knuth's algorithm" ; (let ((n (length seq))) (dotimes (i k seq) (rotatef (elt seq i)(elt seq (+ i (random (- n i)))))))) #+nil (defun mapsome (predicate list &rest more-lists) "" (apply #'mapcan (lambda (&rest args) (when (apply predicate args) (copy-list args))) list more-lists)) #+nil (defun delete-nth (list position) "Deletes the item at position POSITION in list LIST. Modifies LIST. Returns a list of 2 elements: the deleted item and the modified list." (check-type position (integer 0)) (cond ((zerop position) (list (car list) (cdr list))) (t (let* ((tail (nthcdr (1- position) list)) (item (cadr tail))) (when tail (rplacd tail (cddr tail))) (list item list))))) #+nil (defun plist-sans-keys (plist &rest keys) ; <3247672165664225@naggum.no> (loop with sans for tail = (nth-value 2 (get-properties plist keys)) unless tail return (nreconc sans plist) do (loop until (eq plist tail) do (push (pop plist) sans) (push (pop plist) sans)) (setq plist (cddr plist)))) ;; ;; madhu 051224 GLB,LUB ;; (defun popmax (list &optional (cmp #'>) &key key) "destroy LIST while removing and returning the maximum element. Second value is the LIST." (when list (let ((max-cons list) max-prev-cons) (loop for prev-cons = list then cons for cons on (cdr list) if (funcall cmp (if key (funcall key (car cons)) (car cons)) (if key (funcall key (car max-cons)) (car max-cons))) do (setf max-cons cons max-prev-cons prev-cons)) (cond (max-prev-cons (setf (cdr max-prev-cons) (cdr max-cons)) (values (car max-cons) list)) (t (assert (eq max-cons list)) (values (car max-cons) (cdr max-cons))))))) (defun insert-ordered (item list &optional (predicate #'<) &key key test test-not) "Insert ITEM in LIST. may modify LIST. LIST is assumed to be sorted by PREDICATE. If TEST (or TEST-NOT) is non-NIL, it is used to determine if ITEM is present (or absent) in LIST, in which case it is not inserted. KEY if non-NIL is applied to both ITEM and elements of LIST before comparing them. However, unlike section 17.2.1 of the spec, if both TEST and TEST-NOT are NIL, no test is made." (if (endp list) (list item) (macrolet ((apply-key (key element) `(if ,key (funcall ,key ,element) ,element))) (let ((item-key (apply-key key item)) (obj-key (apply-key key (car list)))) (cond ((cond (test (funcall test item-key obj-key)) (test-not (not (funcall test-not item-key obj-key)))) list) ((funcall predicate item-key obj-key) (cons item list)) (t (loop for prev-cons = list then cons for cons on (cdr list) do (setq obj-key (apply-key key (car cons))) if (cond (test (funcall test item-key obj-key)) (test-not (not (funcall test-not item-key obj-key)))) return list else if (funcall predicate item-key obj-key) do (loop-finish) finally (setf (cdr prev-cons) (cons item cons)) (return list)))))))) (defmacro pushnew-ordered (obj place predicate &rest keys &environment env) "OBSOLETE." (if (and (null (getf keys :test)) (null (getf keys :test-not))) (setf (getf keys :test) '#'eql)) ; XXX even if Keys is a literal. (if (and (symbolp place) (eq place (macroexpand place env))) `(setq ,place (insert-ordered ,obj ,place ,predicate ,@keys)) (multiple-value-bind (vars vals stores setter getter) (get-setf-expansion place env) (cond ((cdr stores) ;; Multiple values (let ((g (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (rest obj)))) `(multiple-value-bind ,g ,obj (let* (,@(mapcar #'list vars vals)) (multiple-value-bind ,stores (values ,@(mapcar #'(lambda (a b) `(insert-ordered ,a ,b ,predicate ,@keys)) g (rest getter))) ,setter))))) (t ;; Single value (let ((g (gensym))) `(let* ((,g ,obj) ,@(mapcar #'list vars vals) (,@stores (insert-ordered ,g ,getter ,predicate ,@keys))) ,setter))))))) (defun ordered-intersection (list1 list2 predicate) "LIST1 and LIST2 are SORTED LISTS, ordered according to PREDICATE." (when (and list1 list2) (let (ret (car1 (car list1))(car2 (car list2))) (loop (when (or (endp list1) (endp list2)) (return)) (cond ((funcall predicate car1 car2) (setq list1 (cdr list1) car1 (car list1))) ((funcall predicate car2 car1) (setq list2 (cdr list2) car2 (car list2))) (t ;; deemed equal (push car1 ret) (setq list1 (cdr list1) car1 (car list1) list2 (cdr list2) car2 (car list2))))) (nreverse ret)))) #+nil (defun %last (vector &key (if-does-not-exist :soft)) (declare (type vector vector)) (let ((length (length vector))) (cond ((zerop length) (ecase if-does-not-exist (soft nil) (error "Cannot aref the last element of an empty vector"))) (t (aref vector (1- length)))))) #+nil (defsetf %last (vector) (new-element) (declare (type vector vector)) `(let ((length (length ,vector))) (cond ((zerop length)) (t (setf (aref ,vector (1- length)) ,new-element))))) #+nil (defun %butlast (vector &optional) (declare (type vector vector)) (let ((length (length vector))) (subseq vector 0 (1- length)))) #+nil (defun %nbutlast (vector &optional) (declare (type vector vector)) (let ((length (length vector))) (if (array-has-fill-pointer-p vector) (prog1 vector (setf (fill-pointer vector) (1- length))) (%butlast vector)))) #-allegro (defun suffixp (suffix sequence &key (test #'equalp) &aux idx) "Ends with" (or (null (setq idx (mismatch suffix sequence :from-end t :test test))) (zerop idx))) #-allegro (defun prefixp (prefix sequence &key (test #'equalp) (start1 0) (start2 0) end1 end2 &aux idx) "Begins with" (or (null (setq idx (mismatch prefix sequence :test test :start1 start1 :start2 start2 :end1 end1 :end2 end2))) (>= idx (length prefix)))) (export '(prefixp suffixp)) ;; ;; madhu 050827 ;; #+nil (defun assq (KEY LIST) "Return non-nil if KEY is `eq' to the car of an element of LIST. The value is actually the first element of LIST whose car is KEY. Elements of LIST that are not conses are ignored." (loop for elem in list when (consp elem) do (destructuring-bind (car . cdr) elem (declare (ignore cdr)) (if (eq car key) (return elem))))) ;; ;; LOOP version of ;; IOTA ;; #+nil (defun range (begin end &optional (step 1 step-supplied-p)) (assert (not (zerop step))) (when (< end begin) (if step-supplied-p (unless (< step 0) (setq step (- step))) (setq step -1))) (loop for i below (ceiling (/ (- end begin) step)) collect (+ begin (* i step)))) ;;; ;;; 04-10-13 ;;; #+nil (defun implies (&rest clauses) (reduce (lambda (p q) (if p (if q t nil) t)) clauses)) #+nil (defun generate-e () ;; Author: nate holloway [Fri Oct 15 2004] (loop with n fixnum = 1 and x = 1 and y = 0 for old-digit = -1 then digit and digit = (truncate (+ y (/ x))) if (= old-digit digit) do (princ old-digit) (setq y (* (rem y 1) 10) x (/ x 10) digit (truncate y)) else do (setq x (* n x) n (1+ n) y (+ y (/ x))))) #+nil (defun cross (&rest lists) "" (reduce (lambda (list crosses) (mapcan (lambda (item) (mapcar (lambda (cross) (cons item cross)) crosses)) list)) lists :from-end t :initial-value '(()))) #+nil (defun uncross (list) ; madhu 050909 ;; for LIST of lots of sets of small cardinality (let ((result (make-array (length (car list)) :initial-element nil))) (loop for items in list do (loop for elem in items for i from 0 do (pushnew elem (aref result i)))) (map 'list 'nreverse result))) #+nil (defun prime-p (n) (loop for i from 2 to (isqrt n) never (zerop (mod n i)))) #+nil (defun nchoplist (item list) "NCHOPLIST (ITEM LIST) where ITEM is of the form (a0 .ITEM .... an) => Values (a0 ...), (ITEM .. an) -- if ITEM is in LIST, NIL otherwise. NOTE: Uses EQL to test if ITEM is in LIST. May modify LIST." (cond ((eql item (car list)) (values nil list)) (t (loop for prev = list then curr for curr = (cdr prev) then (cdr curr) while curr if (eql item (car curr)) return (multiple-value-prog1 (values list curr) (setf (cdr prev) nil)))))) #+nil (defun NREMOVE-AT (index list) "<87vfcteo3a.fsf@eva.rplacd.net>" (declare (inline NREMOVE-AT) (type (integer 0) index) (type list list)) (when (zerop index) (return-from NREMOVE-AT (cdr list))) (rplacd #1=(nthcdr (1- index) list) (cddr #1#)) list) #+nil (define-setf-expander nthcdr (n place &environment env) " <878y9pfbec.fsf@Astalo.kon.iki.fi> -- kon" (multiple-value-bind (vars vals store-vars writer-form reader-form) (get-setf-expansion place env) (let* ((gn (gensym)) (gstore (if store-vars (first store-vars) (gensym "STORE")))) (values (list* gn vars) (list* n vals) (list gstore) ;; Intentionally leaves 0.0 unrecognized. `(if (eql ,gn 0) ,(case (length store-vars) (0 `(progn ,writer-form ,gstore)) (1 writer-form) (t `(let ,(rest store-vars) (values ,writer-form)))) (setf (cdr (nthcdr (1- ,gn) ,reader-form)) ,gstore)) `(nthcdr ,gn ,reader-form))))) ;; TODO FIXME pass a set of sort keys instead #+nil (defun make-lexicographic-comparator (&key (test #'<) (sort-keys (list 'identity)) (lhs-symbol 'x) (rhs-symbol 'y)) (labels ((make-simple-form (lhs rhs func) `(,test (,func ,lhs) (,func ,rhs))) (make-ordering-form (lhs-sym rhs-sym &key (test '<) keys) " S.E.Harris" (when keys (if (null (cdr keys)) (make-simple-form lhs-sym rhs-sym (car keys)) `(or ,(make-simple-form lhs-sym rhs-sym (car keys)) (and (not ,(make-simple-form rhs-sym lhs-sym (car keys))) ,(make-ordering-form lhs-sym rhs-sym :test test :keys (cdr keys)))))))) `(lambda (,lhs-symbol ,rhs-symbol) ,(make-ordering-form lhs-symbol rhs-symbol :test test :keys sort-keys)))) #+nil (make-lexicographic-comparator :test '> :sort-keys '(priority1 priority2)) #+nil (defun flatten (x &aux stack result) ; madhu 061207 ;; (flet ((rec (item) (if (atom item) (push item result) (loop for elem in item do (push elem stack))))) (declare (inline rec)) (rec x) (loop while stack do (funcall #'rec (pop stack))) result)) #+nil (defun tree-depth (tree &aux (global-depth 0) stack) ; madhu 061123 ;; ;; (flet ((level (list depth) (when (> (1+ depth) global-depth) (setq global-depth (1+ depth))) (loop for node in list when (consp node) do (push (list node (1+ depth)) stack)))) (declare (inline level)) (cond ((null tree) 0) ((atom tree) 1) (t (level tree 0) (loop while stack do (apply #'level (pop stack))) global-depth)))) (defun position-ordered (elem array &optional (predicate #'<) &key (test #'eql) (start 0) end key) ;TESTME "Return the index of ELEM in the sorted sequence ARRAY, sorted by PREDICATE by performing binary search. KEY if supplied is not applied to ELEM, and defaults to IDENTITY." (loop with low = start and high = (or end (length array)) for middle = (floor (+ high low) 2) while (< 1 (- high low)) do (if (funcall predicate elem (if key (funcall key (elt array middle)) (elt array middle))) (setf high middle) (setf low middle)) finally (if (funcall test elem (if key (funcall key (elt array low)) (elt array low))) (return low)))) ;; Example: Mon Dec 24 07:37:59 2007 +0530 (defun remove-common-delimited-prefix (sorted-sequence delim-char &key key) "SORTED-SEQUENCE is a sequence of non-empty strings sorted by #'STRING<, each of which has components delimited by DELIM-CHAR. This function returns a new sequence which excludes strings which are proper prefixes of other strings in the sequence. KEY if not supplied defaults to IDENTITY." (let ((i 0) (exclude-marker nil) (l (length sorted-sequence))) (delete exclude-marker (map (etypecase sorted-sequence (vector 'vector) (list 'list)) (lambda (x) (let* ((elem-x (if key (funcall key x) x)) (length-elem-x (let ((l (length elem-x))) (cond ((eql (char elem-x (1- l)) delim-char) (1- l)) (t l)))) (j (if (< i (1- l)) (position-ordered elem-x sorted-sequence #'string< :start (1+ i) :test (lambda (a b) (when (< length-elem-x (length b)) (string= a b :end1 length-elem-x :end2 length-elem-x))) :key key)))) (incf i) (if (and j (eql (char (if key (funcall key (elt sorted-sequence j)) (elt sorted-sequence j)) length-elem-x) delim-char)) exclude-marker x))) sorted-sequence)))) #+nil (defun removedirs (infile outfile) "find > INFILE. OUTFILE contains only files and empty directories." (with-open-file (stream outfile :direction :output :if-exists :supersede) (write-lines-to-stream (remove-common-delimited-prefix (sort (with-open-file (stream infile) (read-lines-from-stream stream)) #'string<) #\/) stream))) ;; Example Mon Aug 31 11:32:29 2009 +0530 (defun keep-common-delimited-prefix (sorted-sequence delim-char &key (key #'identity)) "SORTED-SEQUENCE is a sequence of non-empty strings sorted by #'STRING<, each of which has components delimited by DELIM-CHAR. This function returns a new sequence which includes only those strings that are proper prefixes of other strings in the sequence." (let* ((i 0) (exclude-marker nil) (elem-x (funcall key (elt sorted-sequence 0))) (length-elem-x (let ((l (length elem-x))) (cond ((eql (char elem-x (1- l)) delim-char) (1- l)) (t l))))) (delete exclude-marker (map (etypecase sorted-sequence (vector 'vector) (list 'list)) (lambda (x &aux (elem-2 (funcall key x))) (if (and (< 0 i) (when (< length-elem-x (length elem-2)) (string= elem-x elem-2 :end1 length-elem-x :end2 length-elem-x))) (progn (incf i) exclude-marker) (progn (incf i) (setq elem-x elem-2 length-elem-x (let ((l (length elem-x))) (cond ((eql (char elem-x (1- l)) delim-char) (1- l)) (t l)))) x))) sorted-sequence)))) ;;; ---------------------------------------------------------------------- ;;; ;;; STREAM UTILITIES ;;; ;; ;; ;; #+nil (defvar *null-stream* (make-two-way-stream ;; #+nil(make-concatenated-stream) ; cmucl bug (make-string-input-stream "") (make-broadcast-stream))) #+nil ; Unix only (defmacro with-flames-to-devnull (&body body) "UTILITY. Bind *ERROR-OUTPUT* to /dev/null while executing BODY" `(with-open-file (*error-output* "/dev/null" :direction :output :if-exists :append) ,@body)) (defmacro with-flames-to-devnull (&body body) "UTILITY. Bind *ERROR-OUTPUT* to /dev/null while executing BODY" `(let ((*error-output* (make-broadcast-stream))) ,@body)) ;;; ---------------------------------------------------------------------- ;;; ;;; STRING UTILITIES = PORTABLE ;;; (defun substr (string &optional (start 0) end) "Like SUBSEQ but on simple base strings, and without allocating space." (make-array (if end (- end start) (- (length string) start)) :element-type (array-element-type string) :displaced-to string :displaced-index-offset start)) (export '(substr)) ;; ;; COMPARATOR [Mon Jun 07 10:23:42 2004 +0530] ;; #+nil (defun cmp (x y &key (start1 0) (start2 0) &aux p q) "Alphanumeric STRING-LESSP." (cond ((and (setq p (position-if #'digit-char-p x :start start1)) (setq q (position-if #'digit-char-p y :start start2))) (or (string-lessp x y :start1 start1 :start2 start2 :end1 p :end2 q) (and (string-equal x y :start1 start1 :start2 start2 :end1 p :end2 q) ; (multiple-value-bind (num1 idx1) (parse-integer x :start p :junk-allowed t) (multiple-value-bind (num2 idx2) (parse-integer y :start q :junk-allowed t) (or (< num1 num2) (and (= num1 num2) ; (cmp x y :start1 idx1 :start2 idx2)))))))) (t (string-lessp x y :start1 start1 :start2 start2)))) #+nil (defun safe-end (p &optional (start 0) end) (let ((len (length p))) (if end (if (<= end len) end (values len T)) len))) (defun safe-string-match-position (match line &key (test #'string=) (start1 0) end1 (start2 0) end2) "Internal. Look for the substring MATCH bounded by indices START1 and END1 in the string LINE (bounded by indices START2 and END2) by calling TEST with all 4 keyword arguments. If matched, return the position in LINE just past the match. Otherwise return NIL. The bounds END1 and END2 are treated as the lengths of MATCH and LINE if they are unspecified, NIL, or if they are larger than the corresponding lengths." (let ((abs-end1 (length match)) (abs-end2 (length line))) (let ((safe-end1 (if end1 (if (<= end1 abs-end1) end1 abs-end1) abs-end1)) (safe-end2 (if end2 (if (<= end2 abs-end2) end2 abs-end2) abs-end2))) (unless (> start1 safe-end1) (let ((len-match (- safe-end1 start1))) (unless (> start2 safe-end2) (when (<= len-match (- safe-end2 start2)) (let ((pos (+ start2 len-match))) (when (funcall test match line :start1 start1 :end1 safe-end1 :start2 start2 :end2 pos) pos))))))))) (defun position-if-find (char-bag string &key from-end (start 0) end) (position-if (lambda (c) (find c char-bag)) string :from-end from-end :start start :end end)) (defun string-split (char-bag string &key (start 0) end (collect-empty t)) (if (characterp char-bag) (setq char-bag (list char-bag))) (loop for begin = start then (1+ pos) for pos = (position-if-find char-bag string :start begin :end end) if (or collect-empty (or (if pos (< begin pos) (< begin (or end (length string)))))) collect (substr string begin (or pos end)) unless pos do (loop-finish))) (export '(substr safe-string-match-position string-split)) #+nil (string-split #\- "-freetype-bn ttdurga-medium-r-normal--22-160-100-100-p-74-bengali-cdac") ;; ;; STRING-SPLIT EXAMPLES ;; #+nil (defun parse-fonts.dir (directory) (let* ((file (make-pathname :name "fonts" :type "dir" :version nil :defaults directory))) (with-open-file (stream file) (let ((len (read stream)) (n 0)) (loop for line = (read-line stream nil) while line do (incf n) (setq line (string-trim '(#\Space #\Tab) line)) collect (let* ((pos1 (position #\Space line)) (pos2 (position #\Space line :from-end t))) (list (substr line 0 pos1) (substr line (1+ pos2)))) finally (assert (= len n))))))) #+nil (parse-fonts.dir #p"/usr/X11R6/lib/X11/fonts/75dpi/") ;;; ---------------------------------------------------------------------- ;;; ;;; READTABLES: VERBATIM STRING READERS - PORTABLE ;;; #+nil (defun $tring-reader (stream $ arg) ; doesnt escape backslash "Obselete" (declare (ignore $ arg)) (unless (char= (read-char stream t) #\") (error 'parse-error)) (loop for c = (read-char stream t) if (char= c #\") do (return (coerce string 'string)) else collect c into string)) ; Eg: (load #$"c:\madhu\vilisp-2.0\_clisprc.lisp") #+nil (set-dispatch-macro-character #\# #\$ #'$tring-reader) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *matching-delim-pairs* '((#\( . #\)) (#\{ . #\}) (#\[ . #\])) "Alist of (LDELIM . RDELIM) characters, for delimiting strings read by VERBATIM-STRING-READER.")) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *use-matching-delim-pairs-p* t "If non-NIL VERBATIM-STRING-READER will look in *MATCHING-DELIM-PAIRS* to find a matching string delimiter.")) (eval-when (:compile-toplevel :load-toplevel :execute) (defun verbatim-string-reader (stream $ arg) (declare (ignore arg) (ignore $)) (let* ((delim (read-char stream t)) (match (or (and *use-matching-delim-pairs-p* (cdr (assoc delim *matching-delim-pairs*))) delim))) (loop for c = (read-char stream t) if (char= c match) return (coerce string 'string) else collect c into string)))) (eval-when (:compile-toplevel :load-toplevel :execute) (set-dispatch-macro-character #\# #\$ #'verbatim-string-reader)) ;; this screws up in emacs and slime (and when loading clisp 2.34) #-clisp (eval-when (:load-toplevel :execute) (setf (documentation 'verbatim-string-reader 'function) #$ lineno -))) do (write-line line output-stream)))) ;; [Sun Jan 30 09:07:53 2005 +0530] (defun uniq (in out &optional ($a (make-hash-table :test #'equal))) "Copies line from IN stream to OUT stream ignoring duplicates. Trims lines of leading and trailing whitespace. Only the last duplicate is retained." ;; 3 passes! (loop for lineno from 0 for line = (read-line in nil nil) while line do (setf (gethash (string-trim '(#\Space #\Tab #\Newline) line) $a) lineno)) (loop for (lineno . line) in (sort (loop for lineno being each hash-value of $a using (hash-key line) collect (cons lineno line)) #'< :key #'car) do (write-line line out))) #+nil (progn (with-open-file (in ".bash_history") (with-open-file (out "/tmp/.bash_history" :direction :output :if-exists :supersede :if-does-not-exist :create) (uniq in out))) ;; madhu 060204 BUG: this rename doesnt work #+nil (rename-file #p".bash_history.new" #p".bash_history.")) (defun copy-buffered-io (input output &key (block-size 4096) (element-type (stream-element-type input)) (buffer (make-array block-size :element-type element-type))) "Copies INPUT into OUTPUT using BLOCK-SIZE blocks." (let ((actual-block-size (length buffer))) (loop for bytes-read = (read-sequence buffer input) do (write-sequence buffer output :end bytes-read) until (< bytes-read actual-block-size) summing bytes-read into total-bytes-written finally (return total-bytes-written)))) (defun |cat a > b| (file1 file2) (with-open-file (input file1 :element-type '(unsigned-byte 8)) (with-open-file (output file2 :direction :io :element-type '(unsigned-byte 8) :if-exists :overwrite :if-does-not-exist :create) (copy-buffered-io input output)))) (defun |cat a >> b| (src dest) (with-open-file (output dest :if-exists :append :if-does-not-exist :create :element-type '(unsigned-byte 8) :direction :output) (with-open-file (input src :element-type '(unsigned-byte 8)) (copy-buffered-io input output)))) (export '(copy-buffered-io |cat a > b| |cat a >> b|)) ;;; ;;; ;;; (defun ensure-buffer-with-capacity (size &key ((:buffer array)) (element-type (if array (array-element-type array) '(unsigned-byte 8)))) "Ensure that the adjustable array with fill-pointer in BUFFER has capcity to hold SIZE elements. BUFFER can be NIL in which case a new adjustable array with fill-pointer of given ELEMENT-TYPE and SIZE is returned." (cond (array (if (< (array-total-size array) size) (adjust-array array size :element-type element-type :fill-pointer t) (prog1 array (setf (fill-pointer array) size)))) (t (make-array size :element-type element-type :fill-pointer t :adjustable t)))) (defun slurp-file (pathname &optional buffer &key (element-type (if buffer (array-element-type buffer) '(unsigned-byte 8)))) "Slurp contents of PATHNAME into an adjustable array with fill-pointer of type ELEMENT-TYPE. BUFFER can be NIL, in which case a new array is allocated and returned, or an adjustable array with fill-pointer of appropriate element-type into which the file contents are read." (with-open-file (f pathname :element-type element-type) (let* ((size (file-length f)) (array (ensure-buffer-with-capacity size :buffer buffer :element-type element-type)) (ret (read-sequence array f))) (when (= ret size) array)))) ;; ;; Fri Oct 06 09:50:00 2006 +0530 ;; #+orig (defun replace-text-in-file (pathname match replacement &key (element-type 'character) buffer (match-len (length match)) (replacement-len (length replacement))) "Replace first occurrence of MATCH with REPLACEMENT" (if (< replacement-len match-len) (let ((array (slurp-file pathname element-type buffer))) (let ((pos (search match array))) (when pos (with-file-dates-preserved (pathname) (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type element-type) (write-sequence array stream :end pos) (write-sequence replacement stream) (write-sequence array stream :start (+ pos match-len)) T))))) (with-file-dates-preserved (pathname) (with-open-file (stream pathname :direction :io :if-exists :overwrite ; MAKE SURE your lisp ;; doesnt treat OVERWRITE as SUPERSEDE. :element-type element-type) (let* ((size (file-length stream)) (array (ensure-buffer-with-capacity size :buffer buffer :element-type element-type)) (ret (read-sequence array stream)) (pos (progn (assert (= ret size)) (search match array)))) (when pos (assert (file-position stream pos)) (write-sequence replacement stream) (cond ((= match-len replacement-len) T) (T (write-sequence array stream :start (+ pos match-len)) T)))))))) (defun replace-text-in-file (pathname match replacement &key (element-type 'character) buffer (match-len (length match)) (replacement-len (length replacement)) replace-all) "Replace occurrence of MATCH with REPLACEMENT. If REPLACE-ALL is NIL, replace the first occurrence." (if (or (< replacement-len match-len) (and replace-all (> replacement-len match-len))) (let* ((array (slurp-file pathname buffer :element-type element-type)) (beg 0) (pos (search match array))) (when pos (with-file-dates-preserved (pathname) (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type element-type) (loop (write-sequence array stream :start beg :end pos) (write-sequence replacement stream) (setq beg (+ pos match-len)) (when (or (null replace-all) (null (setq pos (search match array :start2 beg)))) (write-sequence array stream :start beg) (return (values T 1)))))))) (with-file-dates-preserved (pathname) ;; loses when unmodified. also when replace-all but only one match (with-open-file (stream pathname :direction :io :if-exists :overwrite :element-type element-type) (let* ((size (file-length stream)) (array (ensure-buffer-with-capacity size :buffer buffer :element-type element-type)) (ret (read-sequence array stream)) beg (pos (progn (assert (= ret size)) (search match array)))) (when pos (loop (assert (file-position stream pos)) (write-sequence replacement stream) (setq beg (+ pos match-len)) (when (or (null replace-all) (null (setq pos (search match array :start2 beg)))) (unless (= match-len replacement-len) (write-sequence array stream :start beg)) (return (values T 2)))))))))) #+nil (let ((match-text "$Header: /mnt/hda5/src/CVS-cmucl/") (replacement-text "$Header: /usr/local/src/CVS-cmucl/") (buf (make-array 1024 :element-type 'character :adjustable t :fill-pointer t))) (flet ((fixrcshdr (pathname depth directory-p) (unless directory-p (when (replace-text-in-file pathname match-text replacement-text :buffer buf) (warn "Modified ~A" pathname))))) (dired #p"home:cmu/src/" #'fixrcshdr))) (defun slurp-stream (stream &optional buffer &key (element-type (stream-element-type stream)) (chunk-size 1024)) "Slurp contents of STREAM into an adjustable array with fill-pointer reading it in chunks of CHUNK-SIZE. BUFFER can be NIL in which case a new array is allocated an returned, or an adjustable array with fill-pointer of appropriate type for storing the contents of STREAM. " (loop for start = 0 then end for size = (+ start chunk-size) for array = (ensure-buffer-with-capacity size :buffer buffer :element-type element-type) then (ensure-buffer-with-capacity size :buffer array) for end = (read-sequence array stream :start start) if (or (zerop end) (< end size)) do (if (< end size) (setf (fill-pointer array) end)) (return array))) (defun string->file (string filename) (with-open-file (stream filename :direction :output :if-exists :supersede :element-type (array-element-type string)) (write-sequence string stream))) (defun stream->file (stream filename &key ; madhu 061216 (element-type (stream-element-type stream)) (buffer-size 1024) (buffer (make-array buffer-size :element-type element-type))) "Supersede pathname FILENAME with the contents of STREAM by writing to it in chunks of BUFFER-SIZE." (with-open-file (outstream filename :if-exists :supersede :element-type element-type :direction :output) (loop for x = (read-sequence buffer stream) until (zerop x) do (write-sequence buffer outstream :end x)))) (export '(slurp-file ensure-buffer-with-capacity slurp-stream stream->file string->file)) (defun read-lines-from-stream (stream &optional lines-array (start 0) end &key (hint 1024)) "STREAM is a character stream. LINES-ARRAY if supplied should be an adjustable array with fill-pointer. START and END denote line numbers with the first line numbered as 0, which limit the lines read. END can be NIL indicating that stream should be read until End of File. Otherwise reading terminates after (END - START) lines have been read. Returns LINES-ARRAY." (loop with lines-array = (or lines-array (make-array hint :adjustable t :fill-pointer 0 :initial-element nil)) for line = (read-line stream nil) for i from 0 while (and line (or (null end) (< i end))) when (>= i start) do (vector-push-extend line lines-array) finally (return lines-array))) (defun write-lines-to-stream (lines-array &optional (stream *standard-output*) (start 0) end) (loop for i from start below (or end (length lines-array)) do (write-line (elt lines-array i) stream))) (defun slurp-lines (pathname &optional (start 0) end &key lines-array) (with-open-file (stream pathname) (read-lines-from-stream stream lines-array start end))) (defun dump-lines (lines-array pathname &optional (start 0) end) (with-open-file (stream pathname :direction :output :if-exists :supersede) (write-lines-to-stream lines-array stream start end))) (export '(slurp-lines dump-lines read-lines-from-stream write-lines-to-stream)) ;;; ---------------------------------------------------------------------- ;;; ;;; PORTABLE UNDEFMETHOD. Touched - Sat Apr 29 10:50:38 2006 +0530 ;;; (defun parse-undefmethod-args (args) "Return values METHOD-QUALIFIERS and METHOD-SPECIALIZERS from parsing ARGS of the form (DEFMETHOD NAME &REST ARGS)." (let (p q method-qualifiers specializers) (loop (cond ((and (atom (setq p (car args))) p) (push p method-qualifiers)) (t (return))) ; now P is the specialized-lambda-list (setq args (cdr args))) (loop (when (null p) (return)) (cond ((symbolp (setq q (car p))) (case q ((&aux &key &optional &rest &allow-other-keys) (return)) (t ; handle eql specializers: (push (find-class T) specializers)))) ((consp (cadr q)) (push (cadr q) specializers)) (t (push (find-class (cadr q)) specializers))) (setq p (cdr p))) (values (nreverse method-qualifiers) (nreverse specializers)))) #+nil (parse-undefmethod-args '(nil)) (defmacro undefmethod (function-name &rest args) `(let ((fdefn (fdefinition ',function-name))) (multiple-value-bind (qualifiers specializers) (parse-undefmethod-args ',args) (let ((meth (find-method fdefn qualifiers specializers))) (when meth (remove-method fdefn meth)))))) (export '(undefmethod)) ;;; ---------------------------------------------------------------------- ;;; ;;; MACROEXPAND DEBUGGING UTILITIES ;;; (defmacro debug-macro-call (form &environment env) ;; (let ((expansion (macroexpand-1 form env))) (format t "~S =expands-to ~S~&" form (macroexpand-1 form env)) expansion)) #+nil (defmacro array-access ((array access) &body body) `(macrolet ((,access (&rest indices) `(aref ,,array ,@indices))) ,@body)) #+nil (array-access (#(0 1 2 3) foo) (debug-macro-call (foo 0))) ;;; ---------------------------------------------------------------------- ;;; ;;; PORTABLE RESTART HACKERY - Touched madhu 050305 ;;; ;;; Do or do not. There is no try. --Yoda ;;; (defmacro choose-with-restarts-internal (choices &body body) (let ((choices-list (gensym))) `(let ((,choices-list ',choices)) (restart-case (progn ,@body) ,@(loop for choice in choices for i from 0 collect `(nil nil :report ,(format nil "Choose ~S:" choice) (nth ,i ,choices-list))))))) #+nil (choose-with-restarts-internal (foo bar car) (error "choose one")) (defun %choose-with-restarts (choices body-fn) (funcall (compile nil `(lambda () (choose-with-restarts-internal ,choices (funcall ,body-fn)))))) (defmacro choose-with-restarts (choices &body body) "CHOICES is evaluated to a list in the current lexical environment. BODY forms are evaluated in a dynamic environment where each item of CHOICES can be uniquely chosen by interactively invoking a particular restart. If BODY evaluates without entering the debugger, the macro returns result of evaluating the final form in BODY. However if the debugger is entered, the user may interactively invoke a restart and the corresponding item from CHOICES is returned. Eg: * (let ((choices '(yes no))) (ecase (choose-with-restarts choices (error \"Should I Stay or Should I go?\")) (yes 'blue-pill) (no 'yellow-pill))) " `(%choose-with-restarts ,choices (lambda () ,@body))) #+nil (%choose-with-restarts (list 'foo 'bar 'car 'var) #'(lambda () (error "foo-error"))) ;;; ---------------------------------------------------------------------- ;;; ;;; CMUCL RLWRAP SUPPORT - Touched Sun Jun 26 11:41:03 2005 +0530 ;;; ;;; breakchars: \"#'(),;\`\\|!?[]{} ;;; #+nil (defun ediweitz-make-cmucl-completions () (with-open-file (!!!-stream "home:.lisp_completions" :direction :output :if-exists :supersede) (let ((!!!-seen (make-hash-table :size 6000 :test #'equal)) (!!!-cl-package (find-package "CL")) (!!!-cl-user-package (find-package "CL-USER"))) (loop for !!!-package in (list-all-packages) do (let ((!!!-prefixes (if (or (eq !!!-package !!!-cl-package) (eq !!!-package !!!-cl-user-package)) (list "") (mapcar #'(lambda (!!!-prefix) (concatenate 'string (string-downcase !!!-prefix) ":")) (if (package-nicknames !!!-package) (package-nicknames !!!-package) (list (package-name !!!-package))))))) (loop for !!!-symbol being the symbols of !!!-package for !!!-symbol-name = (symbol-name !!!-symbol) when (or (eq (nth-value 1 (find-symbol !!!-symbol-name !!!-package)) :external) (eq !!!-package !!!-cl-user-package)) do (loop for !!!-prefix in !!!-prefixes do (let ((!!!-completion (format nil "~A~A~%" !!!-prefix (string-downcase !!!-symbol)))) (unless (or (gethash !!!-completion !!!-seen) (string= "!!!-" !!!-symbol-name :end2 (min (length !!!-symbol-name) 4))) (setf (gethash !!!-completion !!!-seen) t) (princ !!!-completion !!!-stream)))))))))) #+nil (ediweitz-make-cmucl-completions) ;;; ---------------------------------------------------------------------- ;;; ;;; PORTABLE PACKAGES ;;; (defun package-add-nicknames (pkg &rest nicknames) (rename-package (find-package pkg) (package-name pkg) (union nicknames (package-nicknames pkg) :test #'string=))) (defun package-remove-nicknames (pkg &rest nicknames) (rename-package (find-package pkg) (package-name pkg) (set-difference (package-nicknames pkg) nicknames :test #'string=))) (export '(package-add-nicknames package-remove-nicknames)) ;; undo some SBCL inspired ANSI-looniness ;; (package-add-nicknames "CL-USER" "USER") (defmacro extsyms (package) `(loop for sym being each external-symbol of ',package collect sym)) (defmacro pp (table) `(loop for key being each hash-key of ,table using (hash-value val) collect (cons key val))) (defun find-symbols (symbol-designator &optional (functionp t)) "Return a list of symbols named SYMBOL-DESIGNATOR from all packages" (etypecase symbol-designator (string) (symbol (setf symbol-designator (symbol-name symbol-designator)))) (let ((return-list nil)) (loop for package in (list-all-packages) for found-symbol = (find-symbol symbol-designator package) when found-symbol unless (keywordp found-symbol) ;XXX when (or (not functionp) (fboundp found-symbol)) do (pushnew found-symbol return-list)) return-list)) #+nil ;; Example: hopelessly broken (progn (shadow 'fdefinition) (defun fdefinition (function-name) (handler-bind ((undefined-function #'(lambda (c) (let ((choices (find-symbols function-name))) (when choices (return-from fdefinition (fdefinition (choose-with-restarts choices (error "Encountered Error ~S: ~A There was no function of that name in this package, However similar functions were found in other packages: ~S You may choose to return one of the those instead." c (cell-error-name c) choices))))))))) (cl:fdefinition function-name))) (fdefinition 'install-gc-hooks)) ;;; ;;; cleaning Up packages - Touched Sun Oct 30 21:24:15 2005 +0530 ;;; (defun clean-syms (pkg &optional (syms (loop for sym being each symbol of (setq pkg (find-package pkg)) when (eql pkg (symbol-package sym)) collect sym))) (warn "CLEANING: ~A~@[ Deps: ~A.~]" pkg (package-used-by-list pkg)) (loop with rem = (copy-list syms) for sym in syms if (fboundp sym) collect sym into functions if (boundp sym) collect sym into vars and if (hash-table-p (symbol-value sym)) collect sym into hashes end if (find-class sym nil) collect sym into classes finally (when classes (setq classes (sort classes #'STRING< :key #'symbol-name)) (warn "nuking classes ~A" classes) (loop for class in classes do (setf (find-class class) nil)) (setq rem (set-difference rem classes))) (when functions (setq functions (sort functions #'STRING< :key #'symbol-name)) (warn "nuking functions ~A" functions) (loop for func in functions do (fmakunbound func)) (setq rem (set-difference rem functions))) (when hashes (setq hashes (sort hashes #'STRING< :key #'symbol-name)) (warn "nuking hashes ~A" hashes) (loop for hash in hashes do (clrhash (symbol-value hash)) #+cmu (lisp::clobber-hash (symbol-value hash)))) (when vars (setq vars (sort vars #'STRING< :key #'symbol-name)) (warn "nuking vars ~A" vars) (loop for var in vars do (makunbound var)) (setq rem (set-difference rem functions :test #'eq))) (when rem (warn "remaining symbols: ~A" rem))) (loop for sym in syms do (unintern sym pkg))) ;; ;; pjb's cleaning packages imported into CL-USER ;; #+nil (MAPC (LAMBDA (USED) (UNUSE-PACKAGE USED "COMMON-LISP-USER")) (REMOVE (FIND-PACKAGE "COMMON-LISP") (COPY-SEQ (PACKAGE-USE-LIST "COMMON-LISP-USER")))) ;; ;; instead remove all symbols that arent in the use-list ;; #+nil (let ((pkg (find-package "COMMON-LISP-USER")) (use (list (find-package "EXTENSIONS") (find-package "COMMON-LISP")))) (clean-syms (loop for x being each symbol of pkg unless (some (lambda (p) (find-symbol (symbol-name x) p)) use) collect x) pkg)) ;;; WITH-PKG-SLOTS. ;;; RENAMED (defmacro with-slots-in-package ((&rest slot-vars) obj pkg &body body) ; madhu 061205 "PKG is a package designator (evaluated) denoting the package in which slots-vars are looked up." ;; (let ((objvar (gensym))) `(let ((,objvar ,obj)) (declare (ignorable ,objvar)) (symbol-macrolet ,(loop for slot-var in slot-vars collect (etypecase slot-var (cons (assert (= (length slot-var) 2)) (list (car slot-var) `(slot-value ,objvar ',(cadr slot-var)))) (symbol (list slot-var `(slot-value ,objvar ',(find-symbol (symbol-name slot-var) pkg)))))) ,@body)))) (export 'with-slots-in-package) (setf (symbol-function 'with-pkg-slots) (symbol-function 'with-slots-in-package)) #+nil (defmacro with-XXX-slots ((&rest slot-names) CLASS-NAME XXX &body body) (let ((var (gensym)) (direct-slot-names (mapcar #'pcl::slot-definition-name (pcl:class-direct-slots (find-class CLASS-NAME))))) `(let* ((,var ,XXX) ,@(loop for slot-name in slot-names for other = (find slot-name direct-slot-names :test #'string= :key #'symbol-name) unless other do (error "Slot ~A not found in ~A~&" slot-name direct-slot-names) else collect (list slot-name `(slot-value ,var ',other)))) ,@body))) #+nil (with-XXX-slots (time-zone) date-time:date-time obj tz) ;;; ---------------------------------------------------------------------- ;;; ;;; Thu Apr 30 12:34:20 2009 +0530 ;;; #-allegro (progn (defvar *named-readtables* nil "Alist, each element is a cons whose key is a keyword representing a readtable name, and value is a readtable") (defun coerce-keyword (x) (etypecase x (keyword x) (string (intern x :keyword)) (symbol (intern (symbol-name x) :keyword)))) (defun named-readtable (name &optional errorp) (or (cdr (assoc (coerce-keyword name) *named-readtables*)) (and errorp (error "Readtable named ~S does not exist." name)))) (defsetf named-readtable (name) (store) (let ((name-var (gensym)) (store-var (gensym))) `(let* ((,name-var (coerce-keyword ,name)) (,store-var ,store) (cons (assoc ,name-var *named-readtables*))) (if cons (rplacd cons ,store-var) (prog1 ,store-var (push (cons ,name-var ,store-var) *named-readtables*)))))) (defmacro with-named-readtable ((name) &body body) `(let ((cl:*readtable* (named-readtable ,name t))) ,@body)) (export '(*named-readtables* named-readtable with-named-readtable))) ;;; ---------------------------------------------------------------------- ;;; ;;; #|| (named-readtable :barf) (setf (named-readtable :barf) *readtable*) (with-named-readtable (:barf) (pprint *readtable*)) From: Madhu Newsgroups: comp.lang.lisp Subject: Re: A way to get rid of readmacros X-Url: http://www.meer.net/~enometh/ Reply-to: Madhu X-Attribution: Madhu Date: Mon, 27 Apr 2009 06:34:54 +0530 Message-ID: ||# ;;; ---------------------------------------------------------------------- ;;; ;;; LAZY EVALUATION: DELAY/FORCE - PORTABLE ;;; ;;; Touched - Tue 02 Mar 2004 09:36:20 AM IST ;;; #+nil (progn (defclass delayed-computation nil ((delayed :accessor force) ; delayed slot initially unbound! (computation :initarg :form))) (defmacro delay (&body body) `(make-instance 'delayed-computation :form (lambda () ,@body))) (defmethod slot-unbound :around ((class t) (obj delayed-computation) (slot (eql 'delayed))) ;compute the delayed slot - exactly once, on demand (setf (slot-value obj slot) (funcall (slot-value obj 'computation))))) #+nil (let ((foo 10)) ;(pprint (macroexpand-1'(delay(incf foo)))) (setq b1 (delay (incf foo))) (setq b2 (delay (incf foo))) (setq b3 (delay (incf foo))) (assert (= (force b1) 11)) (assert (= (force b1) 11)) (assert (= (force b2) 12)) (assert (= (force b3) 13)) (assert (= (force b3) 13)) ) ;;; ---------------------------------------------------------------------- ;;; ;;; UPTIME PORTABLE. Touched - Sat Jan 07 12:08:32 2006 +0530 ;;; (defvar *uptime-epoch* (get-universal-time) "When this file was loaded.") (defun uptime (&optional (now (get-universal-time)) human-readable) (case now ((t nil) (setq now (get-universal-time)))) (multiple-value-bind (second minute hour) (decode-universal-time now) (format t "~2,'0D:~2,'0D:~2,'0D ~T" hour minute second)) (multiple-value-bind (days diff) (truncate (- now *uptime-epoch*) 86400) (multiple-value-bind (hours diff) (truncate diff 3600) (multiple-value-bind (mins diff) (truncate diff 60) (multiple-value-bind (secs) (truncate diff) (if human-readable (format t "Up ~A day~:P ~A hour~:P ~A minute~:P ~A second~:P." days hours mins secs) (format t "Up ~A day~:P, ~2,'0D:~2,'0D" days hours mins)) (values days hours mins secs)))))) (export '(uptime)) ;;; ---------------------------------------------------------------------- ;;; ;;; My ad-hoc common-lisp controller. ;;; (defvar *my-registry-dir* "home:cmu/registry/") ; XXX (defgeneric register-sysdcl (NAME SYSDCL) (:documentation "Given an mk-defsystem system defintion file SYDCL, REGISTER-SYSDCL will arrange to have that file loaded upon a call to (require 'NAME). In addition the call to (require 'NAME) will compile and load the mk-defsystem system NAME.")) (defmethod register-sysdcl ((module-name string) (sysdcl pathname)) (with-open-file (stream (make-pathname :name (or #+cmu (concatenate 'string module-name "-library") module-name) :type "lisp" :version nil :defaults *my-registry-dir*) :direction :output :if-exists :supersede) ;so beware! (format stream ";;;; vim: ft=lisp ;;;; Touched: <~a, #'register-sysdcl> (in-package #:cl-user) #-mk-defsystem (require :defsystem) ; say no to defsystem (load ~s) (let ((mk::*operations-propagate-to-subsystems* nil)) (mk:load-system '~a :minimal-load t :compile-during-load t)) ;madhu (provide '~a)~%" (iso-8601-date :suppress-tz-p nil) (truename sysdcl) module-name module-name))) #+cmu (pushnew *my-registry-dir* (ext:search-list "modules:")) #+clisp (pushnew *my-registry-dir* custom:*load-paths*) #|| Eg: (ensure-directories-exist *my-registry-dir*) (register-sysdcl "cl-pdf" #p"cl-pdf-2.0.2/sysdcl.lisp") (register-sysdcl "f2cl" #p"f2cl-clocc/sysdcl.lisp") (require 'f2cl) (register-sysdcl "cl-ppcre" #p"cl-ppcre-0.5.7/sysdcl.lisp") (register-sysdcl "cl-who" #p"cl-who-0.3.0/sysdcl.lisp") (register-sysdcl "acl-compat" #p"portableaserve/sysdcl.lisp") (register-sysdcl "aserve" #p"portableaserve/sysdcl.lisp") ||# ;;; ---------------------------------------------------------------------- ;;; ;;; MK-DEFSYSTEM ;;; (defvar *defsystem-source-directory* "home:/cmu/clocc/src/defsystem-3.x/") ;XXX (eval-when (:load-toplevel :execute :compile-toplevel) (unless (find-package :make) (make-package :make))) (defvar make::*dont-redefine-require* t) ;XXX (defvar make::*compile-during-load* t) ;XXX (let ((src (merge-pathnames "defsystem.lisp" *defsystem-source-directory*))) (when (probe-file src) (lc src))) (defmacro clmod (&rest modules) "compile and load DEFYSSTEM MODULES" `(with-compilation-unit #-cmu () #+cmu (:optimize '(optimize (speed #+byte-compile 0 #-byte-compile 2) (space 2) (inhibit-warnings 2) (safety #+small 0 #-small 1) (debug #+small .5 #-small 2)) :optimize-interface '(optimize-interface (safety #+small 1 #-small 2) (debug #+small .5 #-small 2)) :context-declarations '(((:and :external :global) (declare (optimize-interface (safety 2) (debug 1)))) ((:and :external :macro) (declare (optimize (safety 2)))) (:macro (declare (optimize (speed 0)))))) ,@(loop for name in modules for quotep = (typep name '(and symbol (not keyword))) collect `(,(find-symbol "OOS" "MAKE") ,@(if quotep `(',name) `(,name)) :load :force :new-source-and-dependents :minimal-load t :compile-during-load t)))) #+(and nil mk-defsystem) ;madhu 080807 don't (defun mklib (system &optional (defaults *default-pathname-defaults*)) "Creates a concatenated fasl file named SYSTEM-library.FASL from the fasl files of the given mk-defsystem system SYSTEM. The system should already be compiled. The concatenated file is written in the DEFAULTS directory. (FASL is the appropriate fasl pathname-type for the CMUCL system.)" (labels ((handle-load-only (component) ; "Return a list of fasl pathnames" (let* ((source-pathname (mk::component-full-pathname component :source)) (binary-pathname (mk::component-full-pathname component :binary)) (binary-truename (probe-file binary-pathname)) (compilation-required-p (cond (binary-truename (< (file-write-date binary-truename) (file-write-date (truename source-pathname)))) (t t)))) (restart-case (cerror "Skip this file" "Component ~S is load-only." component) (use-existing () :test (lambda (condition) (declare (ignore condition)) binary-truename) :report (lambda (stream) (format stream "Use already compiled (~:[Current~;Out of Date~]) binary: ~A" compilation-required-p binary-truename)) (list binary-truename)) (compile-and-use () :report (lambda (stream) (format stream "Compile ~A to ~A and use that fasl?" source-pathname binary-pathname)) (multiple-value-bind (output-truename warnings-p failure-p) (compile-file source-pathname :output-file binary-pathname) (declare (ignore warnings-p)) (cond (failure-p (cerror "Skip this file" "Compilation of ~A to produce ~A failed." source-pathname binary-pathname)) (t (list output-truename)))))))) (walk-components (component) (declare (special *recursively-handle-deps*)) (ecase (mk::component-type component) ((:file :private-file) (cond ((mk::component-load-only component) (handle-load-only component)) (t (list (mk::component-full-pathname component :binary))))) ((:module :system :subsystem :defsystem) (let ((deps (mk::component-depends-on component))) (when (and deps (not *recursively-handle-deps*)) (restart-case (cerror "Skip deps" "System ~S depends on: ~S." component deps) (recursively-load-deps () :report "Recursively handle deps." (setq *recursively-handle-deps* t)))) (nconc (when (and deps *recursively-handle-deps*) (loop for dep in deps for depsys = (ignore-errors (mk:find-system dep)) unless depsys do (warn "Not handling unknown system: ~S." dep) ;; (cerror "OK" "Not handling unknown system: ~S." dep) else nconc (walk-components depsys))) (loop for x in (mk::component-components component) nconc (walk-components x)))))))) (let* ((system (etypecase system (mk::component (ecase (mk::component-type system) (:defsystem system))) (symbol (mk:find-system system)) (string (mk:find-system system)))) (*recursively-handle-deps* nil) (fasls (walk-components system)) (buf (make-array 2048 :element-type '(unsigned-byte 8))) (pathname (make-pathname :name (concatenate 'string (mk::component-name system) "-library") :type (or (mk::component-binary-extension system) #-cmu (pathname-type (compile-file-pathname "foo.lisp")) #+cmu (c:backend-fasl-file-type c:*target-backend*)) :version :newest :defaults (pathname defaults)))) (declare (special *recursively-handle-deps*)) (with-open-file (out pathname :element-type '(unsigned-byte 8) :direction :output :if-exists :supersede :if-does-not-exist :create) (loop for file in fasls do (restart-case (with-open-file (in (truename file) :element-type '(unsigned-byte 8)) (format t "~%; ~s" file) (loop as x = (read-sequence buf in) until (= x 0) do (write-sequence buf out :end x))) (skip-this-file () :report "Skip this file"))) pathname)))) ;;; ---------------------------------------------------------------------- ;;; ASDF CRAP. ;;; ;;; ASDF rode the `WorseIsBetter' horse to popularity by being worse ;;; than MK's defsystem #+nil (load "home:cmu/cclan/asdf/asdf") #+nil (lc "home:cmu/cclan/asdf/asdf.lisp") #+nil (progn (require :asdf) (pushnew #p"home:cmu/registry/" asdf:*central-registry* :test #'equal) (asdf:operate 'asdf:load-op :asdf-install)) ;;; ---------------------------------------------------------------------- ;;; ;;; SWANK CRAP. ;;; ;;; Touched: [Fri Feb 18 22:56:22 2005 +0530] ;;; #+cmu (defvar *slime-source-directory* "home:elisp/pkg/slime/") ;XXX #-cmu ;; #+logical-home (defvar *slime-source-directory* "home:elisp;pkg;slime;") ;XXX (eval-when (:load-toplevel :execute :compile-toplevel) (unless (find-package :swank-loader) (make-package :swank-loader))) ;; 2008-02 swank-loader changed. separate initialization phase. #+(and nil eyer) (defparameter swank-loader::*fasl-directory* "/user11/madhu/build/swank/") #+(and nil rhea cmu19d) (eval-when (:load-toplevel :execute) (defparameter swank-loader::*fasl-directory* "/scratch/madhu/tmp/swank-19d/")) (defun swank-version-string (&aux *read-eval*) (with-open-file (s (merge-pathnames "ChangeLog" *slime-source-directory*) :if-does-not-exist nil) (and s (symbol-name (read s))))) (defun swank-fasl-directory () (merge-pathnames (make-pathname :directory `(:relative #+nil ,(swank-loader::unique-dir-name) ,@(if (swank-version-string) (list (swank-version-string))))) (binary-directory (merge-pathnames "swank-loader.lisp" *slime-source-directory*)) nil)) #+nil (swank-fasl-directory) (defparameter swank-loader::*fasl-directory* (swank-fasl-directory)) ;; barlow malware crap: #+sbcl (defun require-barlow-malware-crap () (require 'asdf) (require 'sb-bsd-sockets)) (defun swank (&key (port 4005) (announce-fn #'print) style dont-close (external-format "latin-1-unix")) #+sbcl (require-barlow-malware-crap) (and style (ecase style ((:fd-handler :sigio :spawn)))) (progn (require 'slime (merge-pathnames (make-pathname :name "swank-loader" :type "lisp" :version nil :host nil :directory '(:relative)) *slime-source-directory*)) (let (init) (when (setq init (find-symbol "INIT" "SWANK-LOADER")) (funcall init))) (provide 'slime)) (unwind-protect (progn (funcall (find-symbol "SETUP-SERVER" :swank) port announce-fn style dont-close (let* ((fef-fn (find-symbol "FIND-EXTERNAL-FORMAT" :swank))) (if fef-fn (or (funcall fef-fn external-format) (error "~A: ~A not found" fef-fn external-format)) external-format))) #+nil(set (cl:find-symbol "*USE-DEDICATED-OUTPUT-STREAM*" :swank) nil) #+nil(set (cl:find-symbol "*LOG-EVENTS*" :SWANK) t)) (unless (eql style :spawn) (setf *debugger-hook* nil)))) ;; #+nil ;; version using create-server ;madhu 081101 (defun swank-start (&key (port 4005 port-supplied-p) (style nil style-supplied-p) (dont-close nil dont-close-supplied-p) (coding-system "latin-1-unix" coding-system-supplied-p)) (and style (ecase style ((:fd-handler :sigio :spawn)))) (progn (require 'slime (merge-pathnames (make-pathname :name "swank-loader" :type "lisp" :version nil :host nil :directory '(:relative)) *slime-source-directory* nil)) (let (init) (when (setq init (find-symbol "INIT" "SWANK-LOADER")) (funcall init))) (provide 'slime)) (unwind-protect (apply (find-symbol "CREATE-SERVER" :swank) (append (when port-supplied-p (list :port port)) (when style-supplied-p (list :style style)) (when dont-close-supplied-p (list :dont-close dont-close)) (when coding-system-supplied-p (list :coding-system coding-system)))) (setf *debugger-hook* nil))) ;;#+lispworks ;;(swank-start :style :spawn :dont-close t) (defvar *slime-debugger*) (defun kill-swank-debugger () ; works in the parent lisp (psetf *slime-debugger* *debugger-hook* *debugger-hook* nil)) (defun swankl (&rest args) (loop (apply 'swank args)) (setf *debugger-hook* nil)) (export '(swank swankl)) ;;; ---------------------------------------------------------------------- ;;; ;;; FFI CONVENIENCES ;;; #+nil (progn (defun list-dlls () #+allegro (ff:list-all-foreign-libraries) #+cmu (pprint sys::*table*) #+lispworks (fli:print-foreign-modules)) (defvar *oldsigexit-handler* #+cmu (system:enable-interrupt 1 (lambda (&optional signal code scp) (cerror "Continue from exit handler" "signal code scp: ~S" (list signal code scp)))) #+allegro (prog1 (cdr (assoc 1 *signals*)) (set-signal-handler 1 (lambda (signal &optional ignore) (cerror "Continue." "~&; got signal ~d [~s].~%" signal ignore) t))))) ;;; ---------------------------------------------------------------------- ;;; ;;; MISC CMUCL ;;; #+cmu (progn (setq EXT:*LOAD-IF-SOURCE-NEWER* :LOAD-SOURCE) (setq EXT:*GC-VERBOSE* T) (setq CL:*COMPILE-VERBOSE* NIL) (setq EXT:*BYTES-CONSED-BETWEEN-GCS* (* 4 1024 1024)) (setq EXT:*BYTES-CONSED-BETWEEN-GCS* 12582912) (setq EXT:*GC-VERBOSE* NIL) ;; ;; Turn off the generational gc ;; Thu, 18 Aug 2005 13:22:56 -0400 ;; ;; lisp::set-gc-trigger, lisp::set-trigger-age, ;; lisp::set-min-mem-age. ;; #+nil (alien:def-alien-variable gencgc-oldest-gen-to-gc c-call:unsigned-int) #+nil (setf gencgc-oldest-gen-to-gc 0) #+nil (load "home:eli-hacks") #+nil (let ((gross-font "*courier-medium-r*12*")) (setq INTERFACE::ENTRY-FONT-NAME gross-font INTERFACE::ITALIC-FONT-NAME gross-font INTERFACE::HEADER-FONT-NAME gross-font)) #+nil (let ((gross-font "*courier-medium-r*12*")) (setq INSPECT::ENTRY-FONT-NAME gross-font INSPECT::ITALIC-FONT-NAME gross-font INSPECT::HEADER-FONT-NAME gross-font)) #+nil (let ((gross-font "*courier-medium-r*12*")) (setq HEMLOCK::default-font gross-font HEMLOCK::open-paren-highlighting-font gross-font HEMLOCK::active-region-highlighting-font "fixed")) #+mp (defun shutdown-mp (&optional restart-p) ;; NOTE: shutdown-mp wants to be called interactively.. (let ((MP::*CURRENT-PROCESS* MP::*INITIAL-PROCESS*)) (MP::SHUTDOWN-MULTI-PROCESSING) (when restart-p (MP::INIT-MULTI-PROCESSING)))) #+(and nil mp) (progn (mp::shutdown-multi-processing) (ext:without-package-locks (ignore-errors (delete-package "MP"))) (setf *features* (remove :mp *features*))) ;; ;; CMUCL CORE SNAPSHOT. - Touched: Fri Apr 07 21:07:16 2006 +0530 ;; (defun save-snapshot (filename &rest save-lisp-args) "Obselete." (when (zerop (unix:unix-fork)) (apply #'ext:save-lisp filename save-lisp-args))) (defun save-cmucl-clean-slime-debugger () "Called in *after-save-initializations* because cores dumped when slime is running has this bound. TODO" (setf cl:*debugger-hook* nil)) (defun save-cmucl-close-fd-handlers () (loop for handler in lisp::*descriptor-handlers* when (> (lisp::handler-descriptor handler) 2) do (SYSTEM:REMOVE-FD-HANDLER handler))) (defun save-cmucl-inits (corefilepath) "called in the child process" (save-cmucl-close-fd-handlers) (mp::shutdown-multi-processing) (when cl:*debugger-hook* (warn "CHILD: setting debugger-hook to NIL") (setf cl:*debugger-hook* nil) ; does not work! (pushnew 'save-cmucl-clean-slime-debugger ext:*after-save-initializations*)) (pushnew 'system::reinitialize-global-table ext:*after-save-initializations*) (ext:save-lisp corefilepath) (warn "CHILD: strangely survived. killing.") (unix:unix-exit 0)) (defun snapshot (&optional (corefilepath "/var/local/fasl/tsched.core")) (cond ((zerop (unix:unix-fork)) (save-cmucl-inits corefilepath)) (t (alien:alien-funcall (alien:extern-alien "wait" (alien:function alien:unsigned alien:unsigned)) 0))) (warn "PARENT saved")) (defun dont-debug-on-interrupt () (system:enable-interrupt unix:sigint (lambda (signal code scp) (declare (ignore signal code scp)) (unix:unix-exit 1))))) ;;; ---------------------------------------------------------------------- ;;; ;;; MISC ALLEGRO ;;; #+ (and nil allegro) (setf (sys:gsgc-switch :stats) t (sys:gsgc-switch :print) t (sys:gsgc-switch :verbose) t) ;;; local variables: ;;; compile-command: "lisp -quiet -batch -noinit -eval \"(progn (compile-file \\\"home:.cmucl-init\\\") (quit))\"" ;;; end: