(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL")
(filecreated "21-Sep-88 11:02:16" |{EG:PARC:XEROX}<LANNING>LISP>USERS>GENERIC-INIT.;108| 102770
|changes| |to:| (advice files? cl:compile makefile getpromptwindow) (vars rooms-init-commands mail-init-commands unix-init-commands loops-init-commands tedit-init-commands pcl-init-commands generic-initcoms who-line-commands display-control-init-commands chat-init-commands)
(commands "MORE" "BREAK" "UNBREAK" "CALLS" "DESCRIBE" "EC" "EFF" "FILES?" "IC" "NOTICE" "MAKE" "SPY")
(functions xcl-user::log-generic-init-user eval-at-greet notice make oam de file |PickOneAtRandom| atom-neighbors load-nova-fonts)
|previous| |date:| "19-Sep-88 09:26:30" |{EG:PARC:XEROX}<LANNING>LISP>USERS>GENERIC-INIT.;107|
)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
(prettycomprint generic-initcoms)
(rpaqq generic-initcoms ((* |;;| "Macro to avoid problems when trying to maintain file.") (coms (p (cl:proclaim (quote (global *generic-init-loaded*)))) (initvars (*generic-init-loaded* nil)) (functions eval-at-greet)) (* |;;| "Silent loads") (coms (p (cl:proclaim (quote (global *load-silent* prettyheader)))) (initvars (*load-silent* nil)) (vars (\\original-load-verbose *load-verbose*) (\\original-prettyheader prettyheader) (*load-verbose* (if *load-silent* then nil else *load-verbose*)) (prettyheader (if *load-silent* then nil else prettyheader)))) (* |;;| "Environment setup") (coms * compute-directories-init-commands) (coms * env-tailoring-init-commands) (coms * patch-init-commands) (coms (* |;;| "Wants to be (COMS * FILECACHE-INIT-COMMANDS), but the FileCrasher doesn't exist in Lyric, yet. Probably never will.") (vars filecache-init-commands)) (coms * font-setup-init-commands) (declare\: eval@loadwhen (not *generic-init-loaded*) donteval@compile docopy (files (sysload from lispusers) loadmenuitems)) (* |;;| "Machine status") (coms * who-line-commands) (coms * vstats-init-commands) (* |;;| "Display control") (coms * screen-setup-init-commands) (coms * rooms-init-commands) (coms * change-background-init-commands) (coms * display-control-init-commands) (coms * idle-init-commands) (coms * clock-init-commands) (* |;;| "Programming stuff") (coms * programming-init-commands) (coms * old-utils-commands) (coms * wizard-init-commands) (coms * dinfo-init-commands) (coms * pcl-init-commands) (coms * loops-init-commands) (* |;;| "Documentation") (coms * tedit-init-commands) (coms * sketch-init-commands) (coms * notecards-init-commands) (* |;;| "Communication & Info") (coms * mail-init-commands) (coms * chat-init-commands) (coms * talk-init-commands) (coms * calendar-init-commands) (coms * printer-init-commands) (coms * db-init-commands) (coms * nfs-init-commands) (* |;;| "Files") (coms * file-watch-init-commands) (coms * file-server-init-commands) (coms * dirgrapher-init-commands) (coms * fb-init-commands) (coms * compare-files-init-commands) (* |;;| "Random stuff") (coms * unix-init-commands) (coms * demos-init-commands) (coms * games-init-commands) (* |;;| "Cleanup") (coms * background-menu-cleanup-init-commands) (coms * do-load-utilities-init-commands) (coms (* |;;| "Send the Tool Work's a message telling it about this user.") (functions xcl-user::log-generic-init-user) (initvars (\\cc-generic-init-msg t)) (p (eval-at-greet (cl:unless *generic-init-loaded* (xcl-user::log-generic-init-user))))) (vars (*load-verbose* \\original-load-verbose) (prettyheader \\original-prettyheader) (*generic-init-loaded* t)) (* |;;| "Make the FileManager happy") (declare\: dontcopy (prop makefile-environment generic-init))))
(* |;;| "Macro to avoid problems when trying to maintain file.")
(cl:proclaim (quote (global *generic-init-loaded*)))
(rpaq? *generic-init-loaded* nil)
(defmacro eval-at-greet (&body forms) "Evaluate the forms only when loading the compiled file, and then only when greeting" (bquote (cl:eval-when (cl:load) (cl:unless (or *generic-init-loaded* (memb dfnflg (quote (prop allprop)))) (\\\,@ forms)))))
(* |;;| "Silent loads")
(cl:proclaim (quote (global *load-silent* prettyheader)))
(rpaq? *load-silent* nil)
(rpaq \\original-load-verbose *load-verbose*)
(rpaq \\original-prettyheader prettyheader)
(rpaq *load-verbose* (if *load-silent* then nil else *load-verbose*))
(rpaq prettyheader (if *load-silent* then nil else prettyheader))
(* |;;| "Environment setup")
(rpaqq compute-directories-init-commands ((* |;;| "Who am I?") (declare\: donteval@compile (vars (|\\BasicUserName| (let* ((name (username)) (registry-pos (strpos "." name nil nil nil nil nil t))) (cond (registry-pos (substring name 1 (sub1 registry-pos))) (t name)))) (loginhost/dir (cond ((or (null loginhost/dir) (eq loginhost/dir (quote {dsk}))) (concat "{PHYLUM}<" |\\BasicUserName| ">LISP>")) (t loginhost/dir))))) (initvars (|\\UserHomeDirectory| (u-case (packfilename.string (quote host) (filenamefield loginhost/dir (quote host)) (quote directory) |\\BasicUserName|))) (tempdir (concat |\\UserHomeDirectory| "TEMP>")) (home-machine-name "") (private-lispusersdirectories nil) (*cache-directories* nil))))
(* |;;| "Who am I?")
(declare\: donteval@compile
(rpaq |\\BasicUserName| (let* ((name (username)) (registry-pos (strpos "." name nil nil nil nil nil t))) (cond (registry-pos (substring name 1 (sub1 registry-pos))) (t name))))
(rpaq loginhost/dir (cond ((or (null loginhost/dir) (eq loginhost/dir (quote {dsk}))) (concat "{PHYLUM}<" |\\BasicUserName| ">LISP>")) (t loginhost/dir)))
)
(rpaq? |\\UserHomeDirectory| (u-case (packfilename.string (quote host) (filenamefield loginhost/dir (quote host)) (quote directory) |\\BasicUserName|)))
(rpaq? tempdir (concat |\\UserHomeDirectory| "TEMP>"))
(rpaq? home-machine-name "")
(rpaq? private-lispusersdirectories nil)
(rpaq? *cache-directories* nil)
(rpaqq env-tailoring-init-commands ((* |;;;| " Misc environmental tailoring") (declare\: donteval@load donteval@compile (files (sysload noerror from lispusers) pagehold) (vars (|MaxValueLeftMargin| 512) (scrollbarwidth 20) (fixspelldefault (quote \n)) (\\ethertimeout 3000) (empress#sides 2) (*print-case* :downcase)) (* |;;| "FileManager defaults") (vars (cleanupoptions (quote (rc st))) (copyrightflg (quote default)) (recompiledefault (quote exprs)) (*default-cleanup-compiler* (quote cl:compile-file)) (*default-makefile-environment* (quote (:package "XCL-USER" :readtable "XCL" :base 10)))) (* |;;| "None of us here are system hackers") (vars (*original-give-and-take-directories* *give-and-take-directories*) (*give-and-take-directories* (cl:remove-if (cl:function (cl:lambda (file) (cl:member (cl:pathname-host file) (quote ("ERIS" "ERINYES")) :test (cl:function string-equal)))) *give-and-take-directories*))) (* |;;| "I don't like being told that I haven't listed files...") (advise files?) (* |;;| "Load up the extended vmem stuff") (p (eval-at-greet (cl:when (and (eq makesysname (quote :lyric)) (eq (machinetype) (quote dorado))) (filesload (sysload from lispusers) extendedvmem) (install-extended-virtual-memory)) (cl:when (cl:fboundp (quote describe-virtual-memory)) (describe-virtual-memory)))) (* |;;| "Check greetdates whenever I log back in") (addvars (afterlogoutforms (|for| greet-date |in| greetdates |bind| (today ← (date)) |when| (eql 1 (strpos (car greet-date) today nil nil nil nil (uppercasearray))) |do| (|printout| t t (cdr greet-date) t)))))))
(* |;;;| " Misc environmental tailoring")
(declare\: donteval@load donteval@compile
(filesload (sysload noerror from lispusers) pagehold)
(rpaqq |MaxValueLeftMargin| 512)
(rpaqq scrollbarwidth 20)
(rpaqq fixspelldefault \n)
(rpaqq \\ethertimeout 3000)
(rpaqq empress#sides 2)
(rpaq *print-case* :downcase)
(rpaqq cleanupoptions (rc st))
(rpaqq copyrightflg default)
(rpaqq recompiledefault exprs)
(rpaqq *default-cleanup-compiler* cl:compile-file)
(rpaqq *default-makefile-environment* (:package "XCL-USER" :readtable "XCL" :base 10))
(rpaq *original-give-and-take-directories* *give-and-take-directories*)
(rpaq *give-and-take-directories* (cl:remove-if (cl:function (cl:lambda (file) (cl:member (cl:pathname-host file) (quote ("ERIS" "ERINYES")) :test (cl:function string-equal)))) *give-and-take-directories*))
(xcl:reinstall-advice (quote files?) :before (quote ((:last (setq notlistedfiles nil)))))
(readvise files?)
(eval-at-greet (cl:when (and (eq makesysname (quote :lyric)) (eq (machinetype) (quote dorado))) (filesload (sysload from lispusers) extendedvmem) (install-extended-virtual-memory)) (cl:when (cl:fboundp (quote describe-virtual-memory)) (describe-virtual-memory)))
(addtovar afterlogoutforms (|for| greet-date |in| greetdates |bind| (today ← (date)) |when| (eql 1 (strpos (car greet-date) today nil nil nil nil (uppercasearray))) |do| (|printout| t t (cdr greet-date) t)))
)
(rpaqq patch-init-commands ((* |;;;| " Patches") (fns purge-file-advice purge-advice) (declare\: donteval@load donteval@compile (* |;;| "") (* |;;| "Start the Lyric-only stuff") (e (printout nil "(" .ppftl (quote (cl:when (eq makesysname :lyric))) t)) (* |;;| "Add NS fileserver random-access support") (initvars (*nsfiling-random-access* t)) (* |;;| "Fix some compiler bogosity") (advise cl:compile) (* |;;| "Add a few missing optimizers") (files (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) base-optimizers) (* |;;| "The interpreted LET* function is busted") (p (/putd (quote let*) nil)) (* |;;| "The var \\BrushAList is broken in the loadup - it ends in (... . NOBIND) instead of (... . NIL)") (* \; "Some people have their system set up to be so paranoid that it is always checking vars to see if they are eq to NOBIND, and generating an error if they are. Since, in the last loop thru the list, the var is indeed bound to NOBIND, we got troubles. The following piece of code is structured in a convoluted way to get around this problem.") (vars (|\\BrushAList| (cl:do ((x |\\BrushAList| (cdr x)) (number-good-brushes 0 (cl:incf number-good-brushes)) (brushes nil) (number-brushes (length |\\BrushAList|))) ((= number-good-brushes number-brushes) (cl:nreverse brushes)) (cl:push (car x) brushes)))) (* |;;| "Advice saved in a file often gets duplicated. This tries to fix it.") (addvars (makefileforms (purge-file-advice file))) (advise makefile) (* |;;| "Fix the SEdit hang bug") (p (changename (quote |\\\\seditA0001|) (quote readp) (quote \\sysbufp))) (* |;;| "") (* |;;| "End the Lyric-only stuff") (e (printout nil " )" t)))))
(* |;;;| " Patches")
(defineq
(purge-file-advice
(lambda (file) (* \; "Edited 30-Oct-87 11:08 by smL")
(|for| f |in| (filecomslst (rootfilename file)
'advice) |do| (purge-advice f))))
(purge-advice
(lambda (fn) (* \; "Edited 30-Oct-87 11:07 by smL")
(|if| (hasdef fn 'advice)
|then| (putdef fn 'advice (let ((advice (getdef fn 'advice)))
(intersection advice advice)))
fn
|else| nil)))
)
(declare\: donteval@load donteval@compile
(cl:when (eq makesysname :lyric)
(rpaq? *nsfiling-random-access* t)
(xcl:reinstall-advice (quote cl:compile) :around (quote ((:last (let (compiler::*input-stream*) (xcl:inner))))))
(readvise cl:compile)
(filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) base-optimizers)
(/putd (quote let*) nil)
(rpaq |\\BrushAList| (cl:do ((x |\\BrushAList| (cdr x)) (number-good-brushes 0 (cl:incf number-good-brushes)) (brushes nil) (number-brushes (length |\\BrushAList|))) ((= number-good-brushes number-brushes) (cl:nreverse brushes)) (cl:push (car x) brushes)))
(addtovar makefileforms (purge-file-advice file))
(xcl:reinstall-advice (quote makefile) :after (quote ((:last (purge-file-advice file)))) :around (quote ((:last (let ((prettyflg (and (not (memb (quote fast) options)) prettyflg))) (declare (cl:special prettyflg)) *)) (:last (let ((|ObjectAlwaysPPFlag| nil)) *)))))
(readvise makefile)
(changename (quote |\\\\seditA0001|) (quote readp) (quote \\sysbufp))
)
)
(* |;;|
"Wants to be (COMS * FILECACHE-INIT-COMMANDS), but the FileCrasher doesn't exist in Lyric, yet. Probably never will."
)
(rpaqq filecache-init-commands ((* |;;;| "File caching stuff") (files (from "{EG:}<Lanning>FileCache>") filecache) (declare\: donteval@load (p (|if| (boundp (quote fcache.version.number)) |then| (* |;;| "Set up some initial parameters") (|for| |propDescr| |in| (quote ((trust.cachelist t) (delay.delete t) (timetoverify 300) (io.block? t))) |do| (* \; "UNDOably, of course") (undosave (bquote (fcache.putprop (\\\, (car |propDescr|)) (\\\, (fcache.getprop (car |propDescr|)))))) (fcache.putprop (car |propDescr|) (cadr |propDescr|))) (* |;;| "Tell the fcache scavenger to ignore some files that I store on the cache partition") (/nconc (assoc (quote dorado) fcache.scavenge.ignore) (copy (quote (*.sysout updateloops.cm)))) (* |;;| "Treat any mail files as private files if I'm not on my normal machine") (|if| (not (string-equal home-machine-name (etherhostname))) |then| (|/push| private.files (quote *.mail)))))) (* |;;| "File cache msg window stuff") (initvars (file-cache-message-stream-region (|with| region (windowprop promptwindow (quote region)) (createregion left (difference bottom height) width height))) (file-cache-message-stream-icon-position (|with| region (windowprop promptwindow (quote region)) (|create| position xcoord ← (difference left 75) ycoord ← bottom)))) (declare\: donteval@load (p (|if| (boundp (quote fcache.version.number)) |then| (filesload (sysload noerror from lispusers) filecachemsgwindow) (* \; "UNDOably, of course") (undosave (bquote (dspfont (\\\, (dspfont (fontcreate (quote gacha) 8) *file-cache-message-stream*)) (\\\, *file-cache-message-stream*)))) (dspreset *file-cache-message-stream*) (shrinkw *file-cache-message-stream*))))))
(rpaqq font-setup-init-commands ((* |;;;| "Define printing/fonts the way people like. This includes setting prettyprinting fonts used by the editor and others, Lafite fonts, default flags controlling prettyprinting at the top level, ... This needs to be early, so other utils get the desired fonts.") (alists (fontdefs generic-init)) (initvars (\\font-profile-name (quote generic-init))) (declare\: donteval@load donteval@compile (p (eval-at-greet (fontset \\font-profile-name t) (cl:when (boundp (quote promptfont)) (undosave (bquote (dspfont (\\\, (dspfont promptfont promptwindow)) (\\\, promptwindow))))))) (advise getpromptwindow))))
(* |;;;|
"Define printing/fonts the way people like. This includes setting prettyprinting fonts used by the editor and others, Lafite fonts, default flags controlling prettyprinting at the top level, ... This needs to be early, so other utils get the desired fonts."
)
(addtovar fontdefs (generic-init (fontchangeflg . all) (filelinelength . 102) (commentlinelength 80 . 102) (lambdafontlinelength . 95) (firstcol . 60) (prettylcom . 25) (listfilestr . "
") (|ObjectDontPPFlag| . t) (sysprettyflg . t) (**comment**flg) (fontprofile (defaultfont 1 (gacha 10) (gacha 8) (terminal 8)) (boldfont 2 (helvetica 10 brr) (helvetica 8 brr) (modern 8 brr)) (littlefont 3 (helvetica 8) (helvetica 6 mir) (modern 6 mir)) (bigfont 4 (helvetica 12 brr) (helvetica 10 brr) (modern 10 brr)) (userfont boldfont) (commentfont littlefont) (lambdafont bigfont) (systemfont) (clispfont boldfont) (changefont) (prettycomfont boldfont) (tinyfont littlefont) (font1 defaultfont) (font2 boldfont) (font3 littlefont) (font4 bigfont) (font5 5 (helvetica 10 bir) (helvetica 8 bir) (modern 8 bir)) (font6 6 (helvetica 10 brr) (helvetica 8 brr) (modern 8 brr)) (font7 7 (gacha 12) (gacha 12) (terminal 12)) (font8 8 (cream 10) (cream 10) (modern 10 mir)) (font9 9 (cream 10 brr) (cream 10 brr) (modern 10 bir)) (font10 10 (cream 12) (cream 12) (modern 12 mir)) (font11 11 (timesroman 10) (timesroman 10) (classic 10)) (|\\WindowTitleFont| bigfont) (lafitetitlefont |\\WindowTitleFont|) (chat.font font7))))
(rpaq? \\font-profile-name (quote generic-init))
(declare\: donteval@load donteval@compile
(eval-at-greet (fontset \\font-profile-name t) (cl:when (boundp (quote promptfont)) (undosave (bquote (dspfont (\\\, (dspfont promptfont promptwindow)) (\\\, promptwindow))))))
(xcl:reinstall-advice (quote getpromptwindow) :before (quote ((:last (cond ((and (null font) (boundp (quote promptfont))) (setq font promptfont)))))))
(readvise getpromptwindow)
)
(declare\: eval@loadwhen (not *generic-init-loaded*) donteval@compile docopy
(filesload (sysload from lispusers) loadmenuitems)
)
(* |;;| "Machine status")
(rpaqq who-line-commands ((* |;;;| "Give us a Who-Line") (* |;;| "Load and start the who-line") (declare\: donteval@load donteval@compile (files (sysload from lispusers) who-line) (* |;;| "Define these now, instead of with an INITVARS, because (i) Who-Line might have been in the sysout, and (ii) you can't define the entries untill the Who-Line code is loaded.") (vars (*who-line-anchor* (quote (:justify :top))) (*who-line-display-names?* t) (*who-line-directories* (list |\\UserHomeDirectory|)) (*who-line-entries* (list *who-line-vmem-entry* *who-line-symbol-space-entry* *who-line-package-entry* *who-line-readtable-entry* *who-line-tty-proc-entry* *who-line-tty-state-entry* *who-line-directory-entry* *who-line-time-entry*))) (p (eval-at-greet (install-who-line-options) (cl:when (and (boundp (quote *who-line*)) (windowp *who-line*)) (undosave (bquote (closew (\\\, *who-line*))))))))))
(* |;;;| "Give us a Who-Line")
(* |;;| "Load and start the who-line")
(declare\: donteval@load donteval@compile
(filesload (sysload from lispusers) who-line)
(rpaqq *who-line-anchor* (:justify :top))
(rpaqq *who-line-display-names?* t)
(rpaq *who-line-directories* (list |\\UserHomeDirectory|))
(rpaq *who-line-entries* (list *who-line-vmem-entry* *who-line-symbol-space-entry* *who-line-package-entry* *who-line-readtable-entry* *who-line-tty-proc-entry* *who-line-tty-state-entry* *who-line-directory-entry* *who-line-time-entry*))
(eval-at-greet (install-who-line-options) (cl:when (and (boundp (quote *who-line*)) (windowp *who-line*)) (undosave (bquote (closew (\\\, *who-line*))))))
)
(rpaqq vstats-init-commands ((* |;;;| "Storage stuff") (initvars (vstats.clock.interval 0) (vstats.mutil.interval nil) (vstats.position (createposition (difference screenwidth 147) 0))) (declare\: donteval@load donteval@compile (loadmenuitems "System-Aids" (((sysload from lispusers) "VStats") (let ((vstats-item (|for| item |in| |BackgroundMenuCommands| |thereis| (string-equal "VStats" (car item))))) (cl:when vstats-item (/dremove vstats-item |BackgroundMenuCommands|)))) (((sysload from lispusers) |Storage|) (showstorage (quote item)))))))
(* |;;;| "Storage stuff")
(rpaq? vstats.clock.interval 0)
(rpaq? vstats.mutil.interval nil)
(rpaq? vstats.position (createposition (difference screenwidth 147) 0))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "System-Aids") (quote ((sysload from lispusers) "VStats")) (quote (let ((vstats-item (|for| item |in| |BackgroundMenuCommands| |thereis| (string-equal "VStats" (car item))))) (cl:when vstats-item (/dremove vstats-item |BackgroundMenuCommands|)))))
(|AddLoadMenuItem| (quote "System-Aids") (quote ((sysload from lispusers) |Storage|)) (quote (showstorage (quote item))))
)
(* |;;| "Display control")
(rpaqq screen-setup-init-commands ((* |;;;| "Screen layout stuff") (declare\: donteval@load donteval@compile (vars (windowtitleshade grayshade)) (* |;;| "Some interesting background shades") (files (sysload from "{FS8:PARC:XEROX}<Foster>Lisp>Users>") "BITMAP-GALLERY" "GRANITE") (* |;;| "Rearrange the screen") (initvars (\\rearrange-screen (not (cl:member "ROOMS" *modules* :test (cl:function string-equal))))) (p (eval-at-greet (cl:when \\rearrange-screen (* |;;| "Change the background shade") (|GraniteBG|) (* |;;| "Fix up the prompt window") (undosave (bquote (dsptexture (\\\, (dsptexture 42405 promptwindow)) (\\\, promptwindow)))) (undosave (bquote (dspoperation (\\\, (dspoperation (quote replace) promptwindow)) (\\\, promptwindow)))) (undosave (bquote (windowprop (\\\, promptwindow) border (\\\, (windowprop promptwindow (quote border)))))) (windowprop promptwindow (quote border) 1) (undosave (bquote (windowprop (\\\, promptwindow) title (\\\, (windowprop promptwindow (quote title)))))) (windowprop promptwindow (quote title) nil) (clearw promptwindow) (* |;;| "Rearrange the screen a bit") (cl:when (openwp logow) (undosave (bquote (openw (\\\, logow)))) (closew logow)) (let* ((window-gap 2) (window-width (difference (quotient screenwidth 2) (plus window-gap window-gap)))) (undosave (bquote (shapew (\\\, promptwindow) (\\\, (windowprop promptwindow (quote region)))))) (shapew promptwindow (let ((height (heightifwindow (times 4 (fontprop (dspfont nil promptwindow) (quote height))) (windowprop promptwindow (quote title)) (windowprop promptwindow (quote border))))) (createregion window-gap (difference (|if| (and (boundp (quote *who-line*)) (windowp *who-line*)) |then| (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) |else| screenheight) (plus window-gap height)) window-width height))) (undosave (bquote (shapew (\\\, |\\TopLevelTtyWindow|) (\\\, (windowprop |\\TopLevelTtyWindow| (quote region)))))) (shapew |\\TopLevelTtyWindow| (let ((height (heightifwindow (times 17 (fontprop (dspfont nil |\\TopLevelTtyWindow|) (quote height))) (windowprop |\\TopLevelTtyWindow| (quote title)) (windowprop |\\TopLevelTtyWindow| (quote border))))) (createregion window-gap (difference (|fetch| (region bottom) |of| (windowprop promptwindow (quote region))) (plus window-gap height)) window-width height))))))) (* |;;| "Make the standard icon functions be cute") (initvars (\\load-grid-icons t) (enforce.icon.grid t)) (p (eval-at-greet (cl:when \\load-grid-icons (filesload (from lispusers) grid-icons)) (cl:when (and \\rearrange-screen (boundp (quote loaded-files-icon-window)) (windowp loaded-files-icon-window)) (movew loaded-files-icon-window 5 100)))))))
(* |;;;| "Screen layout stuff")
(declare\: donteval@load donteval@compile
(rpaq windowtitleshade grayshade)
(filesload (sysload from "{FS8:PARC:XEROX}<Foster>Lisp>Users>") "BITMAP-GALLERY" "GRANITE")
(rpaq? \\rearrange-screen (not (cl:member "ROOMS" *modules* :test (cl:function string-equal))))
(eval-at-greet (cl:when \\rearrange-screen (* |;;| "Change the background shade") (|GraniteBG|) (* |;;| "Fix up the prompt window") (undosave (bquote (dsptexture (\\\, (dsptexture 42405 promptwindow)) (\\\, promptwindow)))) (undosave (bquote (dspoperation (\\\, (dspoperation (quote replace) promptwindow)) (\\\, promptwindow)))) (undosave (bquote (windowprop (\\\, promptwindow) border (\\\, (windowprop promptwindow (quote border)))))) (windowprop promptwindow (quote border) 1) (undosave (bquote (windowprop (\\\, promptwindow) title (\\\, (windowprop promptwindow (quote title)))))) (windowprop promptwindow (quote title) nil) (clearw promptwindow) (* |;;| "Rearrange the screen a bit") (cl:when (openwp logow) (undosave (bquote (openw (\\\, logow)))) (closew logow)) (let* ((window-gap 2) (window-width (difference (quotient screenwidth 2) (plus window-gap window-gap)))) (undosave (bquote (shapew (\\\, promptwindow) (\\\, (windowprop promptwindow (quote region)))))) (shapew promptwindow (let ((height (heightifwindow (times 4 (fontprop (dspfont nil promptwindow) (quote height))) (windowprop promptwindow (quote title)) (windowprop promptwindow (quote border))))) (createregion window-gap (difference (|if| (and (boundp (quote *who-line*)) (windowp *who-line*)) |then| (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) |else| screenheight) (plus window-gap height)) window-width height))) (undosave (bquote (shapew (\\\, |\\TopLevelTtyWindow|) (\\\, (windowprop |\\TopLevelTtyWindow| (quote region)))))) (shapew |\\TopLevelTtyWindow| (let ((height (heightifwindow (times 17 (fontprop (dspfont nil |\\TopLevelTtyWindow|) (quote height))) (windowprop |\\TopLevelTtyWindow| (quote title)) (windowprop |\\TopLevelTtyWindow| (quote border))))) (createregion window-gap (difference (|fetch| (region bottom) |of| (windowprop promptwindow (quote region))) (plus window-gap height)) window-width height))))))
(rpaq? \\load-grid-icons t)
(rpaq? enforce.icon.grid t)
(eval-at-greet (cl:when \\load-grid-icons (filesload (from lispusers) grid-icons)) (cl:when (and \\rearrange-screen (boundp (quote loaded-files-icon-window)) (windowp loaded-files-icon-window)) (movew loaded-files-icon-window 5 100)))
)
(rpaqq rooms-init-commands ((declare\: donteval@load donteval@compile (initvars (user-suite-directories (list (concat |\\UserHomeDirectory| "ROOMS>"))) (roomsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Lyric>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Medley>Sources>" "{Pogo:AISNorth:XEROX}<Rooms>Medley>Sources>"))))) (roomsusersdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Lyric>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>Users>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Medley>Users>" "{NB:PARC:XEROX}<Rooms>Lyric>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Medley>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>Users>")))))) (* \; "Force CL:EVAL instead of the default IL:EVAL, since IL:EVAL doesn't understand some things.") (loadmenuitems "Screen-Maintanance" (((sysload from rooms) "ROOMS") (cl:eval (quote (progn (set (cl:intern "*SUITE-DIRECTORIES*" "ROOMS") (append user-suite-directories (cl:eval (cl:intern "*SUITE-DIRECTORIES*" "ROOMS")))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from "{NB:PARC:Xerox}<CommonLens>CURRENT>") "CLens-Rooms"))) (cl:dolist (utility (quote ("Rooms-Intro" "Rooms-Notes"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from rooms) (\\\, utility))))) (cl:dolist (utility (bquote ("Background-Menu-Buttons" "Office.suite" "Touchy-Buttons" "Random-Window-Types" "Snuggle" "Notecards-Window-Types" (\\\,@ (if (not (cl:fboundp (quote lafite))) then nil elseif (not (cl:fboundp (quote \\lafite.getmailfolder))) then (quote ("New-Lafite-Window-Types")) else (quote ("Lafite-Window-Types")))) "Un-Hide-Tty" "Rooms-Videohax" (\\\,@ (if (eq makesysname :lyric) then nil else (quote ("WallPaper"))))))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from roomsusers) (\\\, utility)))))))))))))
(declare\: donteval@load donteval@compile
(rpaq? user-suite-directories (list (concat |\\UserHomeDirectory| "ROOMS>")))
(rpaq? roomsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Lyric>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Medley>Sources>" "{Pogo:AISNorth:XEROX}<Rooms>Medley>Sources>")))))
(rpaq? roomsusersdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Lyric>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>Users>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Medley>Users>" "{NB:PARC:XEROX}<Rooms>Lyric>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Medley>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>Users>")))))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from rooms) "ROOMS")) (quote (cl:eval (quote (progn (set (cl:intern "*SUITE-DIRECTORIES*" "ROOMS") (append user-suite-directories (cl:eval (cl:intern "*SUITE-DIRECTORIES*" "ROOMS")))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from "{NB:PARC:Xerox}<CommonLens>CURRENT>") "CLens-Rooms"))) (cl:dolist (utility (quote ("Rooms-Intro" "Rooms-Notes"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from rooms) (\\\, utility))))) (cl:dolist (utility (bquote ("Background-Menu-Buttons" "Office.suite" "Touchy-Buttons" "Random-Window-Types" "Snuggle" "Notecards-Window-Types" (\\\,@ (if (not (cl:fboundp (quote lafite))) then nil elseif (not (cl:fboundp (quote \\lafite.getmailfolder))) then (quote ("New-Lafite-Window-Types")) else (quote ("Lafite-Window-Types")))) "Un-Hide-Tty" "Rooms-Videohax" (\\\,@ (if (eq makesysname :lyric) then nil else (quote ("WallPaper"))))))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from roomsusers) (\\\, utility))))))))))
)
(rpaqq change-background-init-commands ((* |;;;| "Make it easy to change your background") (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "BackgroundImages" "StarBG" (nil from "{PHYLUM}<Loops>Faces>") "Dead") (|push| |BackgroundMenuCommands| (let ((bitmaps (quote (("Standard texture" . windowbackgroundshade) ("Gray shade" . grayshade) ("Light wall paper" . lightwallpaper) ("Medium wall paper" . wallpaper) ("Dark wall paper" . darkwallpaper) ("Waves" . wave-texture) ("Tweed" . xcl-user::*tweed-bm*) ("Chambray" . xcl-user::*chambray-bm*) ("Canvas" . xcl-user::*canvas-bm*) ("Corduroy" . xcl-user::*corduroy-bm*) ("Seersucker" . xcl-user::*seersucker-bm*) ("Burlap" . xcl-user::*burlap-bm*) ("Mesh" . mesh-texture)))) (images (background.files)) (menu-items (quote (("Stars" (quote (starbg)) "Fill the background with stars" (subitems ("ET go home" (quote (|SaucerOff|)) "Get rid of the saucer"))) ("Granite" (quote (|GraniteBG|)) "Fill the background with a pleasing, almost random shade") ("Dead" (changebackground (expandbitmap dead-bm 2 2)) "Put a Deadhead on the background"))))) (bquote ("Change background" (quote (changebackground)) "Change the background to the default texture" (subitems ("Random texture" (quote (let ((shade (|\\Pick-One-At-Random| (quote ((\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| bm |else| (cdr bm)))) (\\\,@ (|for| item |in| menu-items |collect| (car item))) (\\\,@ images) "Rand"))))) (cond ((for item in menu-items thereis (and (cl:consp item) (stringp (car item)) (string-equal shade (car item))) finally (if $$val then (eval (cadr item))))) ((equal shade "Rand") (changebackground (rand 0 blackshade))) ((listp shade) (background.fetch (car shade) (cdr shade))) ((litatom shade) (changebackground (evalv shade))) (t (changebackground shade))))) "Change the background texture to a randomly selected shade") (\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| (bquote ((\\\, bm) (changebackground (\\\, bm)))) |else| (bquote ((\\\, (car bm)) (changebackground (\\\, (cdr bm)))))))) (\\\,@ menu-items) (\\\,@ (|for| image |in| images |collect| (bquote ((\\\, (car image)) (quote (background.fetch (quote (\\\, (car image))) (quote (\\\, (cdr image)))))))))))))))))))
(* |;;;| "Make it easy to change your background")
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "BackgroundImages" "StarBG" (nil from "{PHYLUM}<Loops>Faces>") "Dead")) (quote (|push| |BackgroundMenuCommands| (let ((bitmaps (quote (("Standard texture" . windowbackgroundshade) ("Gray shade" . grayshade) ("Light wall paper" . lightwallpaper) ("Medium wall paper" . wallpaper) ("Dark wall paper" . darkwallpaper) ("Waves" . wave-texture) ("Tweed" . xcl-user::*tweed-bm*) ("Chambray" . xcl-user::*chambray-bm*) ("Canvas" . xcl-user::*canvas-bm*) ("Corduroy" . xcl-user::*corduroy-bm*) ("Seersucker" . xcl-user::*seersucker-bm*) ("Burlap" . xcl-user::*burlap-bm*) ("Mesh" . mesh-texture)))) (images (background.files)) (menu-items (quote (("Stars" (quote (starbg)) "Fill the background with stars" (subitems ("ET go home" (quote (|SaucerOff|)) "Get rid of the saucer"))) ("Granite" (quote (|GraniteBG|)) "Fill the background with a pleasing, almost random shade") ("Dead" (changebackground (expandbitmap dead-bm 2 2)) "Put a Deadhead on the background"))))) (bquote ("Change background" (quote (changebackground)) "Change the background to the default texture" (subitems ("Random texture" (quote (let ((shade (|\\Pick-One-At-Random| (quote ((\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| bm |else| (cdr bm)))) (\\\,@ (|for| item |in| menu-items |collect| (car item))) (\\\,@ images) "Rand"))))) (cond ((for item in menu-items thereis (and (cl:consp item) (stringp (car item)) (string-equal shade (car item))) finally (if $$val then (eval (cadr item))))) ((equal shade "Rand") (changebackground (rand 0 blackshade))) ((listp shade) (background.fetch (car shade) (cdr shade))) ((litatom shade) (changebackground (evalv shade))) (t (changebackground shade))))) "Change the background texture to a randomly selected shade") (\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| (bquote ((\\\, bm) (changebackground (\\\, bm)))) |else| (bquote ((\\\, (car bm)) (changebackground (\\\, (cdr bm)))))))) (\\\,@ menu-items) (\\\,@ (|for| image |in| images |collect| (bquote ((\\\, (car image)) (quote (background.fetch (quote (\\\, (car image))) (quote (\\\, (cdr image))))))))))))))))
)
(rpaqq display-control-init-commands ((declare\: donteval@load donteval@compile (loadmenuitems "Screen-Maintanance" (((sysload from lispusers) "WDWHacks")) (((sysload from lispusers) "Turbo-Windows")) (((sysload from lispusers) "Solid-Movew")) (((sysload from lispusers) "NSDisplaySizes")) (((sysload from lispusers) "SNAPW-ICON"))))))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "WDWHacks")))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "Turbo-Windows")))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "Solid-Movew")))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "NSDisplaySizes")))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "SNAPW-ICON")))
)
(rpaqq idle-init-commands ((* |;;;| "The Idle package") (declare\: donteval@load donteval@compile (loadmenuitems "IdlePatterns" (((sysload from lispusers) "IdleHax")) (((sysload from lispusers) "IdleDrain") (/listput idle.profile (quote displayfn) (quote idle-drain))) (((sysload from lispusers) "ReadBrush")) (((sysload from "{PHYLUM}<Colab>Andes>Users>") "Bouncing-Face")) (((sysload from lispusers) "StarBG") (/listput idle.profile (quote displayfn) (quote |Cosmos|))) (((sysload from lispusers) "Pac-Man-Idle") (/listput idle.profile (quote displayfn) (quote |Pac-Man-Idle|))) (((sysload from "{QV}<Bagley>Lisp>") "Idle-Cost")) (((sysload) "ScreenPaper") (/listput idle.profile (quote displayfn) (quote screenpaper))) (((sysload from private-lispusers) "Idle-Lyrics") (/listput idle.profile (quote displayfn) (quote xcl-user::idle-lyrics)))) (p (eval-at-greet (/listput idle.profile (quote forget) nil) (/listput idle.profile (quote allowed.logins) nil))))))
(* |;;;| "The Idle package")
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "IdleHax")))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "IdleDrain")) (quote (/listput idle.profile (quote displayfn) (quote idle-drain))))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "ReadBrush")))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from "{PHYLUM}<Colab>Andes>Users>") "Bouncing-Face")))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "StarBG")) (quote (/listput idle.profile (quote displayfn) (quote |Cosmos|))))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "Pac-Man-Idle")) (quote (/listput idle.profile (quote displayfn) (quote |Pac-Man-Idle|))))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from "{QV}<Bagley>Lisp>") "Idle-Cost")))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload) "ScreenPaper")) (quote (/listput idle.profile (quote displayfn) (quote screenpaper))))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from private-lispusers) "Idle-Lyrics")) (quote (/listput idle.profile (quote displayfn) (quote xcl-user::idle-lyrics))))
(eval-at-greet (/listput idle.profile (quote forget) nil) (/listput idle.profile (quote allowed.logins) nil))
)
(rpaqq clock-init-commands ((* |;;;| "Telling the time") (* |;;| "Standard clock is the Biclock, in the lower-left corner") (initvars (biclockinitialprops (quote (horizontal left vertical bottom size 95)))) (* |;;| "Optional clock is CROCK, also in the lower-left corner") (declare\: donteval@load donteval@compile (files (sysload noerror from lispusers) biclock) (loadmenuitems nil (((sysload from lispusers) "Crock") (cl:when (and (boundp (quote biclockwindow)) (windowp biclockwindow)) (closew biclockwindow)))))))
(* |;;;| "Telling the time")
(* |;;| "Standard clock is the Biclock, in the lower-left corner")
(rpaq? biclockinitialprops (quote (horizontal left vertical bottom size 95)))
(* |;;| "Optional clock is CROCK, also in the lower-left corner")
(declare\: donteval@load donteval@compile
(filesload (sysload noerror from lispusers) biclock)
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Crock")) (quote (cl:when (and (boundp (quote biclockwindow)) (windowp biclockwindow)) (closew biclockwindow))))
)
(* |;;| "Programming stuff")
(rpaqq programming-init-commands ((* |;;;| "Editing code") (functions notice) (* |;;| "Saving files") (functions make) (* |;;| "For testing optimizers") (functions oam) (* |;;| "Handy exec commands") (commands "BREAK" "UNBREAK" "CALLS" "DESCRIBE" "EC" "EFF" "FILES?" "IC" "NOTICE" "MAKE" "SPY") (* |;;| "never really worked - (loadmenuitems \"ProgrammingAids\" (((sysload from lispusers) \"Step-Command-Menu\")))") (* |;;| "") (* |;;| "SEDIT stuff") (declare\: donteval@load donteval@compile (p (eval-at-greet (* |;;| "Give us a META key if running on a Dorado") (selectq (machinetype) (dorado (metashift t)) nil) (* |;;| "Reset SEdit so it gets the correct fonts") (case makesysname (:lyric (sedit.reset)) (cl:otherwise (cl:funcall (cl:intern "RESET" (cl:find-package "SEDIT"))))) (* |;;| "Hacking SEdit so it uses better package/readtable defaults") (case makesysname (:lyric (filesload (sysload noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "SEDIT-HACK")) (cl:otherwise (filesload (sysload from lispusers) "sedit-profile"))))) (* |;;| "Change the SEdit EXPAND behavior to expand definers in a reasonable way") (loadmenuitems "ProgrammingAids" (((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Definers"))) (* |;;| "The Eval&Insert hook") (loadmenuitems "ProgrammingAids" (((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Eval"))) (* |;;| "Exit/Compile hooks") (p (case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "SEdit-Compile")))))) (* |;;| "TTY editor stuff") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "CL-TTYEdit")))) (declare\: donteval@load donteval@compile (* |;;| "Better WHEREIS facility") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "New-Where-Is"))) (* |;;| "Checking out lexical contexts in a break") (p (case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "Debugger-Context")))))) (* |;;| "Save-Your-Ass") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "Checkpoint"))) (* |;;| "Spy button") (initvars (\spy.button.pos nil)) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) spy) (spy.button \spy.button.pos))) (* |;;| "Graph calls") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "GraphCalls"))) (* |;;| "The Source Manager") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "Manager"))) (* |;;| "Better file listing tools") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "PP-Code-File")) (((sysload from lispusers) "PrettyFileIndex"))) (* |;;| "TEdit executive") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "TExec"))) (* |;;| "Iteration packages") (loadmenuitems "ProgrammingAids" (((sysload from "{Phylum}<Brotsky>rcw>") "OSS")))) (declare\: donteval@load donteval@compile (* |;;| "Moving between Xerox Lisp and the rest of the world") (p (|AddLoadMenuItem| "ProgrammingAids" (case makesysname (:lyric (quote ((sysload from lispusers) "Port-CLFile"))) (cl:otherwise (quote ((sysload from lispusers) "XCL-Bridge")))))))))
(* |;;;| "Editing code")
(cl:defun notice (&rest files) "Notice a set of files, so things on them can be edited" (* |;;;| "Return 4 values: a list of all files that were noticed, a list of files that were already noticed, a list of files that weren't noticed because they weren't loaded, and a list of files that couldn't be found.") (cl:labels ((canonocal-filemanager-name (path) "Return the canonical FileManager name of a file" (cl:intern (cl:string-upcase (cl:pathname-name path)) (cl:find-package "IL"))) (find-source-file (file-name &optional (search-path-list directories)) "Return the full pathname of the source file" (or (* \; "In case we are given enough to find the file") (cl:probe-file file-name) (* \; "Check for the original source, in it's original location") (let ((original-source-file-name (cdr (cl:first (get (canonocal-filemanager-name (pathname file-name)) (quote filedates)))))) (cl:if original-source-file-name (cl:probe-file original-source-file-name) nil)) (* \; "As a last resort, check the list of directories") (cl:find-if (cl:function cl:probe-file) (cl:mapcar (cl:function (cl:lambda (dir) (cl:merge-pathnames file-name dir))) search-path-list)))) (file-noticed-p (path) "Has the file been noticed?" (cl:member (canonocal-filemanager-name path) filelst :test (quote eq))) (file-loaded-p (path) "Has the file been loaded?" (not (null (get (canonocal-filemanager-name path) (quote filedates))))) (notice-file (path) "Notice the file" (load path (quote prop)))) (let ((alread-noticed-files nil) (not-loaded-files nil) (noticed-files nil) (not-found-files nil)) (cl:mapc (cl:function (cl:lambda (file) (let ((pathname (find-source-file file))) (cond ((null pathname) (cl:push file not-found-files)) ((file-noticed-p pathname) (cl:push pathname alread-noticed-files)) ((file-loaded-p pathname) (loadfrom pathname nil (quote prop)) (cl:push pathname noticed-files)) (t (cl:push pathname not-loaded-files)))))) files) (cl:values noticed-files alread-noticed-files not-loaded-files not-found-files))))
(* |;;| "Saving files")
(cl:defun make (files) (let ((files (or files (cl:remove-if-not (cl:function (cl:lambda (file-name) (cdr (get file-name (quote file))))) filelst))) (original-dir *default-pathname-defaults*) file-dir roopt-file) (cl:unwind-protect (cl:dolist (file files) (cl:setq roopt-file (cl:pathname-name file)) (cl:setq roopt-file (cl:typecase roopt-file (string (cl:intern (cl:string-upcase roopt-file) (cl:find-package "IL"))) (cl:symbol (cl:intern (cl:symbol-name roopt-file) (cl:find-package "IL"))))) (cndir (cl:if (get roopt-file (quote filedates)) (let ((file-dir (unpackfilename.string (cdr (cl:first (get roopt-file (quote filedates))))))) (packfilename.string (quote host) (cl:getf file-dir (quote host)) (quote device) (cl:getf file-dir (quote device)) (quote directory) (cl:getf file-dir (quote directory)))) original-dir)) (cl:when (cl:funcall (quote cleanup) roopt-file) (cl:load (packfilename.string (quote name) roopt-file (quote extension) "dfasl")))) (cndir original-dir))))
(* |;;| "For testing optimizers")
(cl:defun oam (form) "Optimize and Macroexpand the form. For use as an SEdit mutator." (compiler:optimize-and-macroexpand-1 form (compiler:make-empty-env) (compiler:make-context)))
(* |;;| "Handy exec commands")
(defcommand "BREAK" (&rest fns) "Set a breakpoint on the named functions." (eval (bquote (break (\\\,@ fns)))))
(defcommand "UNBREAK" (&rest fns) "Remove a breakpoint from the named functions." (eval (bquote (unbreak (\\\,@ fns)))))
(defcommand "CALLS" (fn) "Print out information about what the function calls." (cond ((not (cl:fboundp fn)) (cl:format t "~%~S has no function definition" fn)) ((cl:macro-function fn) (cl:format t "~%~S is a macro" fn)) ((cl:special-form-p fn) (cl:format t "~%~S is a special-form" fn)) (t (destructuring-bind (calls binds uses-free uses-global) (calls fn) (cl:format t "~%--- ~S ---" fn) (let ((format-string "~%~A:~{ ~S~}")) (cl:when (not (null calls)) (cl:format t format-string "CALLS" calls)) (cl:when (not (null binds)) (cl:format t format-string "BINDS" binds)) (cl:when (not (null uses-free)) (cl:format t format-string "SPECIALS USED" uses-free)) (cl:when (not (null uses-global)) (cl:format t format-string "GLOBALS USED" uses-global)))))) (cl:values))
(defcommand "DESCRIBE" (&rest objects) "Describe the named objects." (cl:mapc (cl:function (cl:lambda (x) (cl:format t "~&-- ~A --" x) (cl:describe x))) objects) (cl:values))
(defcommand "EC" (form) "Evaluate a compiled version of the form" (cl:funcall (prog2 (cl:format t "~%Compiling...") (cl:compile nil (bquote (cl:lambda nil (\\\, form)))) (cl:format t "done.~%"))))
(defcommand "EFF" (&rest patterns-commands) "Edit any uses of any of the patterns on any noticed file. Args are ..patterns - ..edit comands." (let* ((position (cl:position "-" patterns-commands :key (cl:function (lambda (pattern) (if (cl:symbolp pattern) then (cl:symbol-name pattern) else ""))) :test (cl:function string-equal))) (patterns (if (null position) then patterns-commands else (cl:butlast patterns-commands (- (length patterns-commands) position)))) (edit-commands (if position then (cl:subseq patterns-commands (1+ position)) else nil))) (case (cl:length patterns) (0 nil) (1 (editfromfile nil nil (cl:first patterns) edit-commands)) (cl:otherwise (editfromfile nil nil (bquote (*any* (\\\,@ patterns))) edit-commands)))) (cl:values))
(defcommand "FILES?" nil "Tell you about what source files need to be dumped." (files?) (cl:values))
(defcommand "IC" (fn) "Inspect the code for the function." (inspectcode (if (cl:symbolp fn) then (if (ccodep (getd fn)) then fn else (cl:compile nil (getd fn))) else (cl:compile nil (if (cl:member (car fn) (quote (cl:lambda lambda)) :test (cl:function eq)) then fn else (bquote (cl:lambda nil (\\\, fn))))))) (cl:values))
(defcommand "NOTICE" (&rest files) "Notice a set of files, so things on them can be edited" (cl:flet ((tell-user (files msg) (cl:when files (cl:format t "~%~A" msg) (cl:mapcar (cl:function (cl:lambda (path) (cl:format t "~%~5T~A" (cl:pathname-name path)))) files)))) (cl:multiple-value-bind (just-noticed previously-noticed not-loaded not-found) (cl:apply (cl:function notice) files) (tell-user just-noticed "Noticed files") (tell-user previously-noticed "Previously noticed files") (tell-user not-loaded "Not loaded, so not noticed files") (tell-user not-found "Could not find files")) (cl:values)))
(defcommand "MAKE" (&rest files) "Save, recompile, and reload the files." (make files) (cl:values))
(defcommand "SPY" (form) (cl:unwind-protect (progn (spy.start) (prog1 (cl:eval form) (spy.end))) (spy.end) (spy.tree)))
(* |;;|
"never really worked - (loadmenuitems \"ProgrammingAids\" (((sysload from lispusers) \"Step-Command-Menu\")))"
)
(* |;;| "")
(* |;;| "SEDIT stuff")
(declare\: donteval@load donteval@compile
(eval-at-greet (* |;;| "Give us a META key if running on a Dorado") (selectq (machinetype) (dorado (metashift t)) nil) (* |;;| "Reset SEdit so it gets the correct fonts") (case makesysname (:lyric (sedit.reset)) (cl:otherwise (cl:funcall (cl:intern "RESET" (cl:find-package "SEDIT"))))) (* |;;| "Hacking SEdit so it uses better package/readtable defaults") (case makesysname (:lyric (filesload (sysload noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "SEDIT-HACK")) (cl:otherwise (filesload (sysload from lispusers) "sedit-profile"))))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Definers")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Eval")))
(case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "SEdit-Compile")))))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "CL-TTYEdit")))
)
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "New-Where-Is")))
(case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "Debugger-Context")))))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "Checkpoint")))
(rpaq? \spy.button.pos nil)
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) spy)) (quote (spy.button \spy.button.pos)))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "GraphCalls")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "Manager")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "PP-Code-File")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "PrettyFileIndex")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "TExec")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from "{Phylum}<Brotsky>rcw>") "OSS")))
)
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| "ProgrammingAids" (case makesysname (:lyric (quote ((sysload from lispusers) "Port-CLFile"))) (cl:otherwise (quote ((sysload from lispusers) "XCL-Bridge")))))
)
(rpaqq old-utils-commands ((* |;;| "Used to be in the seperate file UTILS.") (* |;;| "Making sure that breaks happen") (fns |DebugMode|) (* |;;| "Used to be in Loops") (fns selectw) (functions de file) (usermacros de ee fv) (* |;;| "Print out a doc file") (fns |PrintDocFile|) (* |;;| "Just what is says") (fns |\\Pick-One-At-Random|) (functions |PickOneAtRandom|) (* |;;| "Ways to quit a sysout") (fns |GoodNight| |NewLisp|) (* |;;| "Make the KEY3.CM file on the top partition put you back in you last used partition, and the KEY2.CM restart the vmem, assuming that KEY1.CM starts a fresh sysout") (fns |RememberLastPartition| |RememberLispState|) (declare\: donteval@load donteval@compile (addvars (beforelogoutforms (|RememberLispState|) (|RememberLastPartition|))))))
(* |;;| "Used to be in the seperate file UTILS.")
(* |;;| "Making sure that breaks happen")
(defineq
(|DebugMode|
(lambda (debug-on-p all-execs-p) (* \; "Edited 25-Jan-88 08:19 by smL")
(|if| debug-on-p
|then| (setq nlsetqgag nil)
(setq helpflag break!)
(|if| all-execs-p
|then| (putassoc 'helpflag (list 'break!)
*per-exec-variables*))
|else| (setq nlsetqgag t)
(setq helpflag t)
(|if| all-execs-p
|then| (putassoc 'helpflag (list t)
*per-exec-variables*)))))
)
(* |;;| "Used to be in Loops")
(defineq
(selectw
(lambda nil (* \; "Edited 15-Jan-88 09:17 by smL")
(* |;;;| "Let the user select a window")
(|first| (clrprompt)
(|printout| promptwindow "Move mouse to desired window." t
"Then press down the CTRL key or click mouse")
|until| (or (keydownp 'ctrl)
(not (mousestate up))) |do| nil |finally| (getmousestate)
(clrprompt)
(return (whichw)))))
)
(defmacro de (|fn-name| |arg-list| &rest |body|) (* |;;;| "Shorthand for defineing functions") (bquote (defineq ((\\\, |fn-name|) (\\\, |arg-list|) (\\\,@ |body|)))))
(defmacro file (|file-name| &rest |file-package-commands|) (* |;;;| "Allows one to create a file giving the commands explicitly e.g. - (FILE FOO (VARS * FUMVARS) (FNS * FNSLIST)) - will create FOOCOMS and make file FOO") (let ((|real-file-name| (u-case |file-name|))) (bquote (progn (\\\, (|if| (null |file-package-commands|) |then| nil |elseif| (and (litatom (car |file-package-commands|)) (null (cdr |file-package-commands|))) |then| (bquote (/setatomval (filecoms (quote (\\\, |real-file-name|))) (getatomval (quote (\\\, (car |file-package-commands|)))))) |else| (bquote (/setatomval (filecoms (quote (\\\, |real-file-name|))) (quote (\\\, |file-package-commands|)))))) (resetform (radix 10) (makefile (quote (\\\, |real-file-name|))))))))
(addtovar usermacros (fv nil (e (freevars (\## (orr (up 1) nil)) t))) (ee nil (e (cursor t) t) (e (windowprop ttyineditwindow (quote title) (concat "TtyInEdit of " type " " atm)) t) (coms (tted do.ee ee))) (ee (dummy) (e (cursor t) t) (e (windowprop ttyineditwindow (quote title) (concat "TtyInEdit of " type " " atm)) t) (coms (tted do.ee ee))) (de nil (comsq (bi 1 -1) (e (dedite (\## 1)) t) (bo 1))))
(addtovar editcomsa de ee)
(addtovar editcomsl ee)
(* |;;| "Print out a doc file")
(defineq
(|PrintDocFile|
(lambda (utility-name print-server) (* \; "Edited 17-Mar-88 16:24 by smL")
(* |;;;| "Print out the documentation file for the named package")
(setq print-server (or print-server (car defaultprintinghost)))
(cl:flet ((find-doc-source-file nil (or (findfile (packfilename 'name utility-name 'extension
'tedit)
nil directories)
(findfile (packfilename 'name utility-name 'extension
'ted)
nil directories)
(findfile (packfilename 'name utility-name 'extension
'txt)
nil directories)
(findfile (packfilename 'name utility-name 'extension
'doc)
nil directories))))
(|if| (eq print-server t)
|then| (let ((doc-file (find-doc-source-file)))
(|if| doc-file
|then| (tedit doc-file)
|else| "No doc file found"))
|elseif| print-server
|then| (let ((doc-file (or (findfile (packfilename 'name utility-name 'extension
(selectq (printertype print-server)
((press fullpress)
'press)
(interpress 'ip)
(help "Unknown printer type!")))
nil directories)
(find-doc-source-file))))
(|if| doc-file
|then| (add.process `(empress ',doc-file nil ',print-server))
(concat "Printing file " doc-file " on printer " print-server)
|else| "No doc file found"))
|else| "No printer specified"))))
)
(* |;;| "Just what is says")
(defineq
(|\\Pick-One-At-Random|
(lambda (|list|) (* \; "Edited 15-Jan-88 09:20 by smL")
(* |;;;| "Return a random element of the list")
(resetlst (resetsave (randset t)
`(randset ,(randset)))
(car (nth |list| (rand 1 (length |list|)))))))
)
(defmacro |PickOneAtRandom| (&rest |elements|) (bquote (|\\Pick-One-At-Random| (quote (\\\, (mapcar |elements| (quote eval)))))))
(* |;;| "Ways to quit a sysout")
(defineq
(|GoodNight|
(lambda (|flag| |altoCommandString|) (* |smL| "20-Sep-85 14:43")
(let ((|stream| (openstream '{dsk}rem.cm\;1 'output 'old/new)))
(prin1 (or |altoCommandString| "Q")
|stream|)
(terpri |stream|)
(closef |stream|))
(logout |flag|)))
(|NewLisp|
(lambda nil (* \; "Edited 15-Jan-88 09:20 by smL")
(* |;;;| "Start up a new system, assuming that {DSK}KEY1.CM starts one up.")
(|if| (mouseconfirm "Do you really want to start up a new system?")
|then| (|GoodNight| t "@KEY1.CM"))))
)
(* |;;|
"Make the KEY3.CM file on the top partition put you back in you last used partition, and the KEY2.CM restart the vmem, assuming that KEY1.CM starts a fresh sysout"
)
(defineq
(|RememberLastPartition|
(lambda nil (* \; "Edited 15-Jan-88 09:21 by smL")
(* |;;;|
"Sets up the KEY3 CM file in the last partition (19 or 5) to put you back in this partition.")
(selectq (machinetype)
(dorado (|for| |partitionNumber| |in| '(19 5) |bind| |stream| |key3File|
|eachtime| (setq |key3File| (concat "{DSK" |partitionNumber| "}KEY3.CM;1"))
(setq |stream| (car (nlsetq (getstream |key3File|))))
(and |stream| (closef? |stream|))
(setq |stream| (car (nlsetq (openstream |key3File| 'output 'old/new))))
|thereis| (streamp |stream|)
|finally| (|if| (and (streamp |stream|)
(openp |stream|))
|then| (|printout| |stream| "// "
"This will set you back in your last used partition, "
firstname t "// [last used " (date)
"]" t "Par " (diskpartition)
t)
(closef |stream|))))
nil)))
(|RememberLispState|
(lambda nil (* \; "Edited 15-Jan-88 09:21 by smL")
(* |;;;| "Make KEY2.CM restart this lisp if the logout was not FAST...")
(nlsetq (|if| (and (stkpos 'logout)
(eq (machinetype)
'dorado))
|then| (|if| (nlsetq (getstream '{dsk}key2.cm\;1))
|then| (closef? (getstream '{dsk}key2.cm\;1)))
(resetlst (let ((logout-arg (stkarg 1 'logout))
(stream (openstream '{dsk}key2.cm\;1 'output 'old/new)))
(resetsave nil (list (function closef?)
stream))
(|printout| stream "// You did a (LOGOUT")
(selectq logout-arg
(nil nil)
(|printout| stream " " logout-arg))
(|printout| stream ") last time [" (date)
"], so this will ")
(selectq logout-arg
((nil ?)
(|printout| stream "restart your old"))
(|printout| stream "start a new"))
(|printout| stream " LISP, " firstname t)
(selectq logout-arg
((nil ?)
(|printout| stream "Lisp")
(|if| (eqp (realmemorysize)
21845)
|then| (|printout| stream " 52525/c")))
(|printout| stream "@KEY1.CM"))
(|printout| stream t)))))))
)
(declare\: donteval@load donteval@compile
(addtovar beforelogoutforms (|RememberLispState|) (|RememberLastPartition|))
)
(rpaqq wizard-init-commands ((* |;;;| "Some tools for wizards, or people who occasionally think they are.") (* |;;| "Find out what other symbols were interned at about the same time as a given symbol. Useful to find out what file defined a symbol.") (functions atom-neighbors)))
(* |;;;| "Some tools for wizards, or people who occasionally think they are.")
(* |;;|
"Find out what other symbols were interned at about the same time as a given symbol. Useful to find out what file defined a symbol."
)
(cl:defun atom-neighbors (cl:symbol &optional (xcl-user::number-of-neighbors 8)) (cl:if (cl:symbolp cl:symbol) (let ((xcl-user::atom-number (\\loloc cl:symbol)) (xcl-user::neighbors (list cl:symbol))) (cl:dotimes (xcl-user::i xcl-user::number-of-neighbors) (cl:push (\\vag2 0 (+ xcl-user::atom-number 1 xcl-user::i)) xcl-user::neighbors)) (cl:setf xcl-user::neighbors (cl:nreverse xcl-user::neighbors)) (cl:dotimes (xcl-user::i xcl-user::number-of-neighbors) (cl:push (\\vag2 0 (- xcl-user::atom-number 1 xcl-user::i)) xcl-user::neighbors)) xcl-user::neighbors) "Not a symbol"))
(rpaqq dinfo-init-commands ((* |;;| "Set up the on-line documentation") (declare\: donteval@load donteval@compile (vars (irm.host&dir (cond ((infilep "{DSK}<LISPFILES>HELPSYS>IRMTOP.TEDIT") "{DSK}<LISPFILES>HELPSYS>") ((and (boundp (quote irm.host&dir)) irm.host&dir) irm.host&dir) (t "{Pallas:AISNorth:XEROX}<Lisp>Lyric>LispUsers>IRM>"))) (dinfomodes (quote (graph)))) (initvars (irm.font (fontcreate (quote (helvetica 10)))) (irmwindowregion (let ((width (widthifwindow (cl:* 60 (stringwidth "w" irm.font))))) (createregion (- screenwidth width 5) 5 width (quotient screenheight 2))))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "DInfo" "Helpsys") (dinfo (irm.get.dinfograph t) irmwindowregion)) (((sysload from lispusers) "LispNerd"))))))
(* |;;| "Set up the on-line documentation")
(declare\: donteval@load donteval@compile
(rpaq irm.host&dir (cond ((infilep "{DSK}<LISPFILES>HELPSYS>IRMTOP.TEDIT") "{DSK}<LISPFILES>HELPSYS>") ((and (boundp (quote irm.host&dir)) irm.host&dir) irm.host&dir) (t "{Pallas:AISNorth:XEROX}<Lisp>Lyric>LispUsers>IRM>")))
(rpaqq dinfomodes (graph))
(rpaq? irm.font (fontcreate (quote (helvetica 10))))
(rpaq? irmwindowregion (let ((width (widthifwindow (cl:* 60 (stringwidth "w" irm.font))))) (createregion (- screenwidth width 5) 5 width (quotient screenheight 2))))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "DInfo" "Helpsys")) (quote (dinfo (irm.get.dinfograph t) irmwindowregion)))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "LispNerd")))
)
(rpaqq pcl-init-commands ((* |;;| "PCL fun and games") (initvars (pcldirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<PCL>LYRIC>" "{PHYLUM}<PCL>LYRIC>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{pooh/n}<pooh>pcl>medley>" "{NB:PARC:XEROX}<PCL>MEDLEY>" "{PHYLUM}<PCL>MEDLEY>")))))) (declare\: donteval@load donteval@compile (p (eval-at-greet (cl:unless (cl:find-package "PCL") (|AddLoadMenuItem| "Subsystems" (quote ((from pcl) "Load-PCL")) (quote (cl:when (eq makesysname :lyric) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((from pcl) "Clos-Browser"))))))))))))
(* |;;| "PCL fun and games")
(rpaq? pcldirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<PCL>LYRIC>" "{PHYLUM}<PCL>LYRIC>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{pooh/n}<pooh>pcl>medley>" "{NB:PARC:XEROX}<PCL>MEDLEY>" "{PHYLUM}<PCL>MEDLEY>")))))
(declare\: donteval@load donteval@compile
(eval-at-greet (cl:unless (cl:find-package "PCL") (|AddLoadMenuItem| "Subsystems" (quote ((from pcl) "Load-PCL")) (quote (cl:when (eq makesysname :lyric) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((from pcl) "Clos-Browser"))))))))
)
(rpaqq loops-init-commands ((* |;;;| "Loops initialization") (initvars (loopsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Loops>Lyric>Sources>" "{PHYLUM}<Loops>Lyric>Sources>" "{POGO:AISNorth:XEROX}<LOOPSCORE>SYSTEM>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Loops>Medley>Sources>" "{PHYLUM}<Loops>Medley>Sources>" "{POGO:AISNorth:XEROX}<LOOPSCORE>SYSTEM>"))))) (\\loops-init-form (quote (progn (filesload (from "{EG:PARC:XEROX}<Lanning>Loops>") initloops))))) (declare\: donteval@load donteval@compile (p (eval-at-greet (cond ((cl:member "LOOPS" *features* :test (cl:function string-equal)) (eval \\loops-init-form)) (t (|AddLoadMenuItem| "Subsystems" (quote ((from loops) "Loops")) \\loops-init-form))))))))
(* |;;;| "Loops initialization")
(rpaq? loopsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Loops>Lyric>Sources>" "{PHYLUM}<Loops>Lyric>Sources>" "{POGO:AISNorth:XEROX}<LOOPSCORE>SYSTEM>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Loops>Medley>Sources>" "{PHYLUM}<Loops>Medley>Sources>" "{POGO:AISNorth:XEROX}<LOOPSCORE>SYSTEM>")))))
(rpaq? \\loops-init-form (quote (progn (filesload (from "{EG:PARC:XEROX}<Lanning>Loops>") initloops))))
(declare\: donteval@load donteval@compile
(eval-at-greet (cond ((cl:member "LOOPS" *features* :test (cl:function string-equal)) (eval \\loops-init-form)) (t (|AddLoadMenuItem| "Subsystems" (quote ((from loops) "Loops")) \\loops-init-form))))
)
(* |;;| "Documentation")
(rpaqq tedit-init-commands ((* |;;;| "TEDIT stuff") (functions load-nova-fonts) (declare\: donteval@load donteval@compile (vars (tedit.default.window (createw (let ((width (widthifwindow (times 80 (tedit.stringwidth "A")))) (height (heightifwindow (times 35 (fontprop defaultfont (quote height))) t))) (createregion (min 475 (- screenwidth (+ width 10))) (max 85 (- screenheight height 100)) width height)) "TEDIT window" nil t)) (* \; "Set up default tabs to be 8 spaces, so we can edit code files.") (tedit.default.props (bquote ((\\\,@ tedit.default.props) paralooks (tabs ((\\\, (times 8 (tedit.stringwidth "A"))))))))) (p (eval-at-greet (cl:when (getd (quote tedit)) (* |;;| "Make the ESC key REDO the previous TEdit operation") (undosave (bquote (tedit.setsyntax (\\\, (charcode esc)) (\\\, (tedit.getsyntax (charcode esc)))))) (tedit.setsyntax (charcode esc) (quote redo)) (* |;;| "Make TEdit close files when shrunk") (filesload (sysload from lispusers) tedit-close-on-shrink)))) (loadmenuitems "WritingAids" (((sysload from lispusers) "ProofReader")) (((sysload from lispusers) "TMAX")) (((sysload from lispusers) "DictTool")) (((sysload from lispusers) "TEditDoradoKeys")) (((sysload from lispusers) "EditKeys")) (((sysload from lispusers) "VirtualKeyboards") (let ((keyboard-file (findfile "Code.Keyboard" t private-lispusersdirectories))) (cl:when keyboard-file (vkbd.load-keyboard-file keyboard-file)))) (((sysload from lispusers) "KeyboardEditor")) (((sysload from lispusers) "Equations" "Sketch")) (((sysload from lispusers) "NovaFont") (load-nova-fonts))) (coms (initvars (docobjectsmenufont menufont)) (alists (imageobjgetfns docobj-filestamp-getfn docobj-timestamp-getfn docobj-include-getfn)) (loadmenuitems "WritingAids" (((sysload from lispusers) "Doc-Objects")))))))
(* |;;;| "TEDIT stuff")
(cl:defun load-nova-fonts nil (let ((nova-font-host "Starfile Public:Parc:Xerox") (nova-fonts-to-load (quote ("<VP Applications>VP Optima XSG Fonts>OptimaItalic" "<VP Applications>VP Optima XSG Fonts>OptimaMedium"))) (nova-fonts-to-notice (quote ("<VP Applications>Xerox Logo Fonts>XeroxLogo" "<VP Applications>Xerox VP Quartz Fonts!2>QuartzBIR" "<VP Applications>Xerox VP Quartz Fonts!2>QuartzBRR" "<VP Applications>Xerox VP Quartz Fonts!2>QuartzMIR" "<VP Applications>Xerox VP Quartz Fonts!2>QuartzMRR")))) (cl:flet ((find-nova-font (font) "Find the Novafont file" (cl:probe-file (cl:make-pathname :host nova-font-host :type "NovaFont" :defaults font)))) (cl:mapc (cl:function (cl:lambda (font) (let ((font-file (find-nova-font font))) (cl:when font-file (cl:format (getstream promptwindow (quote output)) "~%Loading Novafont ~A" (cl:pathname-name font-file)) (load-novafont-file font-file) (notice-novafont-file font-file))))) nova-fonts-to-load) (cl:mapc (cl:function (cl:lambda (font) (let ((font-file (find-nova-font font))) (cl:when font-file (cl:format (getstream promptwindow (quote output)) "~%Noticing Novafont ~A" (cl:pathname-name font-file)) (notice-novafont-file font-file))))) nova-fonts-to-notice))) (cl:mapc (cl:function (cl:lambda (item) (cl:pushnew item tedit.known.fonts :test (quote cl:equal)))) (quote (("XeroxLogo" (quote xeroxlogo)) ("Quartz" (quote quartz)) ("Optima" (quote optima))))))
(declare\: donteval@load donteval@compile
(rpaq tedit.default.window (createw (let ((width (widthifwindow (times 80 (tedit.stringwidth "A")))) (height (heightifwindow (times 35 (fontprop defaultfont (quote height))) t))) (createregion (min 475 (- screenwidth (+ width 10))) (max 85 (- screenheight height 100)) width height)) "TEDIT window" nil t))
(rpaq tedit.default.props (bquote ((\\\,@ tedit.default.props) paralooks (tabs ((\\\, (times 8 (tedit.stringwidth "A"))))))))
(eval-at-greet (cl:when (getd (quote tedit)) (* |;;| "Make the ESC key REDO the previous TEdit operation") (undosave (bquote (tedit.setsyntax (\\\, (charcode esc)) (\\\, (tedit.getsyntax (charcode esc)))))) (tedit.setsyntax (charcode esc) (quote redo)) (* |;;| "Make TEdit close files when shrunk") (filesload (sysload from lispusers) tedit-close-on-shrink)))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "ProofReader")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "TMAX")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "DictTool")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "TEditDoradoKeys")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "EditKeys")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "VirtualKeyboards")) (quote (let ((keyboard-file (findfile "Code.Keyboard" t private-lispusersdirectories))) (cl:when keyboard-file (vkbd.load-keyboard-file keyboard-file)))))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "KeyboardEditor")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Equations" "Sketch")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "NovaFont")) (quote (load-nova-fonts)))
(rpaq? docobjectsmenufont menufont)
(addtovar imageobjgetfns (docobj-filestamp-getfn file doc-objects) (docobj-timestamp-getfn file doc-objects) (docobj-include-getfn file doc-objects))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Doc-Objects")))
)
(rpaqq sketch-init-commands ((* |;;;| "SKETCH Stuff") (alists (imageobjgetfns skio.getfn skio.getfn.2)) (declare\: donteval@load donteval@compile (loadmenuitems "WritingAids" (((sysload from lispusers) "Sketch"))))))
(* |;;;| "SKETCH Stuff")
(addtovar imageobjgetfns (skio.getfn) (skio.getfn.2 file sketch))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Sketch")))
)
(rpaqq notecards-init-commands ((* |;;;| "NOTECARDS stuff") (initvars (|NC.NoteCardsIconPosition| (createposition 891 2)) (ncinitialglobalparams (quote (|ForceFiling| nil |MarkersInFileBoxes| nil |UseDeletedLinkIconIndicators| nil))) (notecardsdirectories (bquote ((\\\,@ *cache-directories*) "{QV}<NoteCards>1.3L>" "{NB:PARC:XEROX}<NoteCards>1.3L>")))) (declare\: donteval@load donteval@compile (loadmenuitems "WritingAids" (((sysload from notecards) "NoteCards") (|NoteCards| |NC.NoteCardsIconPosition|))))))
(* |;;;| "NOTECARDS stuff")
(rpaq? |NC.NoteCardsIconPosition| (createposition 891 2))
(rpaq? ncinitialglobalparams (quote (|ForceFiling| nil |MarkersInFileBoxes| nil |UseDeletedLinkIconIndicators| nil)))
(rpaq? notecardsdirectories (bquote ((\\\,@ *cache-directories*) "{QV}<NoteCards>1.3L>" "{NB:PARC:XEROX}<NoteCards>1.3L>")))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from notecards) "NoteCards")) (quote (|NoteCards| |NC.NoteCardsIconPosition|)))
)
(* |;;| "Communication & Info")
(rpaqq mail-init-commands ((* |;;;| "LAFITE stuff") (declare\: donteval@load donteval@compile (* |;;| "These have to be VARS instead of INITVARS since they come set to default values in the FULL sysout.") (vars (*new-lafite-p* (not (cl:fboundp (quote \\lafite.getmailfolder)))) (defaultmailfoldername (quote active.mail)) (lafitedefaulthost&dir (pack* |\\UserHomeDirectory| "MAIL>")) (lafitehardcopybatchflg t) (lafitemovetoconfirmflg (quote left)) (lafiteshowmodeflg (quote always)) (lafitebrowserregion (createregion 360 5 650 165)) (lafitedisplayregion (|with| region (windowprop |\\TopLevelTtyWindow| (quote region)) (createregion (max left scrollbarwidth) 175 (widthifwindow (min (quotient (times 2 screenwidth) 3) (times 85 (stringwidth "W" lafitedisplayfont)))) (difference bottom 175)))) (lafitestatuswindowposition (createposition 100 45)) (lafitemodedefault (or lafitemodedefault (quote gv)))) (* |;;| "In latest Lafite. Of course, it doesn't hurt to set them even if they aren't used.") (vars (lafite.dont.display.headers (quote ("Return-Path" "Redistributed" "Received" "Message-Id" "Comments" "Zippy-Says" "X-Mailer" "Organization" "References"))) (lafite.dont.forward.headers lafite.dont.display.headers) (lafite.dont.hardcopy.headers lafite.dont.display.headers)) (* |;;| "There are lots of optional mail utilities") (loadmenuitems "MailTools" (((sysload from lispusers) "LafiteTimedDelete")) (((sysload from lispusers) "LafiteFind")) (((sysload from lispusers) "Maintain")) (((sysload from lispusers) "NSMaintain")) (((sysload from lispusers) "MailScavenge")) (((sysload from lispusers) "Undigestify")) (((from lispusers) "Lafite-Indent")) (((sysload from lispusers) "MailShare")) (((sysload from "{QV}<Briggs>Lisp>") "LafiteFolderIcon")) (((sysload from "{ERIS}<Lafite>Sources>") "AppendMail"))) (p (eval-at-greet (cl:unless (not *new-lafite-p*) (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafiteHighlight"))) (|AddLoadMenuItem| "MailTools" (quote ((sysload from "{PHYLUM}<Bobrow>Lisp>") "Short-Lafite-Header"))))))) (* |;;| "") (* |;;| "Additional text at the start and end of a msg") (declare\: donteval@load donteval@compile (p (eval-at-greet (if *new-lafite-p* then (* |;;| "New Lafite running, set the appropriate vars.") (rpaq lafite.signature (or lafite.signature (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol))))) (rpaq lafite.gv.from.field (or lafite.gv.from.field (concat (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">"))) else (* |;;| "Use the hack I wrote") (rpaq? lafitemsgtagstring (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol)))) (rpaq? lafitemsgheaderstring (concat "From: " (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">" (character (charcode eol)))) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "Tailor-Lafite-Msg"))))) (* |;;| "Private DL support") (initvars (lafitedldirectories nil)) (declare\: donteval@load donteval@compile (p (eval-at-greet (cl:unless *new-lafite-p* (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafitePrivateDL"))))))) (* |;;| "Patches to Lafite to put the MOVE-TO folder first in the title.") (p (eval-at-greet (cl:when (and (cl:fboundp (quote lafite)) (not *new-lafite-p*)) (filesload (sysload noerror from "{Phylum}<Bobrow>Lisp>") "LafiteTitlePatch") (changename (quote la.opentempfile) (quote dsk) (quote scratch)) (lafitemode (quote gv))))) (coms (* |;;;| "COMMON-LENS stuff") (initvars (\\use-lens? nil) (user::*lens-user-parameters* (bquote ((:default-host-and-dir lafitedefaulthost&dir) (:icon-pos (createposition 98 8)) (:mailweb-pos (createposition 194 7)) (:mailweb-icon-pos (createposition 194 7)) (:mailweb-font (fontcreate (quote (helvetica 8)))) (:feedback-p nil) (:filing-rule "Filing Rules") (:room-name (quote ("Mail"))))))) (vars (user::lens-loader-dir "{NB:PARC:Xerox}<CommonLens>Current>")) (p (eval-at-greet (cond ((cl:member "Common-Lens" *modules* :test (cl:function string-equal)) (* \; "Common-Lens already loaded") (cl:funcall (cl:intern "LOAD-LENS-PATCHES" "CLENS"))) ((and \\use-lens? (not (null (cl:find-package "PCL")))) (* \; "Want to use Common-Lens, so load it now") (cl:load (cl:make-pathname :name "LOAD-CLENS" :defaults user::lens-loader-dir))) (t (* \; "Give the user the option of using it later") (|AddLoadMenuItem| "MailTools" (quote ((from valueof user::lens-loader-dir) "LOAD-CLENS")) (quote (ignore-errors (lafite (quote off)) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on))))))))) (* |;;| "Turn on mailer (no, no, not Norman -- but he is easy to turn on. Or so I've heard.)") (initvars (\\turn-on-mailer (equal (etherhostnumber home-machine-name) (etherhostnumber)))) (p (eval-at-greet (cond ((not (getd (quote lafite))) (* \; "Don't turn on mail if it doesn't exist") nil) ((not \\turn-on-mailer) (* \; "Don't turn on if the user doesn't want to") nil) ((and \\use-lens? (not (null (cl:find-package "CLENS")))) (* \; "Use COMMON-LENS if it's here and the user wants it") (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)) (t (* \; "Use Lafite") (lafite (quote on))))))))
(* |;;;| "LAFITE stuff")
(declare\: donteval@load donteval@compile
(rpaq *new-lafite-p* (not (cl:fboundp (quote \\lafite.getmailfolder))))
(rpaqq defaultmailfoldername active.mail)
(rpaq lafitedefaulthost&dir (pack* |\\UserHomeDirectory| "MAIL>"))
(rpaqq lafitehardcopybatchflg t)
(rpaqq lafitemovetoconfirmflg left)
(rpaqq lafiteshowmodeflg always)
(rpaq lafitebrowserregion (createregion 360 5 650 165))
(rpaq lafitedisplayregion (|with| region (windowprop |\\TopLevelTtyWindow| (quote region)) (createregion (max left scrollbarwidth) 175 (widthifwindow (min (quotient (times 2 screenwidth) 3) (times 85 (stringwidth "W" lafitedisplayfont)))) (difference bottom 175))))
(rpaq lafitestatuswindowposition (createposition 100 45))
(rpaq lafitemodedefault (or lafitemodedefault (quote gv)))
(rpaqq lafite.dont.display.headers ("Return-Path" "Redistributed" "Received" "Message-Id" "Comments" "Zippy-Says" "X-Mailer" "Organization" "References"))
(rpaq lafite.dont.forward.headers lafite.dont.display.headers)
(rpaq lafite.dont.hardcopy.headers lafite.dont.display.headers)
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "LafiteTimedDelete")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "LafiteFind")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "Maintain")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "NSMaintain")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "MailScavenge")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "Undigestify")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((from lispusers) "Lafite-Indent")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "MailShare")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from "{QV}<Briggs>Lisp>") "LafiteFolderIcon")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from "{ERIS}<Lafite>Sources>") "AppendMail")))
(eval-at-greet (cl:unless (not *new-lafite-p*) (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafiteHighlight"))) (|AddLoadMenuItem| "MailTools" (quote ((sysload from "{PHYLUM}<Bobrow>Lisp>") "Short-Lafite-Header")))))
)
(* |;;| "")
(* |;;| "Additional text at the start and end of a msg")
(declare\: donteval@load donteval@compile
(eval-at-greet (if *new-lafite-p* then (* |;;| "New Lafite running, set the appropriate vars.") (rpaq lafite.signature (or lafite.signature (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol))))) (rpaq lafite.gv.from.field (or lafite.gv.from.field (concat (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">"))) else (* |;;| "Use the hack I wrote") (rpaq? lafitemsgtagstring (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol)))) (rpaq? lafitemsgheaderstring (concat "From: " (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">" (character (charcode eol)))) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "Tailor-Lafite-Msg")))
)
(* |;;| "Private DL support")
(rpaq? lafitedldirectories nil)
(declare\: donteval@load donteval@compile
(eval-at-greet (cl:unless *new-lafite-p* (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafitePrivateDL")))))
)
(* |;;| "Patches to Lafite to put the MOVE-TO folder first in the title.")
(eval-at-greet (cl:when (and (cl:fboundp (quote lafite)) (not *new-lafite-p*)) (filesload (sysload noerror from "{Phylum}<Bobrow>Lisp>") "LafiteTitlePatch") (changename (quote la.opentempfile) (quote dsk) (quote scratch)) (lafitemode (quote gv))))
(* |;;;| "COMMON-LENS stuff")
(rpaq? \\use-lens? nil)
(rpaq? user::*lens-user-parameters* (bquote ((:default-host-and-dir lafitedefaulthost&dir) (:icon-pos (createposition 98 8)) (:mailweb-pos (createposition 194 7)) (:mailweb-icon-pos (createposition 194 7)) (:mailweb-font (fontcreate (quote (helvetica 8)))) (:feedback-p nil) (:filing-rule "Filing Rules") (:room-name (quote ("Mail"))))))
(rpaq user::lens-loader-dir "{NB:PARC:Xerox}<CommonLens>Current>")
(eval-at-greet (cond ((cl:member "Common-Lens" *modules* :test (cl:function string-equal)) (* \; "Common-Lens already loaded") (cl:funcall (cl:intern "LOAD-LENS-PATCHES" "CLENS"))) ((and \\use-lens? (not (null (cl:find-package "PCL")))) (* \; "Want to use Common-Lens, so load it now") (cl:load (cl:make-pathname :name "LOAD-CLENS" :defaults user::lens-loader-dir))) (t (* \; "Give the user the option of using it later") (|AddLoadMenuItem| "MailTools" (quote ((from valueof user::lens-loader-dir) "LOAD-CLENS")) (quote (ignore-errors (lafite (quote off)) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)))))))
(* |;;| "Turn on mailer (no, no, not Norman -- but he is easy to turn on. Or so I've heard.)")
(rpaq? \\turn-on-mailer (equal (etherhostnumber home-machine-name) (etherhostnumber)))
(eval-at-greet (cond ((not (getd (quote lafite))) (* \; "Don't turn on mail if it doesn't exist") nil) ((not \\turn-on-mailer) (* \; "Don't turn on if the user doesn't want to") nil) ((and \\use-lens? (not (null (cl:find-package "CLENS")))) (* \; "Use COMMON-LENS if it's here and the user wants it") (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)) (t (* \; "Use Lafite") (lafite (quote on)))))
(rpaqq chat-init-commands ((* |;;;| "CHAT stuff") (declare\: donteval@load donteval@compile (alists (networkloginfo lily symbolics)) (vars (chat.allhosts (sort (bquote (|IBID:PARC:XEROX| |PARC CHS:PARC:XEROX| erinyes eris phylum qv (\\\,@ (|for| host |in| defaultprintinghost |when| (eq (printertype host) (quote interpress)) |collect| host)))))) (closechatwindowflg t) (chat.window.size (let ((n-chars-wide 80) (n-chars-high 24)) (cons (min (quotient (times screenwidth 2) 3) (widthifwindow (times n-chars-wide (stringwidth "A" chat.font)))) (min (quotient (times screenheight 2) 3) (heightifwindow (times n-chars-high (fontprop chat.font (quote height))) t))))) (defaultchathost (filenamefield loginhost/dir (quote host)))) (loadmenuitems nil (((sysload from lispusers) "TCPChat"))))))
(* |;;;| "CHAT stuff")
(declare\: donteval@load donteval@compile
(addtovar networkloginfo (lily (login "l" username cr password cr)) (symbolics (login)))
(rpaq chat.allhosts (sort (bquote (|IBID:PARC:XEROX| |PARC CHS:PARC:XEROX| erinyes eris phylum qv (\\\,@ (|for| host |in| defaultprintinghost |when| (eq (printertype host) (quote interpress)) |collect| host))))))
(rpaqq closechatwindowflg t)
(rpaq chat.window.size (let ((n-chars-wide 80) (n-chars-high 24)) (cons (min (quotient (times screenwidth 2) 3) (widthifwindow (times n-chars-wide (stringwidth "A" chat.font)))) (min (quotient (times screenheight 2) 3) (heightifwindow (times n-chars-high (fontprop chat.font (quote height))) t)))))
(rpaq defaultchathost (filenamefield loginhost/dir (quote host)))
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "TCPChat")))
)
(rpaqq talk-init-commands ((* |;;| "Talk program initialization commands") (initvars (talk.default.region (createregion 575 0 500 500))) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "Talk")))) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload compiled noerror from "{PHYLUM}<Wickberg>Lisp>") fing) (fingw))))))
(* |;;| "Talk program initialization commands")
(rpaq? talk.default.region (createregion 575 0 500 500))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Talk")))
)
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote nil) (quote ((sysload compiled noerror from "{PHYLUM}<Wickberg>Lisp>") fing)) (quote (fingw)))
)
(rpaqq calendar-init-commands ((* |;;;| "Calendar") (initvars (caldaydefaultregion (createregion 32 200 375 100)) (caldefaultalertdelta -10) (caldefaulthost&dir (concat |\\UserHomeDirectory| "CALENDAR>")) (calfont (fontcreate (quote (helvetica 18)))) (calupdateonshrinkflg t) (calkeepexpiredrems t)) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "Calendar") (progn (calloadfile "CalReminders") (let ((file (findfile "Calmanac88" t lispusersdirectories))) (cl:when file (calloadfile file))) (calendar (quote thisyear))))))))
(* |;;;| "Calendar")
(rpaq? caldaydefaultregion (createregion 32 200 375 100))
(rpaq? caldefaultalertdelta -10)
(rpaq? caldefaulthost&dir (concat |\\UserHomeDirectory| "CALENDAR>"))
(rpaq? calfont (fontcreate (quote (helvetica 18))))
(rpaq? calupdateonshrinkflg t)
(rpaq? calkeepexpiredrems t)
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Calendar")) (quote (progn (calloadfile "CalReminders") (let ((file (findfile "Calmanac88" t lispusersdirectories))) (cl:when file (calloadfile file))) (calendar (quote thisyear)))))
)
(rpaqq printer-init-commands ((* |;;| "Printer menu") (initvars (printermenu.position (createposition (difference screenwidth 125) 5))) (loadmenuitems nil (((sysload from lispusers) "PrinterMenu") (printermenu))) (* |;;| "Hardcopying graphs") (loadmenuitems nil (((sysload from lispusers) "HGraph")))))
(* |;;| "Printer menu")
(rpaq? printermenu.position (createposition (difference screenwidth 125) 5))
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "PrinterMenu")) (quote (printermenu)))
(* |;;| "Hardcopying graphs")
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "HGraph")))
(rpaqq db-init-commands ((* |;;| "Information gathering database stuff") (initvars (|*Address-Book-Pos*| (createposition 19 181)) (|*Phone-Directory-Pos*| (createposition 19 181))) (addvars (phonelistfiles "{PHYLUM}<KSA>ROLODEX.TEDIT")) (loadmenuitems nil (((from lispusers) "Phone-Directory")) (((from lispusers) "AddressBook"))) (* |;;| "Bibliographic lookup") (loadmenuitems "WritingAids" (((from lispusers) "Find-Citation")))))
(* |;;| "Information gathering database stuff")
(rpaq? |*Address-Book-Pos*| (createposition 19 181))
(rpaq? |*Phone-Directory-Pos*| (createposition 19 181))
(addtovar phonelistfiles "{PHYLUM}<KSA>ROLODEX.TEDIT")
(|AddLoadMenuItem| (quote nil) (quote ((from lispusers) "Phone-Directory")))
(|AddLoadMenuItem| (quote nil) (quote ((from lispusers) "AddressBook")))
(* |;;| "Bibliographic lookup")
(|AddLoadMenuItem| (quote "WritingAids") (quote ((from lispusers) "Find-Citation")))
(rpaqq nfs-init-commands ((* |;;| "Add NFS support") (loadmenuitems "FileAids" (((sysload from "{NB:PARC:XEROX}<NFS>") "PARC-NFS")))))
(* |;;| "Add NFS support")
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from "{NB:PARC:XEROX}<NFS>") "PARC-NFS")))
(* |;;| "Files")
(rpaqq file-watch-init-commands ((* |;;;| "FileWatcher") (declare\: donteval@load donteval@compile (initvars (|FW-Properties| (bquote (font (gacha 8) all-files? nil position (\\\, (createposition screenwidth (cl:if (and (boundp (quote *who-line*)) (windowp *who-line*)) (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) screenheight))) anchor top-right shade (\\\, grayshade) interval 1000 filters ({dsk1}sysdir {core}<*>rolodex.* {core}<*>*phone*.txt))))) (loadmenuitems "FileAids" (((sysload from lispusers) "FileWatch") (filewatch))))))
(* |;;;| "FileWatcher")
(declare\: donteval@load donteval@compile
(rpaq? |FW-Properties| (bquote (font (gacha 8) all-files? nil position (\\\, (createposition screenwidth (cl:if (and (boundp (quote *who-line*)) (windowp *who-line*)) (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) screenheight))) anchor top-right shade (\\\, grayshade) interval 1000 filters ({dsk1}sysdir {core}<*>rolodex.* {core}<*>*phone*.txt))))
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "FileWatch")) (quote (filewatch)))
)
(rpaqq file-server-init-commands ((loadmenuitems "FileAids" (((sysload from lispusers) "NSProtection") (nsprotection))) (* |;;| "The ArchiveTool") (loadmenuitems "FileAids" (((sysload from lispusers) "ArchiveTool")) (((sysload from lispusers) "ArchiveBrowser")) (((sysload from lispusers) "NSAllocation")))))
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "NSProtection")) (quote (nsprotection)))
(* |;;| "The ArchiveTool")
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "ArchiveTool")))
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "ArchiveBrowser")))
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "NSAllocation")))
(rpaqq dirgrapher-init-commands ((* |;;| "DirGrapher") (initvars (dg.file-info-attributes fb.default.info) (dg.default-dir |\\UserHomeDirectory|) (dg.vertical-horizontal-option (quote horizontal)) (dg.background-directories (bquote ((\\\, dg.default-dir) "{NB:PARC:XEROX}<Colab>" "{Phylum}<KSA>" "{Pogo:AISNorth:XEROX}<Loops>")))) (declare\: donteval@load donteval@compile (loadmenuitems "FileAids" (((sysload from lispusers) "DirGrapher"))))))
(* |;;| "DirGrapher")
(rpaq? dg.file-info-attributes fb.default.info)
(rpaq? dg.default-dir |\\UserHomeDirectory|)
(rpaq? dg.vertical-horizontal-option (quote horizontal))
(rpaq? dg.background-directories (bquote ((\\\, dg.default-dir) "{NB:PARC:XEROX}<Colab>" "{Phylum}<KSA>" "{Pogo:AISNorth:XEROX}<Loops>")))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "DirGrapher")))
)
(rpaqq fb-init-commands ((* |;;| "FileBrowser tailoring") (declare\: donteval@load donteval@compile (vars (fb.default.info (quote (size creationdate)))) (loadmenuitems "FileAids" (((sysload from lispusers) "Resize-FileBrowser"))))))
(* |;;| "FileBrowser tailoring")
(declare\: donteval@load donteval@compile
(rpaqq fb.default.info (size creationdate))
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "Resize-FileBrowser")))
)
(rpaqq compare-files-init-commands ((* |;;| "Comparing files and the like") (loadmenuitems "FileAids" (((sysload from lispusers) "CompareDirectories")) (((sysload from lispusers) "CompareText")) (((sysload from lispusers) "CompareSources")))))
(* |;;| "Comparing files and the like")
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareDirectories")))
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareText")))
(|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareSources")))
(* |;;| "Random stuff")
(rpaqq unix-init-commands ((* |;;| "Some of UNIXish commands") (variables *unix-dir-stack*) (functions do-cd print-directory-stack) (commands "CD" "DIRS" "LS" "MORE" "POPD" "PUSHD" "PWD")))
(* |;;| "Some of UNIXish commands")
(defglobalvar *unix-dir-stack* nil "The directory stack used in the exec commands PUSHD and friends.")
(cl:defun do-cd (directory) (if (string-equal directory "..") then (let* ((current (directoryname t)) (parent (substring current 1 (strpos ">" current -2 nil nil nil nil t)))) (cndir parent)) else (cndir directory)) (directoryname t))
(cl:defun print-directory-stack nil (cl:format t "~%~A" (directoryname t)) (for dir in *unix-dir-stack* do (cl:format t " ~A" dir)) (cl:values))
(defcommand "CD" (&optional directory) "Connect to a directory" (do-cd directory) (setq *unix-dir-stack* nil) (cl:format t "~%~A" (directoryname t)) (cl:values))
(defcommand "DIRS" nil "Print out the directory stack used by PUSHD and friends." (print-directory-stack) (cl:values))
(defcommand "LS" (&optional (dirspec "*")) "List files matching the spec" (let ((filing.enumeration.depth 1)) (directory dirspec (quote (p)))) (cl:values))
(defcommand "MORE" (file) "Type the contents of a file" (cl:funcall (cl:function see) file) (cl:values))
(defcommand "POPD" (directory) "Connect to the previous directory" (if (null *unix-dir-stack*) then (cl:format t "~%popd: Directory stack empty.") else (do-cd (pop *unix-dir-stack*)) (print-directory-stack)) (cl:values))
(defcommand "PUSHD" (directory) "Connect to a directory, remember the current one on the directory stack." (cl:push (directoryname t) *unix-dir-stack*) (do-cd directory) (print-directory-stack) (cl:values))
(defcommand "PWD" nil "Print out the currently connected directory." (cl:format t "~%~A" (directoryname t)) (cl:values))
(rpaqq demos-init-commands ((* |;;;| "Giveing demos and the like") (initvars (|SlideFiles| (quote ("{PHYLUM}<KSA>Talks>*.Tedit;")))) (declare\: donteval@load donteval@compile (loadmenuitems "Demos" (((sysload from lispusers) "SlideProjector")) (((sysload from lispusers) "Magnifier")) (((sysload from lispusers) "Big")) (((load from "{PHYLUM}<KSA>") "Demo"))))))
(* |;;;| "Giveing demos and the like")
(rpaq? |SlideFiles| (quote ("{PHYLUM}<KSA>Talks>*.Tedit;")))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "SlideProjector")))
(|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "Magnifier")))
(|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "Big")))
(|AddLoadMenuItem| (quote "Demos") (quote ((load from "{PHYLUM}<KSA>") "Demo")))
)
(rpaqq games-init-commands ((* |;;;| "R and R") (declare\: donteval@load donteval@compile (loadmenuitems "Games" (((from "{PHYLUM}<Bobrow>Lisp>") "BlackBox")) (((from "{FS8:PARC:XEROX}<Foster>Lisp>") "Go")) (((sysload from lispusers) "Qix") (add.process (quote (qix.grow)))) (((sysload from lispusers) "FaceInvader")) (((sysload from lispusers) "Donz")) (((sysload from lispusers) "Doctor")) (((sysload from lispusers) "Hanoi")) (((sysload from lispusers) "Life")) (((sysload from lispusers) "Solitare")) (((sysload from "{FS8:PARC:XEROX}<Foster>Lisp>") "RandomWord"))))))
(* |;;;| "R and R")
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "Games") (quote ((from "{PHYLUM}<Bobrow>Lisp>") "BlackBox")))
(|AddLoadMenuItem| (quote "Games") (quote ((from "{FS8:PARC:XEROX}<Foster>Lisp>") "Go")))
(|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Qix")) (quote (add.process (quote (qix.grow)))))
(|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "FaceInvader")))
(|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Donz")))
(|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Doctor")))
(|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Hanoi")))
(|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Life")))
(|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Solitare")))
(|AddLoadMenuItem| (quote "Games") (quote ((sysload from "{FS8:PARC:XEROX}<Foster>Lisp>") "RandomWord")))
)
(* |;;| "Cleanup")
(rpaqq background-menu-cleanup-init-commands ((* |;;;| "Clean up the background menu") (functions move-background-item-under) (declare\: donteval@load donteval@compile (p (eval-at-greet (* |;;| "Put the HARDCOPY item under the SNAP command") (move-background-item-under "Hardcopy" "Snap") (* |;;| "Put the ArchiveTool under the FileBrowser") (move-background-item-under "ArchiveTool" "FileBrowser") (* |;;| "Add a menu item for loging out") (/nconc1 |BackgroundMenuCommands| (quote ("LOGOUT & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT)?") (|GoodNight|))) "Logout of LISP" (subitems ("LOGOUT T & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT T)?") (|GoodNight| t))) "Logout without saving VMem"))))) (* |;;| "Hide some system-level commands under a single top-level command") (or (for item in |BackgroundMenuCommands| thereis (string-equal "System" (car item))) (/nconc1 |BackgroundMenuCommands| (list "System" nil nil (list (quote subitems))))) (for label in (quote ("SaveVM" "Idle" "AR Edit" "DumpCache" "Set Directories" "LOGOUT & Power-Off")) do (move-background-item-under label "System")))) (* |;;| "Clear the background menu cache") (vars (|BackgroundMenu| nil)))))
(* |;;;| "Clean up the background menu")
(cl:defun move-background-item-under (label-to-move parent-label) (let ((item-to-move (for item in |BackgroundMenuCommands| thereis (string-equal label-to-move (car item)))) (parent-item (for item in |BackgroundMenuCommands| thereis (string-equal parent-label (car item))))) (cond ((or (null parent-item) (null item-to-move)) nil) ((null (cdddr parent-item)) (* \; "No subitems yet") (/nconc1 parent-item (bquote (subitems (\\\, item-to-move)))) (/dremove item-to-move |BackgroundMenuCommands|)) (t (* \; "Already has subitems ") (/nconc1 (cadddr parent-item) item-to-move) (/dremove item-to-move |BackgroundMenuCommands|)))))
(declare\: donteval@load donteval@compile
(eval-at-greet (* |;;| "Put the HARDCOPY item under the SNAP command") (move-background-item-under "Hardcopy" "Snap") (* |;;| "Put the ArchiveTool under the FileBrowser") (move-background-item-under "ArchiveTool" "FileBrowser") (* |;;| "Add a menu item for loging out") (/nconc1 |BackgroundMenuCommands| (quote ("LOGOUT & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT)?") (|GoodNight|))) "Logout of LISP" (subitems ("LOGOUT T & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT T)?") (|GoodNight| t))) "Logout without saving VMem"))))) (* |;;| "Hide some system-level commands under a single top-level command") (or (for item in |BackgroundMenuCommands| thereis (string-equal "System" (car item))) (/nconc1 |BackgroundMenuCommands| (list "System" nil nil (list (quote subitems))))) (for label in (quote ("SaveVM" "Idle" "AR Edit" "DumpCache" "Set Directories" "LOGOUT & Power-Off")) do (move-background-item-under label "System")))
(rpaqq |BackgroundMenu| nil)
)
(rpaqq do-load-utilities-init-commands ((* |;;| "Load the users specified utilities") (initvars *load-utility-options* nil) (p (eval-at-greet (cl:unless *generic-init-loaded* (cl:mapc (cl:function (cl:lambda (utility) (|PickLoadUtilityItem| utility nil t))) *load-utility-options*))))))
(* |;;| "Load the users specified utilities")
(rpaq? *load-utility-options* nil)
(rpaq? nil nil)
(eval-at-greet (cl:unless *generic-init-loaded* (cl:mapc (cl:function (cl:lambda (utility) (|PickLoadUtilityItem| utility nil t))) *load-utility-options*)))
(* |;;| "Send the Tool Work's a message telling it about this user.")
(cl:defun xcl-user::log-generic-init-user nil "If another person uses Generic-Init, let me know." (ignore-errors (let ((xcl-user::me "Lanning") (xcl-user::user (cl:if \\cc-generic-init-msg (username) ""))) (cond ((string-equal xcl-user::user xcl-user::me) (* |;;| "Don't bother if the user is me.") nil) ((not (cl:fboundp (quote lafite.sendmessage))) (* |;;| "Can't send message if LAFITE isn't loaded.") nil) (t (lafite.sendmessage (cl:format nil "Subject: ~A~%To: ~A~%Cc: ~A~@{~%~%~A~}" "Generic-Init" xcl-user::me xcl-user::user "This is to let you know that I am using Generic-Init (again)." "Thanks for making it available.")) (if (eq makesysname :medely) then (lafite.sendmessage (cl:format nil "Subject: ~A~%To: ~A~%From: ~A~@{~%~%~A~}" "!!!Stop using Generic-Init!!!" (username) "Generic-Init (lanning.pa)" "Welcome to Medley." "Did you know that Generic-Init is no longer supported in Medley?" "I thought not." "Instead, please start using VANILLA-INIT (another failure in the quest for a good name)." "You should edit your personal INIT file to reflect this change." "" "Have a nice day." "--smL"))))))))
(rpaq? \\cc-generic-init-msg t)
(eval-at-greet (cl:unless *generic-init-loaded* (xcl-user::log-generic-init-user)))
(rpaq *load-verbose* \\original-load-verbose)
(rpaq prettyheader \\original-prettyheader)
(rpaqq *generic-init-loaded* t)
(* |;;| "Make the FileManager happy")
(declare\: dontcopy
(putprops generic-init makefile-environment (:package "IL" :readtable "XCL"))
)
(putprops generic-init copyright ("Xerox Corporation" 1987 1988))
(declare\: dontcopy
(filemap (nil (10532 11096 (purge-file-advice 10542 . 10771) (purge-advice 10773 . 11094)) (50783
51349 (|DebugMode| 50793 . 51347)) (51385 51969 (selectw 51395 . 51967)) (53377 55868 (|PrintDocFile|
53387 . 55866)) (55902 56226 (|\\Pick-One-At-Random| 55912 . 56224)) (56395 57032 (|GoodNight| 56405
. 56722) (|NewLisp| 56724 . 57030)) (57212 60582 (|RememberLastPartition| 57222 . 58511) (
|RememberLispState| 58513 . 60580)))))
stop