;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:ZL -*- ;;;SAZ's LISPM init file (format t "~%~%~\date\~%~%" (time:get-universal-time)) ;What the hell day is it, anyway? (setq fs:user-id "saz") ;ensure lower case (setq si:system-additional-info "126.100 10/4") ;just until multi-line bug in WRITE-RESPONSIBILITY gets fixed (load "dj:saz;mass-millions") (setq ZWEI:*NOTIFY-ON-NEW-MAIL-IN-BACKGROUND* :converse) (setq zwei:*zmail-init-loaded* t) (load "dj:saz;zmail.init") ;don't wait for me to fire up zmail to get my init file read in... ;(setq zwei:*from-host* "gsi-cam") ;don't wait for me to fire up zmail to enable me to send mail from ;Zwei without header canonicalization problems... (tv:map-over-sheets #'(lambda (win) (send win :set-deexposed-typeout-action ':permit))) (tv:kbd-esc-more 0) ;turn it off until lispm.init is done loading (defun boost-all-quanta (amt) ;efficiency hack (setq si::default-quantum amt) (mapcar #'(lambda (proc) (send proc :set-quantum amt)) si::all-processes)) (defmacro with-fdefine-warnings-inhibited ((&body body)) `(let ((inhibit-fdefine-warnings t)) ,body)) (defmacro ndelq (object list &optional (times -1)) ;;really delete object from list regardless of position... `(if (mem #'eq ,object ,list) (if (zerop (find-position-in-list ,object ,list)) (setq ,list (delq ,object ,list ,times)) (delq ,object ,list ,times)))) (defmacro watch-vars (vars form) ;; indicates any mutations of variables specified in vars which arose ;; as a result of evaluating form... ;; E.g., (watch-vars (foo bar) (setq foo 3 bar 4)) ;; ==> foo: NIL --> 3 ;; bar: NIL --> 4 ;; 4 ;; ...assuming of course that the two variables were unbound before ;; calling watchvars... `(let ((vars-before (mapcar #'(lambda (var) (if (boundp var) (symeval var))) ',vars))) (let ((return-me (si:eval-special-ok ',form))) (loop for var in ',vars and old-val in vars-before do (format t "~%~A: ~S --> ~S" var old-val (symeval var))) return-me))) (defun zwei:wops (thing) ;;It is not a good idea to send messages to anything other than instances and named-structures, ;;as send employs funcall on its arguments. For example, if destructive-function is a function ;;which ignores its first argument, then doing a (send #'fs:destructive-function :message) will ;;trigger the execution of destructive-function in all its destructive glory. (etypecase thing ((or instance named-structure) (condition-case () (let ((ops (send-if-handles thing :which-operations))) (if (null ops) (format t "~%No :which-operations method defined for ~A ~A" (string-downcase (type-of thing)) thing) (pprint ops) ops)) ((sys:undefined-function si:invalid-function) (format t "~%~A,~ ~%an object of type ~A, does not support messages." thing (type-of thing))))))) (defun STOPWATCH () (let ((foo (time:get-universal-time))) (progn (tyi) (format t "~2%Seconds elapsed: ~A~%" (- (time:get-universal-time) foo))))) #+regression-testing (cl-tests:deftest-seq (zwei:wops zwei:wops-1 :simple) (((zwei:wops-1 :is-error) (zwei:wops nil)) ((zwei:wops-2 :is-error) (zwei:wops t)) ((zwei:wops-3 :is-error) (zwei:wops 5)) ((zwei:wops-4 :is-error) (zwei:wops #'si:print-disk-label)) ((zwei:wops-5) (zwei:wops (zl:make-instance 'si:vanilla-flavor))))) (defvar *JUST-EXECUTE-EVERYTHING* nil) (defmacro ASK-WAIT-AND-EXECUTE (prompt timeout-secs response-if-no-answer value-if-no-user-answer &body body) ;;;prompt and response-if-no-answer are strings, timeout-secs a fixnum. `(*catch 'RESULT (if *just-execute-everything* (progn (format query-io ,response-if-no-answer) ;; Automatically use the defalut for this and all other calls to this function. (if ,value-if-no-user-answer ,@body) (*throw 'result ,value-if-no-user-answer)) (if (with-timeout ((* ,timeout-secs 60) (format query-io ,response-if-no-answer) ;; only if user did not respond ;; within the time allotted by the top-level call (*throw 'RESULT ,value-if-no-user-answer)) (y-or-n-p ,prompt)) (progn ,@body ;do it (*throw 'result t)) ;only if user responded, affirmatively (*throw 'result nil))))) ;only if user responded, negatively (setq *JUST-EXECUTE-EVERYTHING* (ask-wait-and-execute "Shall I default automatically during init file loading?" 10 "... OK, I'll default: ~%" t ;yes if user is not around... nil)) ;this value is unimportant... (ask-wait-and-execute "~&Boost all quanta? " 10 "~& ... all quanta boosted." t (boost-all-quanta 6.)) ;;;This will work after fquery gets fixed...! ;(defun SET-GC-DEGREE-OR-TURN-IT-OFF (max-response-time) ; (let* ((response-seconds (* max-response-time 60.)) ; (degree (fquery `(:type :tyi ; :timeout ,response-seconds ; :default-value no-answer ; :choices ((0 "~&0") (1 "~&1") (2 "~&2") (3 "~&3") :any)) ; "~&Turn GC on with degree: "))) ; (cond ((and (fixp degree) ; ( degree 0) ; ( degree 3)) ; (progn (gc:gc-on :degree degree) ; (format t "~&~%GC turned on at level ~A" degree))) ; ((eq degree 'no-answer) ;timed out; what we usually want ; (progn ; (gc:gc-on :degree 0) ; (format t "~&~%GC turned on at level 1"))) ; (t (progn (gc:gc-off) ; (format t "~&~%GC turned off")))))) ;(SET-GC-DEGREE-OR-TURN-IT-OFF 5.) (ask-wait-and-execute (format nil "~&Load system patches and//or site configuration information? ") 20 "~& ... loading system patches now ..." t (load-patches :noselective)) ;(ask-wait-and-execute "~&Make a BUGMAN system?" 20 "~& ... making the BUGMAN system now ... " ; t (make-system 'bugman :noconfirm)) ;(ask-wait-and-execute "~&Make a WINDOW-MAKER system?" 20 "~& ... making the WINDOW-MAKER system now ... " ; t (make-system 'window-maker :noconfirm)) (ask-wait-and-execute "~&Make a VALID system?" 20 "~& ... Ok, making the VALID system now ... " t (make-system 'valid :noconfirm)) (ask-wait-and-execute "~&Load LISP macros?" 10 "~& ... loading LISP macros now ... " t (load "dj:saz;macros")) (load "dj:saz;pathname") (ask-wait-and-execute "~&Load ZMacs enhancement file?" 10 "~& ... loading ZMacs enhancement file now ... " t (load "dj:saz;zmacs")) (export 'zwei:wops 'global) (setq fs:*load-set-default-pathname* t) (setq *just-execute-everything* nil) (tv:kbd-esc-more 1)