From f5d8a17e74ec0cb7d2611dbd44baf9066e788538 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 15 Feb 2021 20:31:14 -0800 Subject: [PATCH 01/31] First commit of wheel-mouse scrolling --- lispusers/WHEELSCROLL | 1 + lispusers/WHEELSCROLL.LCOM | Bin 0 -> 2313 bytes 2 files changed, 1 insertion(+) create mode 100644 lispusers/WHEELSCROLL create mode 100644 lispusers/WHEELSCROLL.LCOM diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL new file mode 100644 index 00000000..d2a49393 --- /dev/null +++ b/lispusers/WHEELSCROLL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Feb-2021 18:24:12"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;1 3088 changes to%: (VARS WHEELSCROLLCOMS) (FNS ENABLEWHEELSCROLL INSTALL-WHEELSCROLL) previous date%: "15-Feb-2021 16:52:28" {DSK}kaplan>lisp>WHEELSCROLL.;8) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) (INITVARS (WHEELSCROLLDELTA 10)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (UP) (* ; "Edited 15-Feb-2021 16:23 by rmk:") (LET ((W (WHICHW))) (CL:WHEN W (SCROLLW W 0 (CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 15-Feb-2021 18:18 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (INTERRUPTCHAR 520 '(WHEELSCROLL T) T) (INTERRUPTCHAR 521 '(WHEELSCROLL NIL) T) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;;  "This doesn't seem to help the fact that it doesn't scroll when the caret is in the Tedit window.") (TEDIT.SETFUNCTION 520 [FUNCTION (LAMBDA NIL (WHEELSCROLL T] TEDIT.READTABLE) (TEDIT.SETFUNCTION 521 [FUNCTION (LAMBDA NIL (WHEELSCROLL NIL] TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (SEDIT:ADD-COMMAND 520 '(WHEELSCROLL T)) (SEDIT:ADD-COMMAND 521 '(WHEELSCROLL)) (SEDIT:RESET-COMMANDS))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 15-Feb-2021 14:50 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND [LIST (LIST 520 '(WHEELSCROLL T)) (LIST 521 '(WHEELSCROLL] (LISPINTERRUPTS.WSORIG]) ) (RPAQ? WHEELSCROLLDELTA 10) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (792 2943 (ENABLEWHEELSCROLL 802 . 1227) (WHEELSCROLL 1229 . 1538) (INSTALL-WHEELSCROLL 1540 . 2590) (LISPINTERRUPTS.WHEELSCROLL 2592 . 2941))))) STOP \ No newline at end of file diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..f9f48f1dcff73a227a2a63755d6b0799db37e38c GIT binary patch literal 2313 zcmb_d!EW0|5T$ZTS`bLDJ_Hj2LCJ#%?oyN}rBJ*kS2kgqq)Ez#fm~Eeu+=J(V95o7 zqCo$l*B<)?LGSsF{!M3>mc63X1_f%!lx8^lW@qNjj2ZGllT*@_my!lmPL2wAFKc15D$3@nJcg zO~$a8g8}-_VR8D)cf-}>Zq@&Bw49CR{djRbn)N?S#NeT(4*fZf@aK@8OA&u9{LQ`{!xY_}NlZXc7~IchP<&i1?$M&Ll2SfCwgn$|e{^!f(BwS{mBSka-&j&L)PSTu%4b=||TJ9bt?SN@|NNN1H6k|fA-a);i z=qH4dwPfqf|*4VE8yC zqSAgGFc|h9TH}Ef684iJ86Y2$FQ4o3{MmEKrm0NK{MiddlC~8Npq&&mY4;foRk4Qp z=j#oubh<&6f=nG2fV2q|;{Lsy7rbm@3!bqgEP#0JhZigiH)$K}N1-AoYV?1880BqE4jjiw> zu(9fIi!_gpfwXHckoa}Wr;Q+bns@|E1=|9G13=Y4X+hiDR$+r!P&i8oz literal 0 HcmV?d00001 From a8a9b69e948887b46e491a2729dadd657060d508 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Tue, 16 Feb 2021 15:44:08 -0800 Subject: [PATCH 02/31] Better behavior when the wheel moves inside a scroll bar --- lispusers/WHEELSCROLL | 2 +- lispusers/WHEELSCROLL.LCOM | Bin 2313 -> 3267 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL index d2a49393..256f0ee4 100644 --- a/lispusers/WHEELSCROLL +++ b/lispusers/WHEELSCROLL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Feb-2021 18:24:12"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;1 3088 changes to%: (VARS WHEELSCROLLCOMS) (FNS ENABLEWHEELSCROLL INSTALL-WHEELSCROLL) previous date%: "15-Feb-2021 16:52:28" {DSK}kaplan>lisp>WHEELSCROLL.;8) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) (INITVARS (WHEELSCROLLDELTA 10)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (UP) (* ; "Edited 15-Feb-2021 16:23 by rmk:") (LET ((W (WHICHW))) (CL:WHEN W (SCROLLW W 0 (CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 15-Feb-2021 18:18 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (INTERRUPTCHAR 520 '(WHEELSCROLL T) T) (INTERRUPTCHAR 521 '(WHEELSCROLL NIL) T) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;;  "This doesn't seem to help the fact that it doesn't scroll when the caret is in the Tedit window.") (TEDIT.SETFUNCTION 520 [FUNCTION (LAMBDA NIL (WHEELSCROLL T] TEDIT.READTABLE) (TEDIT.SETFUNCTION 521 [FUNCTION (LAMBDA NIL (WHEELSCROLL NIL] TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (SEDIT:ADD-COMMAND 520 '(WHEELSCROLL T)) (SEDIT:ADD-COMMAND 521 '(WHEELSCROLL)) (SEDIT:RESET-COMMANDS))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 15-Feb-2021 14:50 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND [LIST (LIST 520 '(WHEELSCROLL T)) (LIST 521 '(WHEELSCROLL] (LISPINTERRUPTS.WSORIG]) ) (RPAQ? WHEELSCROLLDELTA 10) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (792 2943 (ENABLEWHEELSCROLL 802 . 1227) (WHEELSCROLL 1229 . 1538) (INSTALL-WHEELSCROLL 1540 . 2590) (LISPINTERRUPTS.WHEELSCROLL 2592 . 2941))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-Feb-2021 15:37:58"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;7 5064 changes to%: (VARS WHEELSCROLLCOMS) (FNS WHEELSCROLL \SCROLLBARTOMAIN? \TEDIT.WHEELSCROLL) previous date%: "16-Feb-2021 15:12:14" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;6) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL CREATESCROLLBARWINDOW \SCROLLBARTOMAIN?) (FNS \TEDIT.WHEELSCROLL) (INITVARS (WHEELSCROLLDELTA 10)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (UP) (* ; "Edited 16-Feb-2021 15:35 by rmk:") (LET ((W (\SCROLLBARTOMAIN?))) (CL:WHEN W (SCROLLW W 0 (CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 16-Feb-2021 14:38 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (INTERRUPTCHAR 520 '(WHEELSCROLL T) T) (INTERRUPTCHAR 521 '(WHEELSCROLL NIL) T) (CHANGENAME 'SCROLL.HANDLER 'CREATEW 'CREATESCROLLBARWINDOW) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window. Otherwise the generic function is called on the Tedit window if the cursor is inside it.") (TEDIT.SETFUNCTION 520 [FUNCTION (LAMBDA NIL (\TEDIT.WHEELSCROLL T] TEDIT.READTABLE) (TEDIT.SETFUNCTION 521 [FUNCTION (LAMBDA NIL (\TEDIT.WHEELSCROLL NIL] TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (SEDIT:ADD-COMMAND 520 '(WHEELSCROLL T)) (SEDIT:ADD-COMMAND 521 '(WHEELSCROLL)) (SEDIT:RESET-COMMANDS))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 15-Feb-2021 14:50 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND [LIST (LIST 520 '(WHEELSCROLL T)) (LIST 521 '(WHEELSCROLL] (LISPINTERRUPTS.WSORIG]) (CREATESCROLLBARWINDOW [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS) (* ; "Edited 16-Feb-2021 14:37 by rmk:") (* ;; "This replaces CREATEW inside SCROLL.HANDLER. WINDOW should be bound to the window that this scroll bar will control. The purpose is to create an unreferenced (LOC) pointer from the controller to the controllee, so that wheel scrolling in the scrollbar can be redirected to the controllee.") (DECLARE (USEDFREE WINDOW)) (LET ((SBW (CREATEW REGION TITLE BORDERSIZE NOOPENFLG PROPS))) (WINDOWPROP SBW 'CONTROLLEELOC (LOC WINDOW)) SBW]) (\SCROLLBARTOMAIN? [LAMBDA NIL (* ; "Edited 16-Feb-2021 15:37 by rmk:") (* ;; "Returns the window that that should be wheel scrolled, moving from a scrollbar to its scrollee if necessary.") (LET ((W (WHICHW))) (CL:WHEN W (CL:WHEN (WINDOWPROP W 'CONTROLLEELOC) [SETQ W (VAG (WINDOWPROP W 'CONTROLLEELOC] (GETMOUSESTATE) (\CURSORPOSITION [IPLUS 10 (FETCH LEFT OF (WINDOWPROP W 'REGION] LASTMOUSEY) (SETCURSOR DEFAULTCURSOR) (GETMOUSESTATE))) W]) ) (DEFINEQ (\TEDIT.WHEELSCROLL [LAMBDA (UP) (* ; "Edited 16-Feb-2021 15:35 by rmk:") (* ;; "Called from the TEDIT.READTABLE when the wheel moves and the caret is in the TEDIT (WHICHW) window.") (\TEDIT.SCROLLFN (\SCROLLBARTOMAIN?) 0 (CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)]) ) (RPAQ? WHEELSCROLLDELTA 10) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (929 4504 (ENABLEWHEELSCROLL 939 . 1364) (WHEELSCROLL 1366 . 1690) (INSTALL-WHEELSCROLL 1692 . 2873) (LISPINTERRUPTS.WHEELSCROLL 2875 . 3224) (CREATESCROLLBARWINDOW 3226 . 3839) ( \SCROLLBARTOMAIN? 3841 . 4502)) (4505 4919 (\TEDIT.WHEELSCROLL 4515 . 4917))))) STOP \ No newline at end of file diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM index f9f48f1dcff73a227a2a63755d6b0799db37e38c..16e609ed7adac2b132880cd1193583644c71d3af 100644 GIT binary patch delta 1342 zcmZ`(OK;Oa5VlJiN|7Z>LA(TvDj^a0)0$d70>VXUV13(<$pD; z#xKLNpgt29MuXPxgR%8vX?DC$ed}STSc9tR*z%Qr?#$?^|E8AT^^-@9Ir4WpVl{|8 z2Xba&R$kXF-FaJ^80a%&S>%U37xxZ9%1ec_@>JpUi0$dy@>!ubeOtpz-Q=gjie8uJ zCyx$l4kTH34cGVQy|CMLxevst?B=!W(54~+Qn4T(NkT;{<(^<62SRGQc})V%Fy(#( z3k1B5%iEN@T?#b?+Th=@_Jqyh~JE5lVGhM3^4DkF5BpHZy6Qt8vToJa3kbvyXe@ihC$k8pG(uAuB_n?p zzYTUz*YN8`DFPFcW*->X5XE7X;9CWF7)F%0f;L(fwjKL4PS`byCIP_&qGWh5rtNHC zEp+A(%b?Bax;A;mZF;^jnejBEYlDs=tG6$+_h+}x0j*RqAxcGlE~^Yy6@t(MV*c*3 zY?R0Xcp(>=o>ADLhpw_QrW^RvN?(ETY0FIm;iYjB#$_02DT30bvdRdjv-*Z9K+~Dy z&0>yD84BUH3f#Fn-BIS}qWiy%iaq*eg>En1%@qwG< zfUbg-&95{vKwOF4CYo=7ygYIEW*XrP&Cx%JPXpm1wTCoa(^cbluE^Es>(fY)i9^7R z8Ln-v$`(gCjnPy#I17xDe7E;S_dgOJKLe!}Pkv|rOWY;KnOJh;#E`wIMYUkBr;g}` I+@9+F0zg?wF#rGn delta 422 zcmZvYOG^S#9L1Tz85g?pQQ8Ck1fdd|_fG0KN-*j*2Zr%6*Thymln^YRwTsr#Ci#DW zHf?LuE@%;bf}mCV_Vo=?Xd%?%Y!2uA;GEasmFLFtB%;OkVU)%x0itSjOH(HMO@U0F zmfYi`-bue3YC-1|a8=m#{>c(L8I)uKN?cX(UDz<0rRPl6C^2T*`C8dD!LV$un`U&* zi$H(aKJWC-M$kGKx7RgTBlGB_mY^C{CxZoVw=?Q*&sAd?_3>7`6y!$9$d?+p>B!)~ zQJgA-pNsFo{Wed`& ze@vA?u3WbY6|BnnAXT7fn5>|4W=|<9*fR={INr<4Vw&KC9PklHC4WgZrWg3^4vac4 qya@u~xgilC3O+kOP;p(mA`mt#gYW7!8(r=!zBzoj=U&92yZQt7%yhc| From 6c8ef665bb820157da97bc0470a1a83ff17a8239 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Tue, 16 Feb 2021 22:37:49 -0800 Subject: [PATCH 03/31] Tedit scrolling executed in mouse process --- lispusers/WHEELSCROLL | 2 +- lispusers/WHEELSCROLL.LCOM | Bin 3267 -> 3301 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL index 256f0ee4..e71d6c40 100644 --- a/lispusers/WHEELSCROLL +++ b/lispusers/WHEELSCROLL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-Feb-2021 15:37:58"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;7 5064 changes to%: (VARS WHEELSCROLLCOMS) (FNS WHEELSCROLL \SCROLLBARTOMAIN? \TEDIT.WHEELSCROLL) previous date%: "16-Feb-2021 15:12:14" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;6) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL CREATESCROLLBARWINDOW \SCROLLBARTOMAIN?) (FNS \TEDIT.WHEELSCROLL) (INITVARS (WHEELSCROLLDELTA 10)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (UP) (* ; "Edited 16-Feb-2021 15:35 by rmk:") (LET ((W (\SCROLLBARTOMAIN?))) (CL:WHEN W (SCROLLW W 0 (CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 16-Feb-2021 14:38 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (INTERRUPTCHAR 520 '(WHEELSCROLL T) T) (INTERRUPTCHAR 521 '(WHEELSCROLL NIL) T) (CHANGENAME 'SCROLL.HANDLER 'CREATEW 'CREATESCROLLBARWINDOW) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window. Otherwise the generic function is called on the Tedit window if the cursor is inside it.") (TEDIT.SETFUNCTION 520 [FUNCTION (LAMBDA NIL (\TEDIT.WHEELSCROLL T] TEDIT.READTABLE) (TEDIT.SETFUNCTION 521 [FUNCTION (LAMBDA NIL (\TEDIT.WHEELSCROLL NIL] TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (SEDIT:ADD-COMMAND 520 '(WHEELSCROLL T)) (SEDIT:ADD-COMMAND 521 '(WHEELSCROLL)) (SEDIT:RESET-COMMANDS))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 15-Feb-2021 14:50 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND [LIST (LIST 520 '(WHEELSCROLL T)) (LIST 521 '(WHEELSCROLL] (LISPINTERRUPTS.WSORIG]) (CREATESCROLLBARWINDOW [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS) (* ; "Edited 16-Feb-2021 14:37 by rmk:") (* ;; "This replaces CREATEW inside SCROLL.HANDLER. WINDOW should be bound to the window that this scroll bar will control. The purpose is to create an unreferenced (LOC) pointer from the controller to the controllee, so that wheel scrolling in the scrollbar can be redirected to the controllee.") (DECLARE (USEDFREE WINDOW)) (LET ((SBW (CREATEW REGION TITLE BORDERSIZE NOOPENFLG PROPS))) (WINDOWPROP SBW 'CONTROLLEELOC (LOC WINDOW)) SBW]) (\SCROLLBARTOMAIN? [LAMBDA NIL (* ; "Edited 16-Feb-2021 15:37 by rmk:") (* ;; "Returns the window that that should be wheel scrolled, moving from a scrollbar to its scrollee if necessary.") (LET ((W (WHICHW))) (CL:WHEN W (CL:WHEN (WINDOWPROP W 'CONTROLLEELOC) [SETQ W (VAG (WINDOWPROP W 'CONTROLLEELOC] (GETMOUSESTATE) (\CURSORPOSITION [IPLUS 10 (FETCH LEFT OF (WINDOWPROP W 'REGION] LASTMOUSEY) (SETCURSOR DEFAULTCURSOR) (GETMOUSESTATE))) W]) ) (DEFINEQ (\TEDIT.WHEELSCROLL [LAMBDA (UP) (* ; "Edited 16-Feb-2021 15:35 by rmk:") (* ;; "Called from the TEDIT.READTABLE when the wheel moves and the caret is in the TEDIT (WHICHW) window.") (\TEDIT.SCROLLFN (\SCROLLBARTOMAIN?) 0 (CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)]) ) (RPAQ? WHEELSCROLLDELTA 10) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (929 4504 (ENABLEWHEELSCROLL 939 . 1364) (WHEELSCROLL 1366 . 1690) (INSTALL-WHEELSCROLL 1692 . 2873) (LISPINTERRUPTS.WHEELSCROLL 2875 . 3224) (CREATESCROLLBARWINDOW 3226 . 3839) ( \SCROLLBARTOMAIN? 3841 . 4502)) (4505 4919 (\TEDIT.WHEELSCROLL 4515 . 4917))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-Feb-2021 22:36:05"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;11 5620 changes to%: (FNS \TEDIT.WHEELSCROLL \SCROLLBARTOMAIN?) previous date%: "16-Feb-2021 16:10:43" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;8) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL CREATESCROLLBARWINDOW \SCROLLBARTOMAIN?) (FNS \TEDIT.WHEELSCROLL) (INITVARS (WHEELSCROLLDELTA 10)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (UP) (* ; "Edited 16-Feb-2021 15:35 by rmk:") (LET ((W (\SCROLLBARTOMAIN?))) (CL:WHEN W (SCROLLW W 0 (CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 16-Feb-2021 14:38 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (INTERRUPTCHAR 520 '(WHEELSCROLL T) T) (INTERRUPTCHAR 521 '(WHEELSCROLL NIL) T) (CHANGENAME 'SCROLL.HANDLER 'CREATEW 'CREATESCROLLBARWINDOW) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window. Otherwise the generic function is called on the Tedit window if the cursor is inside it.") (TEDIT.SETFUNCTION 520 [FUNCTION (LAMBDA NIL (\TEDIT.WHEELSCROLL T] TEDIT.READTABLE) (TEDIT.SETFUNCTION 521 [FUNCTION (LAMBDA NIL (\TEDIT.WHEELSCROLL NIL] TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (SEDIT:ADD-COMMAND 520 '(WHEELSCROLL T)) (SEDIT:ADD-COMMAND 521 '(WHEELSCROLL)) (SEDIT:RESET-COMMANDS))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 15-Feb-2021 14:50 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND [LIST (LIST 520 '(WHEELSCROLL T)) (LIST 521 '(WHEELSCROLL] (LISPINTERRUPTS.WSORIG]) (CREATESCROLLBARWINDOW [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS) (* ; "Edited 16-Feb-2021 14:37 by rmk:") (* ;; "This replaces CREATEW inside SCROLL.HANDLER. WINDOW should be bound to the window that this scroll bar will control. The purpose is to create an unreferenced (LOC) pointer from the controller to the controllee, so that wheel scrolling in the scrollbar can be redirected to the controllee.") (DECLARE (USEDFREE WINDOW)) (LET ((SBW (CREATEW REGION TITLE BORDERSIZE NOOPENFLG PROPS))) (WINDOWPROP SBW 'CONTROLLEELOC (LOC WINDOW)) SBW]) (\SCROLLBARTOMAIN? [LAMBDA NIL (* ; "Edited 16-Feb-2021 22:13 by rmk:") (* ;; "Returns the window that should be wheel scrolled, moving from a scrollbar to its scrollee if necessary.") (LET ((W (WHICHW))) (CL:WHEN W (CL:WHEN (WINDOWPROP W 'CONTROLLEELOC) [SETQ W (VAG (WINDOWPROP W 'CONTROLLEELOC] (GETMOUSESTATE) (\CURSORPOSITION [IPLUS 10 (FETCH LEFT OF (WINDOWPROP W 'REGION] LASTMOUSEY) (SETCURSOR DEFAULTCURSOR) (GETMOUSESTATE))) (* ;; "IN/SCROLL/BAR? in WINDOWSCROLL does nothing if the window doesn't have a SCROLLFN, even though SCROLLW applies SCROLLBYREPAINTFN as a default in that case. So a direct call to SCROLLW might scroll a window that can't be scrolled by moving the mouse into the scrollbar (or so it seems). If we don't exclude this, then odd things like menus would be scrolled that shouldn't be.") (AND (WINDOWPROP W 'SCROLLFN) W]) ) (DEFINEQ (\TEDIT.WHEELSCROLL [LAMBDA (UP) (* ; "Edited 16-Feb-2021 22:35 by rmk:") (* ;; "Called from the TEDIT.READTABLE when the wheel moves and the caret is in the TEDIT (WHICHW) window or its scrollbar.") (LET ((WINDOW (\SCROLLBARTOMAIN?))) (CL:WHEN WINDOW [PROCESS.EVAL (FIND.PROCESS 'MOUSE) `(SCROLLW ,WINDOW 0 ,(CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)])]) ) (RPAQ? WHEELSCROLLDELTA 10) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (875 4891 (ENABLEWHEELSCROLL 885 . 1310) (WHEELSCROLL 1312 . 1636) (INSTALL-WHEELSCROLL 1638 . 2819) (LISPINTERRUPTS.WHEELSCROLL 2821 . 3170) (CREATESCROLLBARWINDOW 3172 . 3785) ( \SCROLLBARTOMAIN? 3787 . 4889)) (4892 5475 (\TEDIT.WHEELSCROLL 4902 . 5473))))) STOP \ No newline at end of file diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM index 16e609ed7adac2b132880cd1193583644c71d3af..4dca4a1dcb9ed46a749d9d56e26f087b90b278cf 100644 GIT binary patch delta 376 zcmX>s`BZX3B!`iam9d$Xf$7A=2qr_riM#Z~VnSS9JVW%tJzQOVf}Ml>eS8!$^Ask_ zGU_w(PWE9mLTD-UP%<=BFf}tWP)N>5%u7!#Rw&6=wNlV<^9xqsg_<+@KclR=rb0nc zYFTD}X|X~|Vo54cjgq06u3Ku7u91O}p@N~Am7#%^iSfij4@Qg4^O?T0$tEx|GB9v3 z0D&MQgGb6HuXGTb3q)+PoxGXTN@2eTCx~}aZVR)A0E32wg+h#{UvOxUYq+PMi+{Mn z%sl~*^2uAaXyY=M4JzQOVf}Ml>eS8#RAheTXP>8>;qo<#} z!sLlu!YrA23cM5l>rd8aG(zYv^r$yiFf}kUQAo~6%u7!#Rw&6=wNlUsa|{Yr;6*ak z+21!$`&arFst)Kp*)VPIrn1RIp)FgYdQWI From 0c7fed9a1842277b5069a05b09005342ef519208 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Wed, 17 Feb 2021 08:55:59 -0800 Subject: [PATCH 04/31] DINFO: removed compile-time declarations from compiled file --- lispusers/DINFO | 2 +- lispusers/DINFO.LCOM | Bin 31368 -> 30047 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/DINFO b/lispusers/DINFO index 88b13c0b..fc75f867 100644 --- a/lispusers/DINFO +++ b/lispusers/DINFO @@ -1 +1 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "27-Nov-2020 09:14:02" {DSK}larry>ilisp>medley>lispusers>DINFO.;3 63476 changes to%: (VARS DINFOCOMS) (TEMPLATES DINFOGRAPHPROP) previous date%: " 1-Oct-87 10:11:04" {DSK}larry>ilisp>medley>lispusers>DINFO.;1) (* ; " Copyright (c) 1985, 1986, 1987, 2020 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DINFOCOMS) (RPAQQ DINFOCOMS ((FILES TEDIT GRAPHER) (DECLARE%: EVAL@COMPILE (RECORDS DINFOGRAPH DINFONODE) (FUNCTIONS DINFOGRAPHPROP)) (FNS (* ; "Primary functions") DINFO DINFO.UPDATE DINFOGRAPH DINFO.SPECIAL.UPDATE DINFO.READ.GRAPH DINFO.WRITE.GRAPH DINFO.SELECT.GRAPH DINFO.DEFAULT.MENU DINFO.FIND DINFO.LOOKUP) (FNS (* ; "Koto compatability") DINFO.READ.KOTO.GRAPH) (FNS (* ; "Window functions") DINFO.SETUP.WINDOW DINFO.CLOSEFN DINFO.SHRINKFN DINFO.EXPANDFN DINFO.ICONFN) (FNS (* ; "FreeMenu functions") DINFO.ADD.FMENU DINFO.CREATE.FMENU DINFO.FMW.CLOSEFN DINFO.FMENU.HANDLER DINFO.UPDATE.FMENU DINFO.TOGGLE.MENU DINFO.TOGGLE.GRAPH DINFO.TOGGLE.HISTORY DINFO.TOGGLE.TEXT) (FNS (* ; "Other menu functions") DINFO.UPDATE.MENU.DISPLAY DINFO.UPDATE.FROM.MENU DINFO.UPDATE.HISTORY DINFO.HISTORIC.UPDATE) (FNS (* ; "Interface to GRAPHER") DINFO.UPDATE.GRAPH.DISPLAY DINFO.UPDATE.FROM.GRAPH DINFO.GET.GRAPH.WINDOW DINFO.CREATE.GRAPH.WINDOW DINFO.SHOWGRAPH DINFO.INVERT.NODE DINFO.LAYOUTGRAPH) (FNS (* ; "Interface to TEdit") DINFO.UPDATE.TEXT.DISPLAY DINFO.TITLEMENUFN DINFO.OPENTEXTSTREAM DINFO.SHOWSEL DINFO.GET.FILENAME) (ADDVARS (BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH) "Open a DInfo window for browsing documentation."))) (VARS (BackgroundMenu)) (INITVARS (DINFO.GRAPHS) (DINFOMODES '(TEXT GRAPH)) (DINFO.HISTORY.LENGTH 20) (\DINFO.MAX.MENU.LEN 10)) (GLOBALVARS DINFO.GRAPH.FILES DINFOMODES DINFO.HISTORY.LENGTH \DINFO.MAX.MENU.LEN) (PROP (FILETYPE) DINFO) (TEMPLATES DINFOGRAPHPROP))) (FILESLOAD TEDIT GRAPHER) (DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE (DATATYPE DINFOGRAPH (NAME NODELST TOPNODEID CURRENTNODE USERDATA TEXTPROPS FREEMENUITEMS LOOKUPFN MENUFN DEFAULTHOST DEFAULTDEVICE DEFAULTDIR MONITORLOCK DINFO.MENU WINDOW MENUFONT FMENU.WINDOW GRAPH.WINDOW HISTORY.MENU.WINDOW SUBNODE.MENU.WINDOW LAST.TEXT LAST.INVERTED.NODE LAST.GRAPH.LOCATION HISTORY.ITEMS FIND.STRING LOOKUP.STRING) (SYSTEM)) (RECORD DINFONODE (ID LABEL FILE FROMBYTE TOBYTE PARENT CHILDREN NEXTNODE PREVIOUSNODE USERDATA) (SYSTEM)) ) (/DECLAREDATATYPE 'DINFOGRAPH '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((DINFOGRAPH 0 POINTER) (DINFOGRAPH 2 POINTER) (DINFOGRAPH 4 POINTER) (DINFOGRAPH 6 POINTER) (DINFOGRAPH 8 POINTER) (DINFOGRAPH 10 POINTER) (DINFOGRAPH 12 POINTER) (DINFOGRAPH 14 POINTER) (DINFOGRAPH 16 POINTER) (DINFOGRAPH 18 POINTER) (DINFOGRAPH 20 POINTER) (DINFOGRAPH 22 POINTER) (DINFOGRAPH 24 POINTER) (DINFOGRAPH 26 POINTER) (DINFOGRAPH 28 POINTER) (DINFOGRAPH 30 POINTER) (DINFOGRAPH 32 POINTER) (DINFOGRAPH 34 POINTER) (DINFOGRAPH 36 POINTER) (DINFOGRAPH 38 POINTER) (DINFOGRAPH 40 POINTER) (DINFOGRAPH 42 POINTER) (DINFOGRAPH 44 POINTER) (DINFOGRAPH 46 POINTER) (DINFOGRAPH 48 POINTER) (DINFOGRAPH 50 POINTER)) '52) (DEFMACRO DINFOGRAPHPROP (GRAPH PROP &OPTIONAL (NEW-VALUE NIL NEW-VALUE-SUPPLIED)) [LET [(REAL-FIELD (AND (LISTP PROP) (EQ (CAR PROP) 'QUOTE) (FMEMB (CADR PROP) (RECORDFIELDNAMES 'DINFOGRAPH T)) (CADR PROP] (IF NEW-VALUE-SUPPLIED THEN [IF REAL-FIELD THEN `(REPLACE (DINFOGRAPH ,REAL-FIELD) OF ,GRAPH WITH ,NEW-VALUE) ELSE `(LET* ((SI::$GRAPH$ ,GRAPH) (SI::$USERDATA$ (FETCH (DINFOGRAPH USERDATA) OF SI::$GRAPH$)) (SI::$PROP$ ,PROP) (SI::$NEW-VALUE$ ,NEW-VALUE)) (IF (LISTP SI::$USERDATA$) THEN (LISTPUT SI::$USERDATA$ SI::$PROP$ SI::$NEW-VALUE$) ELSE (REPLACE (DINFOGRAPH USERDATA) OF SI::$GRAPH$ WITH (LIST SI::$PROP$ SI::$NEW-VALUE$)) SI::$NEW-VALUE$] ELSE (IF REAL-FIELD THEN `(FETCH (DINFOGRAPH ,REAL-FIELD) OF ,GRAPH) ELSE `(LISTGET (FETCH (DINFOGRAPH USERDATA) OF ,GRAPH) ,PROP]) ) (DEFINEQ (DINFO [LAMBDA (GRAPH.OR.FILE WINDOW.OR.REGION SETUP.ONLY? NO.FREEMENU?) (* drc%: "25-Jan-86 18:23") (* Starts a DInfo browser.) (RESETLST (LET ((W (OR (WINDOWP WINDOW.OR.REGION) (AND (REGIONP WINDOW.OR.REGION) (CREATEW WINDOW.OR.REGION "DInfo" NIL T)) (AND (type? DINFOGRAPH GRAPH.OR.FILE) (WINDOWP (fetch (DINFOGRAPH WINDOW) of GRAPH.OR.FILE))) (CREATEW NIL "DInfo"))) GRAPH MONITORLOCK) (OPENW W) [SETQ GRAPH (if (type? DINFOGRAPH GRAPH.OR.FILE) then GRAPH.OR.FILE else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW W)) (DINFO.READ.GRAPH GRAPH.OR.FILE] [SETQ MONITORLOCK (OR (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) (replace (DINFOGRAPH MONITORLOCK) of GRAPH with (CREATE.MONITORLOCK "DInfo"] (RESETSAVE NIL (LIST 'RELEASE.MONITORLOCK MONITORLOCK)) (OBTAIN.MONITORLOCK MONITORLOCK) (DINFO.SETUP.WINDOW GRAPH W NO.FREEMENU?) (OR SETUP.ONLY? (DINFO.UPDATE GRAPH NIL NIL T)) GRAPH]) (DINFO.UPDATE [LAMBDA (GRAPH NEW.NODE SEL FORCE?) (* jow "20-May-86 15:14") (* * Called to visit a NEW.NODE in GRAPH, or to just make sure that the display  of GRAPH is current.) (LET ([NODE (OR NEW.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH) (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) (fetch (DINFOGRAPH NODELST) of GRAPH] (PREVIOUS.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (OPENW WINDOW) (WINDOWPROP WINDOW 'DINFOGRAPH GRAPH) (OR (FMEMB NODE (fetch (DINFOGRAPH NODELST) of GRAPH)) (ERROR NODE "NOT IN NODELST")) (LET ((FMENU.WINDOW (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH)) (MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH))) [RESETLST (RESETSAVE NIL (LIST 'RELEASE.MONITORLOCK MONITORLOCK)) (if (NOT (OBTAIN.MONITORLOCK MONITORLOCK T)) then (* somebody else is messing with this  graph.) (FLASHWINDOW WINDOW) (PROMPTPRINT "DInfo is busy") elseif (NULL FMENU.WINDOW) then (replace (DINFOGRAPH CURRENTNODE) of GRAPH with NODE) (* FreeMenu turned off, so just  display text) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NODE SEL) else (* We've got a FreeMenu, so update  away!) (DINFO.UPDATE.FMENU GRAPH NODE) (LET ((STATUS (FM.GETSTATE FMENU.WINDOW))) (replace (DINFOGRAPH CURRENTNODE) of GRAPH with NODE) (AND (LISTGET STATUS 'GRAPH) (DINFO.UPDATE.GRAPH.DISPLAY GRAPH NODE FORCE?)) (AND (LISTGET STATUS 'MENU) (DINFO.UPDATE.MENU.DISPLAY GRAPH NODE)) (AND (LISTGET STATUS 'TEXT) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NODE SEL)) (DINFO.UPDATE.HISTORY GRAPH NODE SEL (LISTGET STATUS 'HISTORY] (CLEARW (GETPROMPTWINDOW WINDOW]) (DINFOGRAPH [LAMBDA (X) (* drc%: " 8-Jan-86 11:12") (if (type? DINFOGRAPH X) then X elseif (AND (WINDOWP X) (WINDOWPROP X 'DINFOGRAPH)) elseif (AND (WINDOWP X) (WINDOWPROP X 'MAINWINDOW)) then (WINDOWPROP (WINDOWPROP X 'MAINWINDOW) 'DINFOGRAPH]) (DINFO.SPECIAL.UPDATE [LAMBDA (TYPE GRAPH) (* drc%: "25-Jan-86 18:26") (* * Do a TYPE update of Graph, where TYPE is one of Top, Parent, Previous or  Next.) (LET* [(DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (CURRENT.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (NEW.NODE (FASSOC (SELECTQ TYPE (Top (fetch (DINFOGRAPH TOPNODEID) of GRAPH)) (Parent (fetch (DINFONODE PARENT) of CURRENT.NODE)) (Next (fetch (DINFONODE NEXTNODE) of CURRENT.NODE)) (Previous (fetch (DINFONODE PREVIOUSNODE) of CURRENT.NODE)) NIL) (fetch (DINFOGRAPH NODELST) of GRAPH] (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then (if NEW.NODE then (PROCESSPROP (THIS.PROCESS) 'NAME (CONCAT "DInfo " TYPE)) (DINFO.UPDATE GRAPH NEW.NODE) else (* TYPE of Top! or Node! will sound silly here, but should never happen.) (printout (GETPROMPTWINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) T "This node has no " TYPE)) else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) (DINFO.READ.GRAPH [LAMBDA (FILE QUIETFLG) (* drc%: "25-Jan-86 18:17") (* Reads a file written by DINFO.WRITE.GRAPH.  Returns the DInfo graph stored on FILE.) (OR QUIETFLG (printout T T "Reading " (FILENAMEFIELD FILE 'NAME) " graph...")) (LET* ((FULLFILENAME (INFILEP FILE)) [DATA (CDR (READFILE (OR FULLFILENAME (ERROR "FILE NOT FOUND" FILE] (GRAPH (create DINFOGRAPH))) (* fields stored on file) (replace (DINFOGRAPH TOPNODEID) of GRAPH with (LISTGET DATA 'TOPNODEID)) (replace (DINFOGRAPH TEXTPROPS) of GRAPH with (LISTGET DATA 'TEXTPROPS)) (replace (DINFOGRAPH LOOKUPFN) of GRAPH with (LISTGET DATA 'LOOKUPFN)) (replace (DINFOGRAPH MENUFN) of GRAPH with (LISTGET DATA 'MENUFN)) (replace (DINFOGRAPH FREEMENUITEMS) of GRAPH with (LISTGET DATA 'FREEMENUITEMS)) (replace (DINFOGRAPH NODELST) of GRAPH with (LISTGET DATA 'NODELST)) (replace (DINFOGRAPH USERDATA) of GRAPH with (LISTGET DATA 'USERDATA)) (* fields filled in at read time) (replace (DINFOGRAPH NAME) of GRAPH with (FILENAMEFIELD FULLFILENAME 'NAME)) (replace (DINFOGRAPH DEFAULTHOST) of GRAPH with (FILENAMEFIELD FULLFILENAME 'HOST)) (replace (DINFOGRAPH DEFAULTDEVICE) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DEVICE)) (replace (DINFOGRAPH DEFAULTDIR) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DIRECTORY)) (OR QUIETFLG (printout T "OK.")) GRAPH]) (DINFO.WRITE.GRAPH [LAMBDA (GRAPH FILE) (* drc%: "25-Jan-86 18:16") (* Writes a DInfo graph to a file for reading by DINFO.READ.GRAPH.  Returns the full file name of the file.) (* dump it out as a props list) (WRITEFILE (LIST 'TOPNODEID (fetch (DINFOGRAPH TOPNODEID) of GRAPH) 'TEXTPROPS (fetch (DINFOGRAPH TEXTPROPS) of GRAPH) 'LOOKUPFN (fetch (DINFOGRAPH LOOKUPFN) of GRAPH) 'MENUFN (fetch (DINFOGRAPH MENUFN) of GRAPH) 'FREEMENUITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH) 'NODELST (fetch (DINFOGRAPH NODELST) of GRAPH) 'USERDATA (fetch (DINFOGRAPH USERDATA) of GRAPH)) FILE]) (DINFO.SELECT.GRAPH [LAMBDA NIL (* drc%: "24-Jan-86 13:25") (* * This is called when DInfo is selected from the Background Menu.) (DECLARE (GLOBALVARS DINFO.GRAPHS)) (ALLOW.BUTTON.EVENTS) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (LET [(GRAPH (if (NULL DINFO.GRAPHS) then (PROMPTPRINT "No Graphs installed -- load HelpSys or DInfoEdit") elseif (NULL (CDR DINFO.GRAPHS)) then (EVAL (CADAR DINFO.GRAPHS)) else (MENU (create MENU CENTERFLG _ T TITLE _ "Select Graph" ITEMS _ DINFO.GRAPHS] (AND GRAPH (DINFO GRAPH]) (DINFO.DEFAULT.MENU [LAMBDA (GRAPH) (* jow "15-Jul-86 17:36") (* * This is the default MENUFN for DInfo graphs.) (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (CLEARW (GETPROMPTWINDOW DINFOW)) (LET [(TYPE (MENU (OR (fetch (DINFOGRAPH DINFO.MENU) of GRAPH) (replace (DINFOGRAPH DINFO.MENU) of GRAPH with (create MENU ITEMS _ '(("Top" 'Top "Visit the top node in the graph" ) ("Parent" 'Parent "Visit the parent of the current node" ) ("Previous" 'Previous "Visit the node before this node") ("Next " 'Next "Visit the node following this node") ("Find" 'Find "Search the text of this node") ("Lookup" 'Lookup "Lookup a new term in this graph") ("Expanded Menu" 'FreeMenu "Add an expanded options menu.")) CENTERFLG _ T MENUFONT _ (FONTCREATE 'HELVETICA 10 'BOLD] (if TYPE then (PROCESSPROP (THIS.PROCESS) 'NAME (CONCAT "DInfo " TYPE)) (SELECTQ TYPE ((Top Parent Previous Next) (DINFO.SPECIAL.UPDATE TYPE GRAPH)) (Find (DINFO.FIND GRAPH)) (Lookup (DINFO.LOOKUP GRAPH '(LEFT))) (FreeMenu (DINFO.ADD.FMENU GRAPH) (DINFO.UPDATE GRAPH)) NIL]) (DINFO.FIND [LAMBDA (GRAPH BUTTONS) (* drc%: "25-Jan-86 18:23") (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (if (NOT (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T)) then (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy") else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (TERPRI T) (LET ([STRING (if (AND (FMEMB 'MIDDLE BUTTONS) (fetch (DINFOGRAPH FIND.STRING) of GRAPH)) else (PROMPTFORWORD "Find: " (fetch (DINFOGRAPH FIND.STRING) of GRAPH) NIL NIL NIL 'TTY (CONSTANT (CHARCODE (EOL ESCAPE LF] (TEXTSTREAM (WINDOWPROP DINFOW 'TEXTSTREAM)) PAIR) (replace (DINFOGRAPH FIND.STRING) of GRAPH with STRING) (if STRING then (PRINTOUT T " Searching...") (if (SETQ PAIR (TEDIT.FIND TEXTSTREAM STRING NIL NIL T)) then (printout T "OK.") (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SHOWSEL TEXTSTREAM T (TEDIT.SETSEL TEXTSTREAM (CAR PAIR) (NCHARS STRING) 'RIGHT T))) else (printout T "not found.") (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 0]) (DINFO.LOOKUP [LAMBDA (GRAPH BUTTONS) (* drc%: "25-Jan-86 18:22") (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then [RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (LET ((LOOKUPFN (fetch (DINFOGRAPH LOOKUPFN) of GRAPH))) (if LOOKUPFN then (CLEARW T) (LET* [(OLD.STRING (fetch (DINFOGRAPH LOOKUP.STRING) of GRAPH)) (STRING (if (AND OLD.STRING (FMEMB 'MIDDLE BUTTONS)) then OLD.STRING else (PROMPTFORWORD "Lookup: " OLD.STRING NIL NIL NIL 'TTY (CONSTANT (CHARCODE (EOL ESCAPE LF] (replace (DINFOGRAPH LOOKUP.STRING) of GRAPH with STRING) (AND STRING (APPLY* LOOKUPFN STRING GRAPH))) else (PRINTOUT T T "The " (fetch (DINFOGRAPH NAME) of GRAPH) " graph has no LOOKUPFN."] else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) ) (DEFINEQ (DINFO.READ.KOTO.GRAPH [LAMBDA (FILE QUIETFLG) (* drc%: " 4-Feb-86 11:27") (* Reads a file written by Koto DINFO.WRITE.GRAPH and returns a Lute  DINFOGRAPH. Thus, (DINFO.WRITE.GRAPH (DINFO.READ.KOTO.GRAPH ) )  will convert the Koto format graph in to a Lute format graph in  .) (OR QUIETFLG (printout T T "Reading " (FILENAMEFIELD FILE 'NAME) " graph...")) (LET* ((FULLFILENAME (INFILEP FILE)) [DATA (CDR (READFILE (OR FULLFILENAME (ERROR "FILE NOT FOUND" FILE] (GRAPH (create DINFOGRAPH))) (* in Koto we just wrote out the  DINFOGRAPH record) (for FIELD in DATA as N from 1 to 11 do (* fields stored on file) (SELECTQ N ((1 4 5 6 10 11)) (2 (replace (DINFOGRAPH NODELST) of GRAPH with FIELD)) (3 (replace (DINFOGRAPH TOPNODEID) of GRAPH with FIELD)) (7 (replace (DINFOGRAPH TEXTPROPS) of GRAPH with FIELD)) (8 (replace (DINFOGRAPH LOOKUPFN) of GRAPH with FIELD)) (9 (replace (DINFOGRAPH MENUFN) of GRAPH with FIELD)) (SHOULDNT))) (* fields filled in at read time) (replace (DINFOGRAPH NAME) of GRAPH with (FILENAMEFIELD FULLFILENAME 'NAME)) (replace (DINFOGRAPH DEFAULTHOST) of GRAPH with (FILENAMEFIELD FULLFILENAME 'HOST)) (replace (DINFOGRAPH DEFAULTDEVICE) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DEVICE)) (replace (DINFOGRAPH DEFAULTDIR) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DIRECTORY)) (OR QUIETFLG (printout T "OK.")) GRAPH]) ) (DEFINEQ (DINFO.SETUP.WINDOW [LAMBDA (GRAPH WINDOW NO.FREEMENU?) (* jow "10-Jun-86 15:29") (replace (DINFOGRAPH WINDOW) of GRAPH with WINDOW) (WINDOWPROP WINDOW 'DINFOGRAPH GRAPH) (DETACHALLWINDOWS WINDOW) (if (NOT NO.FREEMENU?) then (DINFO.ADD.FMENU GRAPH)) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NIL NIL T) (WINDOWPROP WINDOW 'TITLE (CONCAT (fetch (DINFOGRAPH NAME) of GRAPH) " DInfo")) (WINDOWADDPROP WINDOW 'CLOSEFN 'DINFO.CLOSEFN) (WINDOWADDPROP WINDOW 'SHRINKFN 'DINFO.SHRINKFN) (WINDOWADDPROP WINDOW 'EXPANDFN 'DINFO.EXPANDFN]) (DINFO.CLOSEFN [LAMBDA (W) (* drc%: "25-Jan-86 18:26") (LET [(GRAPH (WINDOWPROP W 'DINFOGRAPH] (if (type? DINFOGRAPH GRAPH) then (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH)) (* remove circularity...) (WINDOWPROP W 'DINFOGRAPH NIL]) (DINFO.SHRINKFN [LAMBDA (W) (* drc%: "25-Jan-86 18:26") (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of (DINFOGRAPH W]) (DINFO.EXPANDFN [LAMBDA (W) (* jow "15-Jul-86 17:00") (LET* ((GRAPH (DINFOGRAPH W)) (FMENU (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH))) (if (AND FMENU (LISTGET (FM.GETSTATE FMENU) 'GRAPH)) then (LET ((GRAPHW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) (OPENW GRAPHW) (TOTOPW W) (WINDOWPROP GRAPHW 'DINFOGRAPH GRAPH]) (DINFO.ICONFN [LAMBDA (W) (* drc%: "25-Jan-86 16:33") (OR (WINDOWPROP WINDOW 'ICON) (WINDOWPROP WINDOW 'ICON (TITLEDICONW TEDIT.TITLED.ICON.TEMPLATE (WINDOWPROP WINDOW 'TITLE) TEDIT.ICON.FONT NIL T)) (WINDOWPROP WINDOW 'ICON]) ) (DEFINEQ (DINFO.ADD.FMENU [LAMBDA (GRAPH) (* jow "20-May-86 15:41") (* * Add a DInfo FreeMenu to WINDOW. then update the FreeMenu's display.) (LET ((WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (FM.WINDOW (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH))) (if [AND (WINDOWP FM.WINDOW) (FMEMB FM.WINDOW (WINDOWPROP WINDOW 'ATTACHEDWINDOWS] then (OPENW FM.WINDOW) else (REMOVEPROMPTWINDOW WINDOW) (SETQ FM.WINDOW (OR (WINDOWP FM.WINDOW) (DINFO.CREATE.FMENU GRAPH))) (replace (DINFOGRAPH FMENU.WINDOW) of GRAPH with FM.WINDOW) (ATTACHWINDOW FM.WINDOW WINDOW) (WINDOWPROP FM.WINDOW 'FM.PROMPTWINDOW (GETPROMPTWINDOW WINDOW)) (WINDOWDELPROP FM.WINDOW 'PASSTOMAINCOMS 'CLOSEW) (WINDOWADDPROP FM.WINDOW 'CLOSEFN 'DINFO.FMW.CLOSEFN T) (DINFO.UPDATE.FMENU GRAPH]) (DINFO.CREATE.FMENU [LAMBDA (GRAPH) (* jow "15-Jul-86 17:39") (* * Makes a DInfo FreeMenu for GRAPH) (LET* [(ADD.ITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH)) (FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT)) (FM (FREEMENU `((PROPS FONT %, FONT) ((LABEL Node%: TYPE DISPLAY FONT (HELVETICA 10)) (ID NODE LABEL "" TYPE DISPLAY)) ((LABEL Top! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the top node") (ID TOP LABEL "" TYPE DISPLAY)) ((LABEL Parent! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the parent of the current node") (ID PARENT LABEL "" TYPE DISPLAY)) ((LABEL Previous! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the node previous to the current node") (ID PREVIOUS LABEL "" TYPE DISPLAY)) ((LABEL Next! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the node after the current node") (ID NEXT LABEL "" TYPE DISPLAY)) ((LABEL Display%: TYPE DISPLAY FONT (HELVETICA 10)) (LABEL Graph ID GRAPH INITSTATE %, (MEMB 'GRAPH DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.GRAPH FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the graph") (LABEL Menu ID MENU INITSTATE %, (MEMB 'MENU DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.MENU FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the subnode menu") (LABEL Text ID TEXT INITSTATE %, (MEMB 'TEXT DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.TEXT FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the text of the current node") (LABEL History ID HISTORY INITSTATE %, (MEMB 'HISTORY DINFOMODES) TYPE TOGGLE FONT (HELVETICA 10 BOLD) SELECTEDFN DINFO.TOGGLE.HISTORY MESSAGE "Toggle the display of the History Menu")) %, (APPEND '((LABEL Find! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Perform a string search in the selected text of the current node" ) (LABEL Lookup! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Lookup a term in this graph. LEFT for new term, MIDDLE to repeat last." )) ADD.ITEMS] (WINDOWPROP FM 'FM.DONTRESHAPE T) FM]) (DINFO.FMW.CLOSEFN [LAMBDA (W) (* drc%: "25-Jan-86 18:19") (* * CLOSEFN for a DInfo FreeMenu window.) (LET* ((DINFOW (WINDOWPROP W 'MAINWINDOW)) (GRAPH (DINFOGRAPH DINFOW))) (if GRAPH then (DETACHWINDOW W) (replace (DINFOGRAPH FMENU.WINDOW) of GRAPH with NIL) (DETACHWINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) (CLOSEW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) (DETACHWINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH)) (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH)) (REMOVEPROMPTWINDOW DINFOW]) (DINFO.FMENU.HANDLER [LAMBDA (ITEM WINDOW BUTTONS) (* drc%: "16-Jan-86 11:42") (* * Handle a command from the FreeMenu.) (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH)) (TYPE (MKATOM (SUBSTRING (FM.ITEMPROP ITEM 'LABEL) 1 -2] (SELECTQ TYPE ((Top Parent Previous Next) (DINFO.SPECIAL.UPDATE TYPE GRAPH)) (Find (DINFO.FIND GRAPH BUTTONS)) (Lookup (DINFO.LOOKUP GRAPH BUTTONS)) (SHOULDNT]) (DINFO.UPDATE.FMENU [LAMBDA (GRAPH NEW.NODE) (* jow "20-May-86 15:13") (* * Update the display of GRAPH's FreeMenu.  If NEW.NODE is not specified, use Top node of GRAPH, and change Top node title.) (LET* [(W (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH)) (NODELST (fetch (DINFOGRAPH NODELST) of GRAPH)) (NODE (OR NEW.NODE (FASSOC (fetch (DINFONODE ID) of (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) NODELST) (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) NODELST] (OR NEW.NODE (FM.CHANGELABEL (FM.GETITEM 'TOP NIL W) (fetch (DINFONODE LABEL) of (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) (fetch (DINFOGRAPH NODELST) of GRAPH))) W)) (FM.CHANGELABEL (FM.GETITEM 'NODE NIL W) (fetch (DINFONODE LABEL) of NODE) W) (FM.CHANGELABEL (FM.GETITEM 'PARENT NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE PARENT) of NODE) NODELST)) W) (FM.CHANGELABEL (FM.GETITEM 'NEXT NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE NEXTNODE) of NODE) NODELST)) W) (FM.CHANGELABEL (FM.GETITEM 'PREVIOUS NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE PREVIOUSNODE) of NODE) NODELST)) W]) (DINFO.TOGGLE.MENU [LAMBDA (ITEM WINDOW) (* jow "10-Jun-86 14:15") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.MENU.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) else (LET ((SUBNODE.MENU.WINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH))) (DETACHWINDOW SUBNODE.MENU.WINDOW) (CLOSEW SUBNODE.MENU.WINDOW]) (DINFO.TOGGLE.GRAPH [LAMBDA (ITEM WINDOW) (* ; "Edited 1-Oct-87 09:56 by drc:") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.GRAPH.DISPLAY GRAPH (fetch CURRENTNODE of GRAPH) T) else (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) ITEM]) (DINFO.TOGGLE.HISTORY [LAMBDA (ITEM WINDOW) (* jow "10-Jun-86 14:22") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.HISTORY GRAPH NIL NIL T) else (LET ((HISTORY.MENU.WINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH))) (DETACHWINDOW HISTORY.MENU.WINDOW) (CLOSEW HISTORY.MENU.WINDOW]) (DINFO.TOGGLE.TEXT [LAMBDA (ITEM WINDOW) (* drc%: "25-Jan-86 18:26") (LET* ((DINFOW (WINDOWPROP WINDOW 'MAINWINDOW)) (GRAPH (WINDOWPROP DINFOW 'DINFOGRAPH)) (MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH))) (if (NOT (OBTAIN.MONITORLOCK MONITORLOCK T)) then (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy") elseif (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.TEXT.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (RELEASE.MONITORLOCK MONITORLOCK) else (DINFO.UPDATE.TEXT.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH) NIL T) (RELEASE.MONITORLOCK MONITORLOCK]) ) (DEFINEQ (DINFO.UPDATE.MENU.DISPLAY [LAMBDA (GRAPH NODE) (* drc%: "25-Jan-86 18:20") (LET* [(DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (WINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) [CHILDREN (DREVERSE (for ID in (fetch (DINFONODE CHILDREN) of NODE) bind (NODELST _ (fetch (DINFOGRAPH NODELST) of GRAPH)) collect (FASSOC ID NODELST] (LENGTH (FLENGTH CHILDREN)) (SCROLLABLE (GREATERP LENGTH \DINFO.MAX.MENU.LEN)) (MENU (create MENU MENUFONT _ (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT) ITEMWIDTH _ (WINDOWPROP DINFOW 'WIDTH) CENTERFLG _ T MENUCOLUMNS _ 1 MENUOUTLINESIZE _ 0 ITEMS _ (for CHILD in CHILDREN collect (LIST (fetch (DINFONODE LABEL) of CHILD) CHILD "Will visit this node if selected." )) WHENSELECTEDFN _ (FUNCTION DINFO.UPDATE.FROM.MENU] (AND WINDOW (PROGN (DETACHWINDOW WINDOW) (CLOSEW WINDOW))) (if CHILDREN then (UPDATE/MENU/IMAGE MENU) (SETQ WINDOW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (WINDOWPROP DINFOW 'WIDTH) HEIGHT _ (HEIGHTIFWINDOW (if SCROLLABLE then (TIMES \DINFO.MAX.MENU.LEN (fetch (MENU ITEMHEIGHT) of MENU)) else (fetch (MENU IMAGEHEIGHT) of MENU)) T)) "Subnodes" NIL T)) (ADDMENU MENU WINDOW (create POSITION XCOORD _ 0 YCOORD _ (if SCROLLABLE then (TIMES (DIFFERENCE \DINFO.MAX.MENU.LEN LENGTH) (fetch (MENU ITEMHEIGHT) of MENU)) else 0)) T) (ATTACHWINDOW WINDOW DINFOW 'BOTTOM) (REDISPLAYW WINDOW) (replace (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH with WINDOW) (LET [(BITS (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW 'REGION] (* Slide DINFOW up if our new menu is off the screen) (AND (ILESSP BITS 0) (RELMOVEW DINFOW (create POSITION XCOORD _ 0 YCOORD _ (IDIFFERENCE 0 BITS]) (DINFO.UPDATE.FROM.MENU [LAMBDA (ITEM MENU BUTTONS) (* drc%: "12-Dec-85 14:49") (DINFO.UPDATE (WINDOWPROP (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW) 'DINFOGRAPH) (CADR ITEM]) (DINFO.UPDATE.HISTORY [LAMBDA (GRAPH NODE SEL DISPLAY?) (* drc%: "25-Jan-86 18:21") (LET* ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (OLDWINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH)) (OLDITEMS (fetch (DINFOGRAPH HISTORY.ITEMS) of GRAPH)) (NEWITEM (if SEL then (LIST (if (LISTP SEL) then (CAR SEL) else SEL) (LIST (fetch (DINFONODE ID) of NODE) SEL) "Will re-lookup this term") elseif NODE then (LIST (fetch (DINFONODE LABEL) of NODE) (LIST (fetch (DINFONODE ID) of NODE) SEL) "Will re-visit this node"))) (ITEMS (if [AND NEWITEM (NOT (EQUAL NEWITEM (CAR OLDITEMS] then (CONS NEWITEM (for ITEM in OLDITEMS as I from 2 to DINFO.HISTORY.LENGTH collect ITEM)) else OLDITEMS))) (replace (DINFOGRAPH HISTORY.ITEMS) of GRAPH with ITEMS) (AND OLDWINDOW (PROGN (DETACHWINDOW OLDWINDOW) (CLOSEW OLDWINDOW))) (AND DISPLAY? ITEMS (LET [(HISTORYW (ATTACHMENU (create MENU MENUFONT _ (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT) TITLE _ "History" CENTERFLG _ T MENUCOLUMNS _ 1 ITEMS _ ITEMS WHENSELECTEDFN _ (FUNCTION DINFO.HISTORIC.UPDATE)) DINFOW 'LEFT 'TOP] (replace (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH with HISTORYW]) (DINFO.HISTORIC.UPDATE [LAMBDA (ITEM MENU BUTTONS) (* drc%: "25-Jan-86 18:24") (LET* [(ID (CAADR ITEM)) (SEL (CADADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (GRAPH (WINDOWPROP WINDOW 'DINFOGRAPH)) (NODE (FASSOC ID (fetch (DINFOGRAPH NODELST) of GRAPH] (if (NOT (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T)) then (FLASHWINDOW WINDOW) (PROMPTPRINT "DInfo is busy") elseif (NULL NODE) then (PRINTOUT (GETPROMPTWINDOW WINDOW) T "This node no longer exists") else (DINFO.UPDATE GRAPH NODE SEL]) ) (DEFINEQ (DINFO.UPDATE.GRAPH.DISPLAY [LAMBDA (DINFO.GRAPH NODE FORCE?) (* drc%: "27-Jan-86 16:19") (LET [(DINFOW (fetch (DINFOGRAPH WINDOW) of DINFO.GRAPH)) (LOCATION (CONS (fetch (DINFONODE PARENT) of NODE) (fetch (DINFONODE CHILDREN) of NODE] (if (AND (NOT FORCE?) (EQUAL LOCATION (fetch (DINFOGRAPH LAST.GRAPH.LOCATION) of DINFO.GRAPH))) then (* don't need to relayout grapher display --  just change which node is inverted.) (DINFO.INVERT.NODE (fetch (DINFOGRAPH GRAPH.WINDOW) of DINFO.GRAPH) NODE DINFO.GRAPH) else (DINFO.SHOWGRAPH (DINFO.LAYOUTGRAPH DINFO.GRAPH NODE) DINFO.GRAPH)) (replace (DINFOGRAPH LAST.GRAPH.LOCATION) of DINFO.GRAPH with LOCATION) (WINDOWPROP (fetch (DINFOGRAPH GRAPH.WINDOW) of DINFO.GRAPH) 'TITLE (CONCAT (fetch (DINFOGRAPH NAME) of DINFO.GRAPH) " - " (fetch (DINFONODE LABEL) of (fetch (DINFOGRAPH CURRENTNODE) of DINFO.GRAPH]) (DINFO.UPDATE.FROM.GRAPH [LAMBDA (GRAPHER.NODE GRAPH.WINDOW) (* drc%: "12-Dec-85 18:34") (AND GRAPHER.NODE (ADD.PROCESS `(DINFO.UPDATE (QUOTE %, (WINDOWPROP GRAPH.WINDOW 'DINFOGRAPH)) (QUOTE %, (fetch (GRAPHNODE NODEID) of GRAPHER.NODE))) 'NAME "DInfo From Graph"]) (DINFO.GET.GRAPH.WINDOW [LAMBDA (GRAPH REGION) (* drc%: "25-Jan-86 18:05") (LET ((W (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) (COND ((WINDOWP W)) (T (SETQ W (DINFO.CREATE.GRAPH.WINDOW GRAPH REGION)) [WINDOWPROP W 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'DINFOGRAPH NIL] (replace (DINFOGRAPH GRAPH.WINDOW) of GRAPH with W))) (WINDOWPROP W 'DINFOGRAPH GRAPH) W]) (DINFO.CREATE.GRAPH.WINDOW [LAMBDA (GRAPH REGION) (* drc%: "25-Jan-86 17:49") (LET* ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (DINFOREGION (WINDOWPROP DINFOW 'REGION)) (LEFT (DIFFERENCE (DIFFERENCE (fetch (REGION LEFT) of DINFOREGION) (fetch (REGION WIDTH) of REGION)) 10)) (BOTTOM (DIFFERENCE (DIFFERENCE (fetch (REGION BOTTOM) of DINFOREGION) (fetch (REGION HEIGHT) of REGION)) 50))) (CREATEW (CREATEREGION (if (GEQ LEFT 0) then LEFT else (RAND 0 10)) (if (GEQ BOTTOM 0) then BOTTOM else (RAND 0 10)) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION)) NIL NIL T]) (DINFO.SHOWGRAPH [LAMBDA (GRAPHER.GRAPH DINFO.GRAPH) (* drc%: "27-Jan-86 16:15") (LET* [(GRAPH.REGION (GRAPHREGION GRAPHER.GRAPH)) (GRAPH.WINDOW (DINFO.GET.GRAPH.WINDOW DINFO.GRAPH GRAPH.REGION)) (WINDOW.REGION (WINDOWPROP GRAPH.WINDOW 'REGION] [SHAPEW GRAPH.WINDOW (LET [(LEFT (fetch (REGION LEFT) of WINDOW.REGION)) (BOTTOM (fetch (REGION BOTTOM) of WINDOW.REGION)) (HEIGHT (HEIGHTIFWINDOW (fetch (REGION HEIGHT) of GRAPH.REGION) T)) (WIDTH (WIDTHIFWINDOW (fetch (REGION WIDTH) of GRAPH.REGION] (create REGION LEFT _ LEFT BOTTOM _ BOTTOM HEIGHT _ (if (GEQ (IPLUS BOTTOM HEIGHT) SCREENHEIGHT) then (IDIFFERENCE SCREENHEIGHT BOTTOM) else HEIGHT) WIDTH _ (if (GEQ (IPLUS LEFT WIDTH) SCREENWIDTH) then (IDIFFERENCE SCREENWIDTH LEFT) else WIDTH] (SHOWGRAPH GRAPHER.GRAPH GRAPH.WINDOW (FUNCTION DINFO.UPDATE.FROM.GRAPH) (FUNCTION DINFO.UPDATE.FROM.GRAPH]) (DINFO.INVERT.NODE [LAMBDA (WINDOW DINFO.NODE DINFO.GRAPH) (* drc%: "25-Jan-86 18:24") (LET* ((NODE (for NODE in (fetch (GRAPH GRAPHNODES) of (WINDOWPROP WINDOW 'GRAPH)) thereis (EQ (fetch (GRAPHNODE NODEID) of NODE) DINFO.NODE))) (LAST.NODE (fetch (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH))) (replace (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH with NODE) (if (NEQ NODE LAST.NODE) then (replace (GRAPHNODE NODELABELSHADE) of NODE with BLACKSHADE) (* (PRINTDISPLAYNODE NODE  (create POSITION XCOORD _ 0 YCOORD _ 0)  WINDOW)) (replace (GRAPHNODE NODELABELSHADE) of LAST.NODE with WHITESHADE) (* (PRINTDISPLAYNODE LAST.NODE  (create POSITION XCOORD _ 0 YCOORD _ 0)  WINDOW)) (REDISPLAYW WINDOW) else (OPENW WINDOW]) (DINFO.LAYOUTGRAPH [LAMBDA (DINFO.GRAPH NODE) (* drc%: "25-Jan-86 18:20") (LET* [(WINDOW (fetch (DINFOGRAPH WINDOW) of DINFO.GRAPH)) (FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of DINFO.GRAPH)) MENUFONT)) (NODELST (fetch (DINFOGRAPH NODELST) of DINFO.GRAPH)) (CHILDREN (for ID in (fetch (DINFONODE CHILDREN) of NODE) collect (FASSOC ID NODELST))) [CHILD.GRAPHER.NODES (for CHILD in CHILDREN collect (create GRAPHNODE NODEID _ CHILD NODELABEL _ (fetch (DINFONODE LABEL) of CHILD] (GRAPHER.NODE (create GRAPHNODE NODELABELSHADE _ BLACKSHADE NODEID _ NODE TONODES _ CHILDREN NODELABEL _ (fetch (DINFONODE LABEL) of NODE] (replace (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH with GRAPHER.NODE) (* so DINFO.INVERT.NODE will work  right) (if (fetch (DINFONODE PARENT) of NODE) then (LET* ((PARENT (FASSOC (fetch (DINFONODE PARENT) of NODE) NODELST)) (SIBLINGS (for ID in (fetch (DINFONODE CHILDREN) of PARENT) collect (FASSOC ID NODELST))) [SIBLING.GRAPHER.NODES (for SIBLING in SIBLINGS collect (if (EQ (fetch (DINFONODE ID) of SIBLING) (fetch (DINFONODE ID) of NODE)) then GRAPHER.NODE else (create GRAPHNODE NODEID _ SIBLING NODELABEL _ (fetch (DINFONODE LABEL) of SIBLING] (PARENT.GRAPHER.NODE (create GRAPHNODE NODEID _ PARENT NODELABEL _ (fetch (DINFONODE LABEL) of PARENT) TONODES _ SIBLINGS))) (LAYOUTGRAPH (CONS PARENT.GRAPHER.NODE (NCONC SIBLING.GRAPHER.NODES CHILD.GRAPHER.NODES)) (LIST PARENT) NIL FONT)) else (LAYOUTGRAPH (CONS GRAPHER.NODE CHILD.GRAPHER.NODES) (LIST NODE) NIL FONT]) ) (DEFINEQ (DINFO.UPDATE.TEXT.DISPLAY [LAMBDA (GRAPH NODE SEL OFF?) (* drc%: "25-Jan-86 18:18") (LET ((WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (FILENAME (DINFO.GET.FILENAME GRAPH NODE)) (FROM (fetch (DINFONODE FROMBYTE) of NODE)) (TO (fetch (DINFONODE TOBYTE) of NODE)) (PROPS (APPEND (LIST 'READONLY T 'NOTITLE T 'TITLEMENUFN 'DINFO.TITLEMENUFN) (fetch (DINFOGRAPH TEXTPROPS) of GRAPH))) (OLD.TEXTSTREAM (WINDOWPROP (fetch (DINFOGRAPH WINDOW) of GRAPH) 'TEXTSTREAM)) TEXTSTREAM FULLFILENAME) (* Default directory and host.) (if (OR OFF? (NULL FILENAME)) then (OPENTEXTSTREAM (if OFF? then "" else "This node has no text") WINDOW NIL NIL PROPS) (replace (DINFOGRAPH LAST.TEXT) of GRAPH with NIL) elseif (SETQ FULLFILENAME (MKATOM (INFILEP FILENAME))) then (SETQ TEXTSTREAM (DINFO.OPENTEXTSTREAM FULLFILENAME WINDOW FROM TO PROPS)) (DINFO.SHOWSEL TEXTSTREAM SEL) else (OPENTEXTSTREAM (CONCAT "Sorry, can't find the text for this node." (MKSTRING (CHARACTER (CHARCODE CR))) "Missing file is: " FILENAME) WINDOW NIL NIL PROPS) (replace (DINFOGRAPH LAST.TEXT) of GRAPH with NIL)) (CLOSEF? OLD.TEXTSTREAM) (WINDOWPROP WINDOW 'ICONFN 'DINFO.ICONFN) (WINDOWPROP WINDOW 'TEDIT.TITLEMENUFN 'DINFO.TITLEMENUFN]) (DINFO.TITLEMENUFN [LAMBDA (DINFOW) (* drc%: "25-Jan-86 18:19") (* * This is the TEdit TITLEMENUFN for a DInfo Window.  Uses the MENUFN of graph, defaulting to DINFO.DEFAULT.MENU.) (LET [(GRAPH (WINDOWPROP DINFOW 'DINFOGRAPH] (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then [LET ((MENUFN (fetch (DINFOGRAPH MENUFN) of GRAPH))) (if (FGETD MENUFN) then (OR (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH) (DINFO.ADD.FMENU GRAPH)) (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (APPLY* MENUFN GRAPH)) else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (DINFO.DEFAULT.MENU GRAPH] else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) (DINFO.OPENTEXTSTREAM [LAMBDA (FILE WINDOW FROM TO PROPS) (* drc%: "25-Jan-86 18:24") (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW WINDOW)) (LET ((TEXTSTREAM (WINDOWPROP WINDOW 'TEXTSTREAM)) (THIS.TEXT (LIST FILE FROM TO))) (if (AND (EQUAL THIS.TEXT (fetch (DINFOGRAPH LAST.TEXT) of (DINFOGRAPH WINDOW))) TEXTSTREAM) then (* Same text, and its still there, so  do nothing.) TEXTSTREAM else (AND TEXTSTREAM (TEDIT.KILL TEXTSTREAM)) (CLEARW T) (CLEARW WINDOW) [RESETSAVE NIL `(AND RESETSTATE (WINDOWPROP %, WINDOW 'LAST.TEXT NIL] (PRINTOUT T "Fetching text from " FILE "...") (PROG1 (OPENTEXTSTREAM FILE WINDOW FROM TO PROPS) (PRINTOUT T "OK.") (replace (DINFOGRAPH LAST.TEXT) of (DINFOGRAPH WINDOW) with THIS.TEXT]) (DINFO.SHOWSEL [LAMBDA (TEXTSTREAM SEL) (* drc%: "16-Jan-86 21:30") (if (LISTP SEL) then (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM (CADR SEL) 0)) elseif (STRINGP SEL) then [LET ((CHAR# (TEDIT.FIND TEXTSTREAM SEL))) (if CHAR# then (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM CHAR# (NCHARS SEL) NIL T] else (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 0]) (DINFO.GET.FILENAME [LAMBDA (GRAPH NODE) (* drc%: "10-Jan-86 14:47") (* * returns the filename of the documentation for NODE in GRAPH.  Defaults HOST and DIRECTORY to that of graph) (LET ((FILE (fetch (DINFONODE FILE) of NODE))) (AND FILE (PACKFILENAME 'HOST (OR (FILENAMEFIELD FILE 'HOST) (fetch (DINFOGRAPH DEFAULTHOST) of GRAPH)) 'DEVICE (OR (FILENAMEFIELD FILE 'DEVICE) (fetch (DINFOGRAPH DEFAULTDEVICE) of GRAPH)) 'DIRECTORY (OR (FILENAMEFIELD FILE 'DIRECTORY) (fetch (DINFOGRAPH DEFAULTDIR) of GRAPH)) 'BODY FILE]) ) (ADDTOVAR BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH) "Open a DInfo window for browsing documentation.")) (RPAQQ BackgroundMenu NIL) (RPAQ? DINFO.GRAPHS ) (RPAQ? DINFOMODES '(TEXT GRAPH)) (RPAQ? DINFO.HISTORY.LENGTH 20) (RPAQ? \DINFO.MAX.MENU.LEN 10) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DINFO.GRAPH.FILES DINFOMODES DINFO.HISTORY.LENGTH \DINFO.MAX.MENU.LEN) ) (PUTPROPS DINFO FILETYPE :COMPILE-FILE) (SETTEMPLATE 'DINFOGRAPHPROP 'MACRO) (PUTPROPS DINFO COPYRIGHT ("Xerox Corporation" 1985 1986 1987 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6436 23262 (DINFO 6446 . 8060) (DINFO.UPDATE 8062 . 10926) (DINFOGRAPH 10928 . 11346) ( DINFO.SPECIAL.UPDATE 11348 . 13046) (DINFO.READ.GRAPH 13048 . 14903) (DINFO.WRITE.GRAPH 14905 . 15995) (DINFO.SELECT.GRAPH 15997 . 16904) (DINFO.DEFAULT.MENU 16906 . 19430) (DINFO.FIND 19432 . 21816) ( DINFO.LOOKUP 21818 . 23260)) (23263 25957 (DINFO.READ.KOTO.GRAPH 23273 . 25955)) (25958 28272 ( DINFO.SETUP.WINDOW 25968 . 26649) (DINFO.CLOSEFN 26651 . 27084) (DINFO.SHRINKFN 27086 . 27282) ( DINFO.EXPANDFN 27284 . 27841) (DINFO.ICONFN 27843 . 28270)) (28273 39121 (DINFO.ADD.FMENU 28283 . 29378) (DINFO.CREATE.FMENU 29380 . 32917) (DINFO.FMW.CLOSEFN 32919 . 33764) (DINFO.FMENU.HANDLER 33766 . 34405) (DINFO.UPDATE.FMENU 34407 . 36612) (DINFO.TOGGLE.MENU 36614 . 37204) (DINFO.TOGGLE.GRAPH 37206 . 37705) (DINFO.TOGGLE.HISTORY 37707 . 38251) (DINFO.TOGGLE.TEXT 38253 . 39119)) (39122 46820 ( DINFO.UPDATE.MENU.DISPLAY 39132 . 43152) (DINFO.UPDATE.FROM.MENU 43154 . 43453) (DINFO.UPDATE.HISTORY 43455 . 45989) (DINFO.HISTORIC.UPDATE 45991 . 46818)) (46821 56987 (DINFO.UPDATE.GRAPH.DISPLAY 46831 . 48149) (DINFO.UPDATE.FROM.GRAPH 48151 . 48594) (DINFO.GET.GRAPH.WINDOW 48596 . 49181) ( DINFO.CREATE.GRAPH.WINDOW 49183 . 50300) (DINFO.SHOWGRAPH 50302 . 52027) (DINFO.INVERT.NODE 52029 . 53417) (DINFO.LAYOUTGRAPH 53419 . 56985)) (56988 62844 (DINFO.UPDATE.TEXT.DISPLAY 56998 . 58859) ( DINFO.TITLEMENUFN 58861 . 59986) (DINFO.OPENTEXTSTREAM 59988 . 61204) (DINFO.SHOWSEL 61206 . 61939) ( DINFO.GET.FILENAME 61941 . 62842))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "14-Feb-2021 23:11:36"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;5 64800 changes to%: (VARS DINFOCOMS) previous date%: "14-Feb-2021 14:55:19" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;4) (* ; " Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation. ") (PRETTYCOMPRINT DINFOCOMS) (RPAQQ DINFOCOMS ((FILES TEDIT GRAPHER) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DINFOGRAPH DINFONODE) (FUNCTIONS DINFOGRAPHPROP)) (INITRECORDS DINFOGRAPH) (FNS (* ; "Primary functions") DINFO DINFO.UPDATE DINFOGRAPH DINFO.SPECIAL.UPDATE DINFO.READ.GRAPH DINFO.WRITE.GRAPH DINFO.SELECT.GRAPH DINFO.DEFAULT.MENU DINFO.FIND DINFO.LOOKUP) (FNS (* ; "Koto compatability") DINFO.READ.KOTO.GRAPH) (FNS (* ; "Window functions") DINFO.SETUP.WINDOW DINFO.CLOSEFN DINFO.SHRINKFN DINFO.EXPANDFN DINFO.ICONFN) (FNS (* ; "FreeMenu functions") DINFO.ADD.FMENU DINFO.CREATE.FMENU DINFO.FMW.CLOSEFN DINFO.FMENU.HANDLER DINFO.UPDATE.FMENU DINFO.TOGGLE.MENU DINFO.TOGGLE.GRAPH DINFO.TOGGLE.HISTORY DINFO.TOGGLE.TEXT) (FNS (* ; "Other menu functions") DINFO.UPDATE.MENU.DISPLAY DINFO.UPDATE.FROM.MENU DINFO.UPDATE.HISTORY DINFO.HISTORIC.UPDATE) (FNS (* ; "Interface to GRAPHER") DINFO.UPDATE.GRAPH.DISPLAY DINFO.UPDATE.FROM.GRAPH DINFO.GET.GRAPH.WINDOW DINFO.CREATE.GRAPH.WINDOW DINFO.SHOWGRAPH DINFO.INVERT.NODE DINFO.LAYOUTGRAPH) (FNS (* ; "Interface to TEdit") DINFO.UPDATE.TEXT.DISPLAY DINFO.TITLEMENUFN DINFO.OPENTEXTSTREAM DINFO.SHOWSEL DINFO.GET.FILENAME) (ADDVARS (BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH) "Open a DInfo window for browsing documentation."))) (VARS (BackgroundMenu)) (INITVARS (DINFO.GRAPHS) (DINFOMODES '(TEXT GRAPH)) (DINFO.HISTORY.LENGTH 20) (\DINFO.MAX.MENU.LEN 10)) (GLOBALVARS DINFO.GRAPH.FILES DINFOMODES DINFO.HISTORY.LENGTH \DINFO.MAX.MENU.LEN) (PROP (FILETYPE) DINFO) (DECLARE%: DONTCOPY (TEMPLATES DINFOGRAPHPROP)))) (FILESLOAD TEDIT GRAPHER) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE DINFOGRAPH (NAME NODELST TOPNODEID CURRENTNODE USERDATA TEXTPROPS FREEMENUITEMS LOOKUPFN MENUFN DEFAULTHOST DEFAULTDEVICE DEFAULTDIR MONITORLOCK DINFO.MENU WINDOW MENUFONT FMENU.WINDOW GRAPH.WINDOW HISTORY.MENU.WINDOW SUBNODE.MENU.WINDOW LAST.TEXT LAST.INVERTED.NODE LAST.GRAPH.LOCATION HISTORY.ITEMS FIND.STRING LOOKUP.STRING) (SYSTEM)) (RECORD DINFONODE (ID LABEL FILE FROMBYTE TOBYTE PARENT CHILDREN NEXTNODE PREVIOUSNODE USERDATA) (SYSTEM)) ) (/DECLAREDATATYPE 'DINFOGRAPH '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((DINFOGRAPH 0 POINTER) (DINFOGRAPH 2 POINTER) (DINFOGRAPH 4 POINTER) (DINFOGRAPH 6 POINTER) (DINFOGRAPH 8 POINTER) (DINFOGRAPH 10 POINTER) (DINFOGRAPH 12 POINTER) (DINFOGRAPH 14 POINTER) (DINFOGRAPH 16 POINTER) (DINFOGRAPH 18 POINTER) (DINFOGRAPH 20 POINTER) (DINFOGRAPH 22 POINTER) (DINFOGRAPH 24 POINTER) (DINFOGRAPH 26 POINTER) (DINFOGRAPH 28 POINTER) (DINFOGRAPH 30 POINTER) (DINFOGRAPH 32 POINTER) (DINFOGRAPH 34 POINTER) (DINFOGRAPH 36 POINTER) (DINFOGRAPH 38 POINTER) (DINFOGRAPH 40 POINTER) (DINFOGRAPH 42 POINTER) (DINFOGRAPH 44 POINTER) (DINFOGRAPH 46 POINTER) (DINFOGRAPH 48 POINTER) (DINFOGRAPH 50 POINTER)) '52) (DEFMACRO DINFOGRAPHPROP (GRAPH PROP &OPTIONAL (NEW-VALUE NIL NEW-VALUE-SUPPLIED)) [LET [(REAL-FIELD (AND (LISTP PROP) (EQ (CAR PROP) 'QUOTE) (FMEMB (CADR PROP) (RECORDFIELDNAMES 'DINFOGRAPH T)) (CADR PROP] (IF NEW-VALUE-SUPPLIED THEN [IF REAL-FIELD THEN `(REPLACE (DINFOGRAPH ,REAL-FIELD) OF ,GRAPH WITH ,NEW-VALUE) ELSE `(LET* ((SI::$GRAPH$ ,GRAPH) (SI::$USERDATA$ (FETCH (DINFOGRAPH USERDATA) OF SI::$GRAPH$)) (SI::$PROP$ ,PROP) (SI::$NEW-VALUE$ ,NEW-VALUE)) (IF (LISTP SI::$USERDATA$) THEN (LISTPUT SI::$USERDATA$ SI::$PROP$ SI::$NEW-VALUE$) ELSE (REPLACE (DINFOGRAPH USERDATA) OF SI::$GRAPH$ WITH (LIST SI::$PROP$ SI::$NEW-VALUE$)) SI::$NEW-VALUE$] ELSE (IF REAL-FIELD THEN `(FETCH (DINFOGRAPH ,REAL-FIELD) OF ,GRAPH) ELSE `(LISTGET (FETCH (DINFOGRAPH USERDATA) OF ,GRAPH) ,PROP]) ) (/DECLAREDATATYPE 'DINFOGRAPH '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((DINFOGRAPH 0 POINTER) (DINFOGRAPH 2 POINTER) (DINFOGRAPH 4 POINTER) (DINFOGRAPH 6 POINTER) (DINFOGRAPH 8 POINTER) (DINFOGRAPH 10 POINTER) (DINFOGRAPH 12 POINTER) (DINFOGRAPH 14 POINTER) (DINFOGRAPH 16 POINTER) (DINFOGRAPH 18 POINTER) (DINFOGRAPH 20 POINTER) (DINFOGRAPH 22 POINTER) (DINFOGRAPH 24 POINTER) (DINFOGRAPH 26 POINTER) (DINFOGRAPH 28 POINTER) (DINFOGRAPH 30 POINTER) (DINFOGRAPH 32 POINTER) (DINFOGRAPH 34 POINTER) (DINFOGRAPH 36 POINTER) (DINFOGRAPH 38 POINTER) (DINFOGRAPH 40 POINTER) (DINFOGRAPH 42 POINTER) (DINFOGRAPH 44 POINTER) (DINFOGRAPH 46 POINTER) (DINFOGRAPH 48 POINTER) (DINFOGRAPH 50 POINTER)) '52) (DEFINEQ (DINFO [LAMBDA (GRAPH.OR.FILE WINDOW.OR.REGION SETUP.ONLY? NO.FREEMENU?) (* drc%: "25-Jan-86 18:23") (* Starts a DInfo browser.) (RESETLST (LET ((W (OR (WINDOWP WINDOW.OR.REGION) (AND (REGIONP WINDOW.OR.REGION) (CREATEW WINDOW.OR.REGION "DInfo" NIL T)) (AND (type? DINFOGRAPH GRAPH.OR.FILE) (WINDOWP (fetch (DINFOGRAPH WINDOW) of GRAPH.OR.FILE))) (CREATEW NIL "DInfo"))) GRAPH MONITORLOCK) (OPENW W) [SETQ GRAPH (if (type? DINFOGRAPH GRAPH.OR.FILE) then GRAPH.OR.FILE else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW W)) (DINFO.READ.GRAPH GRAPH.OR.FILE] [SETQ MONITORLOCK (OR (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) (replace (DINFOGRAPH MONITORLOCK) of GRAPH with (CREATE.MONITORLOCK "DInfo"] (RESETSAVE NIL (LIST 'RELEASE.MONITORLOCK MONITORLOCK)) (OBTAIN.MONITORLOCK MONITORLOCK) (DINFO.SETUP.WINDOW GRAPH W NO.FREEMENU?) (OR SETUP.ONLY? (DINFO.UPDATE GRAPH NIL NIL T)) GRAPH]) (DINFO.UPDATE [LAMBDA (GRAPH NEW.NODE SEL FORCE?) (* jow "20-May-86 15:14") (* * Called to visit a NEW.NODE in GRAPH, or to just make sure that the display  of GRAPH is current.) (LET ([NODE (OR NEW.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH) (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) (fetch (DINFOGRAPH NODELST) of GRAPH] (PREVIOUS.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (OPENW WINDOW) (WINDOWPROP WINDOW 'DINFOGRAPH GRAPH) (OR (FMEMB NODE (fetch (DINFOGRAPH NODELST) of GRAPH)) (ERROR NODE "NOT IN NODELST")) (LET ((FMENU.WINDOW (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH)) (MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH))) [RESETLST (RESETSAVE NIL (LIST 'RELEASE.MONITORLOCK MONITORLOCK)) (if (NOT (OBTAIN.MONITORLOCK MONITORLOCK T)) then (* somebody else is messing with this  graph.) (FLASHWINDOW WINDOW) (PROMPTPRINT "DInfo is busy") elseif (NULL FMENU.WINDOW) then (replace (DINFOGRAPH CURRENTNODE) of GRAPH with NODE) (* FreeMenu turned off, so just  display text) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NODE SEL) else (* We've got a FreeMenu, so update  away!) (DINFO.UPDATE.FMENU GRAPH NODE) (LET ((STATUS (FM.GETSTATE FMENU.WINDOW))) (replace (DINFOGRAPH CURRENTNODE) of GRAPH with NODE) (AND (LISTGET STATUS 'GRAPH) (DINFO.UPDATE.GRAPH.DISPLAY GRAPH NODE FORCE?)) (AND (LISTGET STATUS 'MENU) (DINFO.UPDATE.MENU.DISPLAY GRAPH NODE)) (AND (LISTGET STATUS 'TEXT) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NODE SEL)) (DINFO.UPDATE.HISTORY GRAPH NODE SEL (LISTGET STATUS 'HISTORY] (CLEARW (GETPROMPTWINDOW WINDOW]) (DINFOGRAPH [LAMBDA (X) (* drc%: " 8-Jan-86 11:12") (if (type? DINFOGRAPH X) then X elseif (AND (WINDOWP X) (WINDOWPROP X 'DINFOGRAPH)) elseif (AND (WINDOWP X) (WINDOWPROP X 'MAINWINDOW)) then (WINDOWPROP (WINDOWPROP X 'MAINWINDOW) 'DINFOGRAPH]) (DINFO.SPECIAL.UPDATE [LAMBDA (TYPE GRAPH) (* drc%: "25-Jan-86 18:26") (* * Do a TYPE update of Graph, where TYPE is one of Top, Parent, Previous or  Next.) (LET* [(DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (CURRENT.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (NEW.NODE (FASSOC (SELECTQ TYPE (Top (fetch (DINFOGRAPH TOPNODEID) of GRAPH)) (Parent (fetch (DINFONODE PARENT) of CURRENT.NODE)) (Next (fetch (DINFONODE NEXTNODE) of CURRENT.NODE)) (Previous (fetch (DINFONODE PREVIOUSNODE) of CURRENT.NODE)) NIL) (fetch (DINFOGRAPH NODELST) of GRAPH] (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then (if NEW.NODE then (PROCESSPROP (THIS.PROCESS) 'NAME (CONCAT "DInfo " TYPE)) (DINFO.UPDATE GRAPH NEW.NODE) else (* TYPE of Top! or Node! will sound silly here, but should never happen.) (printout (GETPROMPTWINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) T "This node has no " TYPE)) else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) (DINFO.READ.GRAPH [LAMBDA (FILE QUIETFLG) (* drc%: "25-Jan-86 18:17") (* Reads a file written by DINFO.WRITE.GRAPH.  Returns the DInfo graph stored on FILE.) (OR QUIETFLG (printout T T "Reading " (FILENAMEFIELD FILE 'NAME) " graph...")) (LET* ((FULLFILENAME (INFILEP FILE)) [DATA (CDR (READFILE (OR FULLFILENAME (ERROR "FILE NOT FOUND" FILE] (GRAPH (create DINFOGRAPH))) (* fields stored on file) (replace (DINFOGRAPH TOPNODEID) of GRAPH with (LISTGET DATA 'TOPNODEID)) (replace (DINFOGRAPH TEXTPROPS) of GRAPH with (LISTGET DATA 'TEXTPROPS)) (replace (DINFOGRAPH LOOKUPFN) of GRAPH with (LISTGET DATA 'LOOKUPFN)) (replace (DINFOGRAPH MENUFN) of GRAPH with (LISTGET DATA 'MENUFN)) (replace (DINFOGRAPH FREEMENUITEMS) of GRAPH with (LISTGET DATA 'FREEMENUITEMS)) (replace (DINFOGRAPH NODELST) of GRAPH with (LISTGET DATA 'NODELST)) (replace (DINFOGRAPH USERDATA) of GRAPH with (LISTGET DATA 'USERDATA)) (* fields filled in at read time) (replace (DINFOGRAPH NAME) of GRAPH with (FILENAMEFIELD FULLFILENAME 'NAME)) (replace (DINFOGRAPH DEFAULTHOST) of GRAPH with (FILENAMEFIELD FULLFILENAME 'HOST)) (replace (DINFOGRAPH DEFAULTDEVICE) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DEVICE)) (replace (DINFOGRAPH DEFAULTDIR) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DIRECTORY)) (OR QUIETFLG (printout T "OK.")) GRAPH]) (DINFO.WRITE.GRAPH [LAMBDA (GRAPH FILE) (* drc%: "25-Jan-86 18:16") (* Writes a DInfo graph to a file for reading by DINFO.READ.GRAPH.  Returns the full file name of the file.) (* dump it out as a props list) (WRITEFILE (LIST 'TOPNODEID (fetch (DINFOGRAPH TOPNODEID) of GRAPH) 'TEXTPROPS (fetch (DINFOGRAPH TEXTPROPS) of GRAPH) 'LOOKUPFN (fetch (DINFOGRAPH LOOKUPFN) of GRAPH) 'MENUFN (fetch (DINFOGRAPH MENUFN) of GRAPH) 'FREEMENUITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH) 'NODELST (fetch (DINFOGRAPH NODELST) of GRAPH) 'USERDATA (fetch (DINFOGRAPH USERDATA) of GRAPH)) FILE]) (DINFO.SELECT.GRAPH [LAMBDA NIL (* drc%: "24-Jan-86 13:25") (* * This is called when DInfo is selected from the Background Menu.) (DECLARE (GLOBALVARS DINFO.GRAPHS)) (ALLOW.BUTTON.EVENTS) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (LET [(GRAPH (if (NULL DINFO.GRAPHS) then (PROMPTPRINT "No Graphs installed -- load HelpSys or DInfoEdit") elseif (NULL (CDR DINFO.GRAPHS)) then (EVAL (CADAR DINFO.GRAPHS)) else (MENU (create MENU CENTERFLG _ T TITLE _ "Select Graph" ITEMS _ DINFO.GRAPHS] (AND GRAPH (DINFO GRAPH]) (DINFO.DEFAULT.MENU [LAMBDA (GRAPH) (* jow "15-Jul-86 17:36") (* * This is the default MENUFN for DInfo graphs.) (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (CLEARW (GETPROMPTWINDOW DINFOW)) (LET [(TYPE (MENU (OR (fetch (DINFOGRAPH DINFO.MENU) of GRAPH) (replace (DINFOGRAPH DINFO.MENU) of GRAPH with (create MENU ITEMS _ '(("Top" 'Top "Visit the top node in the graph" ) ("Parent" 'Parent "Visit the parent of the current node" ) ("Previous" 'Previous "Visit the node before this node") ("Next " 'Next "Visit the node following this node") ("Find" 'Find "Search the text of this node") ("Lookup" 'Lookup "Lookup a new term in this graph") ("Expanded Menu" 'FreeMenu "Add an expanded options menu.")) CENTERFLG _ T MENUFONT _ (FONTCREATE 'HELVETICA 10 'BOLD] (if TYPE then (PROCESSPROP (THIS.PROCESS) 'NAME (CONCAT "DInfo " TYPE)) (SELECTQ TYPE ((Top Parent Previous Next) (DINFO.SPECIAL.UPDATE TYPE GRAPH)) (Find (DINFO.FIND GRAPH)) (Lookup (DINFO.LOOKUP GRAPH '(LEFT))) (FreeMenu (DINFO.ADD.FMENU GRAPH) (DINFO.UPDATE GRAPH)) NIL]) (DINFO.FIND [LAMBDA (GRAPH BUTTONS) (* drc%: "25-Jan-86 18:23") (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (if (NOT (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T)) then (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy") else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (TERPRI T) (LET ([STRING (if (AND (FMEMB 'MIDDLE BUTTONS) (fetch (DINFOGRAPH FIND.STRING) of GRAPH)) else (PROMPTFORWORD "Find: " (fetch (DINFOGRAPH FIND.STRING) of GRAPH) NIL NIL NIL 'TTY (CONSTANT (CHARCODE (EOL ESCAPE LF] (TEXTSTREAM (WINDOWPROP DINFOW 'TEXTSTREAM)) PAIR) (replace (DINFOGRAPH FIND.STRING) of GRAPH with STRING) (if STRING then (PRINTOUT T " Searching...") (if (SETQ PAIR (TEDIT.FIND TEXTSTREAM STRING NIL NIL T)) then (printout T "OK.") (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SHOWSEL TEXTSTREAM T (TEDIT.SETSEL TEXTSTREAM (CAR PAIR) (NCHARS STRING) 'RIGHT T))) else (printout T "not found.") (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 0]) (DINFO.LOOKUP [LAMBDA (GRAPH BUTTONS) (* drc%: "25-Jan-86 18:22") (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then [RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (LET ((LOOKUPFN (fetch (DINFOGRAPH LOOKUPFN) of GRAPH))) (if LOOKUPFN then (CLEARW T) (LET* [(OLD.STRING (fetch (DINFOGRAPH LOOKUP.STRING) of GRAPH)) (STRING (if (AND OLD.STRING (FMEMB 'MIDDLE BUTTONS)) then OLD.STRING else (PROMPTFORWORD "Lookup: " OLD.STRING NIL NIL NIL 'TTY (CONSTANT (CHARCODE (EOL ESCAPE LF] (replace (DINFOGRAPH LOOKUP.STRING) of GRAPH with STRING) (AND STRING (APPLY* LOOKUPFN STRING GRAPH))) else (PRINTOUT T T "The " (fetch (DINFOGRAPH NAME) of GRAPH) " graph has no LOOKUPFN."] else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) ) (DEFINEQ (DINFO.READ.KOTO.GRAPH [LAMBDA (FILE QUIETFLG) (* drc%: " 4-Feb-86 11:27") (* Reads a file written by Koto DINFO.WRITE.GRAPH and returns a Lute  DINFOGRAPH. Thus, (DINFO.WRITE.GRAPH (DINFO.READ.KOTO.GRAPH ) )  will convert the Koto format graph in to a Lute format graph in  .) (OR QUIETFLG (printout T T "Reading " (FILENAMEFIELD FILE 'NAME) " graph...")) (LET* ((FULLFILENAME (INFILEP FILE)) [DATA (CDR (READFILE (OR FULLFILENAME (ERROR "FILE NOT FOUND" FILE] (GRAPH (create DINFOGRAPH))) (* in Koto we just wrote out the  DINFOGRAPH record) (for FIELD in DATA as N from 1 to 11 do (* fields stored on file) (SELECTQ N ((1 4 5 6 10 11)) (2 (replace (DINFOGRAPH NODELST) of GRAPH with FIELD)) (3 (replace (DINFOGRAPH TOPNODEID) of GRAPH with FIELD)) (7 (replace (DINFOGRAPH TEXTPROPS) of GRAPH with FIELD)) (8 (replace (DINFOGRAPH LOOKUPFN) of GRAPH with FIELD)) (9 (replace (DINFOGRAPH MENUFN) of GRAPH with FIELD)) (SHOULDNT))) (* fields filled in at read time) (replace (DINFOGRAPH NAME) of GRAPH with (FILENAMEFIELD FULLFILENAME 'NAME)) (replace (DINFOGRAPH DEFAULTHOST) of GRAPH with (FILENAMEFIELD FULLFILENAME 'HOST)) (replace (DINFOGRAPH DEFAULTDEVICE) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DEVICE)) (replace (DINFOGRAPH DEFAULTDIR) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DIRECTORY)) (OR QUIETFLG (printout T "OK.")) GRAPH]) ) (DEFINEQ (DINFO.SETUP.WINDOW [LAMBDA (GRAPH WINDOW NO.FREEMENU?) (* jow "10-Jun-86 15:29") (replace (DINFOGRAPH WINDOW) of GRAPH with WINDOW) (WINDOWPROP WINDOW 'DINFOGRAPH GRAPH) (DETACHALLWINDOWS WINDOW) (if (NOT NO.FREEMENU?) then (DINFO.ADD.FMENU GRAPH)) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NIL NIL T) (WINDOWPROP WINDOW 'TITLE (CONCAT (fetch (DINFOGRAPH NAME) of GRAPH) " DInfo")) (WINDOWADDPROP WINDOW 'CLOSEFN 'DINFO.CLOSEFN) (WINDOWADDPROP WINDOW 'SHRINKFN 'DINFO.SHRINKFN) (WINDOWADDPROP WINDOW 'EXPANDFN 'DINFO.EXPANDFN]) (DINFO.CLOSEFN [LAMBDA (W) (* drc%: "25-Jan-86 18:26") (LET [(GRAPH (WINDOWPROP W 'DINFOGRAPH] (if (type? DINFOGRAPH GRAPH) then (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH)) (* remove circularity...) (WINDOWPROP W 'DINFOGRAPH NIL]) (DINFO.SHRINKFN [LAMBDA (W) (* drc%: "25-Jan-86 18:26") (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of (DINFOGRAPH W]) (DINFO.EXPANDFN [LAMBDA (W) (* jow "15-Jul-86 17:00") (LET* ((GRAPH (DINFOGRAPH W)) (FMENU (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH))) (if (AND FMENU (LISTGET (FM.GETSTATE FMENU) 'GRAPH)) then (LET ((GRAPHW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) (OPENW GRAPHW) (TOTOPW W) (WINDOWPROP GRAPHW 'DINFOGRAPH GRAPH]) (DINFO.ICONFN [LAMBDA (W) (* drc%: "25-Jan-86 16:33") (OR (WINDOWPROP WINDOW 'ICON) (WINDOWPROP WINDOW 'ICON (TITLEDICONW TEDIT.TITLED.ICON.TEMPLATE (WINDOWPROP WINDOW 'TITLE) TEDIT.ICON.FONT NIL T)) (WINDOWPROP WINDOW 'ICON]) ) (DEFINEQ (DINFO.ADD.FMENU [LAMBDA (GRAPH) (* jow "20-May-86 15:41") (* * Add a DInfo FreeMenu to WINDOW. then update the FreeMenu's display.) (LET ((WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (FM.WINDOW (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH))) (if [AND (WINDOWP FM.WINDOW) (FMEMB FM.WINDOW (WINDOWPROP WINDOW 'ATTACHEDWINDOWS] then (OPENW FM.WINDOW) else (REMOVEPROMPTWINDOW WINDOW) (SETQ FM.WINDOW (OR (WINDOWP FM.WINDOW) (DINFO.CREATE.FMENU GRAPH))) (replace (DINFOGRAPH FMENU.WINDOW) of GRAPH with FM.WINDOW) (ATTACHWINDOW FM.WINDOW WINDOW) (WINDOWPROP FM.WINDOW 'FM.PROMPTWINDOW (GETPROMPTWINDOW WINDOW)) (WINDOWDELPROP FM.WINDOW 'PASSTOMAINCOMS 'CLOSEW) (WINDOWADDPROP FM.WINDOW 'CLOSEFN 'DINFO.FMW.CLOSEFN T) (DINFO.UPDATE.FMENU GRAPH]) (DINFO.CREATE.FMENU [LAMBDA (GRAPH) (* jow "15-Jul-86 17:39") (* * Makes a DInfo FreeMenu for GRAPH) (LET* [(ADD.ITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH)) (FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT)) (FM (FREEMENU `((PROPS FONT %, FONT) ((LABEL Node%: TYPE DISPLAY FONT (HELVETICA 10)) (ID NODE LABEL "" TYPE DISPLAY)) ((LABEL Top! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the top node") (ID TOP LABEL "" TYPE DISPLAY)) ((LABEL Parent! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the parent of the current node") (ID PARENT LABEL "" TYPE DISPLAY)) ((LABEL Previous! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the node previous to the current node") (ID PREVIOUS LABEL "" TYPE DISPLAY)) ((LABEL Next! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the node after the current node") (ID NEXT LABEL "" TYPE DISPLAY)) ((LABEL Display%: TYPE DISPLAY FONT (HELVETICA 10)) (LABEL Graph ID GRAPH INITSTATE %, (MEMB 'GRAPH DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.GRAPH FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the graph") (LABEL Menu ID MENU INITSTATE %, (MEMB 'MENU DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.MENU FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the subnode menu") (LABEL Text ID TEXT INITSTATE %, (MEMB 'TEXT DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.TEXT FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the text of the current node") (LABEL History ID HISTORY INITSTATE %, (MEMB 'HISTORY DINFOMODES) TYPE TOGGLE FONT (HELVETICA 10 BOLD) SELECTEDFN DINFO.TOGGLE.HISTORY MESSAGE "Toggle the display of the History Menu")) %, (APPEND '((LABEL Find! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Perform a string search in the selected text of the current node" ) (LABEL Lookup! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Lookup a term in this graph. LEFT for new term, MIDDLE to repeat last." )) ADD.ITEMS] (WINDOWPROP FM 'FM.DONTRESHAPE T) FM]) (DINFO.FMW.CLOSEFN [LAMBDA (W) (* drc%: "25-Jan-86 18:19") (* * CLOSEFN for a DInfo FreeMenu window.) (LET* ((DINFOW (WINDOWPROP W 'MAINWINDOW)) (GRAPH (DINFOGRAPH DINFOW))) (if GRAPH then (DETACHWINDOW W) (replace (DINFOGRAPH FMENU.WINDOW) of GRAPH with NIL) (DETACHWINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) (CLOSEW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) (DETACHWINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH)) (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH)) (REMOVEPROMPTWINDOW DINFOW]) (DINFO.FMENU.HANDLER [LAMBDA (ITEM WINDOW BUTTONS) (* drc%: "16-Jan-86 11:42") (* * Handle a command from the FreeMenu.) (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH)) (TYPE (MKATOM (SUBSTRING (FM.ITEMPROP ITEM 'LABEL) 1 -2] (SELECTQ TYPE ((Top Parent Previous Next) (DINFO.SPECIAL.UPDATE TYPE GRAPH)) (Find (DINFO.FIND GRAPH BUTTONS)) (Lookup (DINFO.LOOKUP GRAPH BUTTONS)) (SHOULDNT]) (DINFO.UPDATE.FMENU [LAMBDA (GRAPH NEW.NODE) (* jow "20-May-86 15:13") (* * Update the display of GRAPH's FreeMenu.  If NEW.NODE is not specified, use Top node of GRAPH, and change Top node title.) (LET* [(W (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH)) (NODELST (fetch (DINFOGRAPH NODELST) of GRAPH)) (NODE (OR NEW.NODE (FASSOC (fetch (DINFONODE ID) of (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) NODELST) (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) NODELST] (OR NEW.NODE (FM.CHANGELABEL (FM.GETITEM 'TOP NIL W) (fetch (DINFONODE LABEL) of (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) (fetch (DINFOGRAPH NODELST) of GRAPH))) W)) (FM.CHANGELABEL (FM.GETITEM 'NODE NIL W) (fetch (DINFONODE LABEL) of NODE) W) (FM.CHANGELABEL (FM.GETITEM 'PARENT NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE PARENT) of NODE) NODELST)) W) (FM.CHANGELABEL (FM.GETITEM 'NEXT NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE NEXTNODE) of NODE) NODELST)) W) (FM.CHANGELABEL (FM.GETITEM 'PREVIOUS NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE PREVIOUSNODE) of NODE) NODELST)) W]) (DINFO.TOGGLE.MENU [LAMBDA (ITEM WINDOW) (* jow "10-Jun-86 14:15") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.MENU.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) else (LET ((SUBNODE.MENU.WINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH))) (DETACHWINDOW SUBNODE.MENU.WINDOW) (CLOSEW SUBNODE.MENU.WINDOW]) (DINFO.TOGGLE.GRAPH [LAMBDA (ITEM WINDOW) (* ; "Edited 1-Oct-87 09:56 by drc:") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.GRAPH.DISPLAY GRAPH (fetch CURRENTNODE of GRAPH) T) else (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) ITEM]) (DINFO.TOGGLE.HISTORY [LAMBDA (ITEM WINDOW) (* jow "10-Jun-86 14:22") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.HISTORY GRAPH NIL NIL T) else (LET ((HISTORY.MENU.WINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH))) (DETACHWINDOW HISTORY.MENU.WINDOW) (CLOSEW HISTORY.MENU.WINDOW]) (DINFO.TOGGLE.TEXT [LAMBDA (ITEM WINDOW) (* drc%: "25-Jan-86 18:26") (LET* ((DINFOW (WINDOWPROP WINDOW 'MAINWINDOW)) (GRAPH (WINDOWPROP DINFOW 'DINFOGRAPH)) (MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH))) (if (NOT (OBTAIN.MONITORLOCK MONITORLOCK T)) then (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy") elseif (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.TEXT.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (RELEASE.MONITORLOCK MONITORLOCK) else (DINFO.UPDATE.TEXT.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH) NIL T) (RELEASE.MONITORLOCK MONITORLOCK]) ) (DEFINEQ (DINFO.UPDATE.MENU.DISPLAY [LAMBDA (GRAPH NODE) (* drc%: "25-Jan-86 18:20") (LET* [(DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (WINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) [CHILDREN (DREVERSE (for ID in (fetch (DINFONODE CHILDREN) of NODE) bind (NODELST _ (fetch (DINFOGRAPH NODELST) of GRAPH)) collect (FASSOC ID NODELST] (LENGTH (FLENGTH CHILDREN)) (SCROLLABLE (GREATERP LENGTH \DINFO.MAX.MENU.LEN)) (MENU (create MENU MENUFONT _ (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT) ITEMWIDTH _ (WINDOWPROP DINFOW 'WIDTH) CENTERFLG _ T MENUCOLUMNS _ 1 MENUOUTLINESIZE _ 0 ITEMS _ (for CHILD in CHILDREN collect (LIST (fetch (DINFONODE LABEL) of CHILD) CHILD "Will visit this node if selected." )) WHENSELECTEDFN _ (FUNCTION DINFO.UPDATE.FROM.MENU] (AND WINDOW (PROGN (DETACHWINDOW WINDOW) (CLOSEW WINDOW))) (if CHILDREN then (UPDATE/MENU/IMAGE MENU) (SETQ WINDOW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (WINDOWPROP DINFOW 'WIDTH) HEIGHT _ (HEIGHTIFWINDOW (if SCROLLABLE then (TIMES \DINFO.MAX.MENU.LEN (fetch (MENU ITEMHEIGHT) of MENU)) else (fetch (MENU IMAGEHEIGHT) of MENU)) T)) "Subnodes" NIL T)) (ADDMENU MENU WINDOW (create POSITION XCOORD _ 0 YCOORD _ (if SCROLLABLE then (TIMES (DIFFERENCE \DINFO.MAX.MENU.LEN LENGTH) (fetch (MENU ITEMHEIGHT) of MENU)) else 0)) T) (ATTACHWINDOW WINDOW DINFOW 'BOTTOM) (REDISPLAYW WINDOW) (replace (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH with WINDOW) (LET [(BITS (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW 'REGION] (* Slide DINFOW up if our new menu is off the screen) (AND (ILESSP BITS 0) (RELMOVEW DINFOW (create POSITION XCOORD _ 0 YCOORD _ (IDIFFERENCE 0 BITS]) (DINFO.UPDATE.FROM.MENU [LAMBDA (ITEM MENU BUTTONS) (* drc%: "12-Dec-85 14:49") (DINFO.UPDATE (WINDOWPROP (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW) 'DINFOGRAPH) (CADR ITEM]) (DINFO.UPDATE.HISTORY [LAMBDA (GRAPH NODE SEL DISPLAY?) (* drc%: "25-Jan-86 18:21") (LET* ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (OLDWINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH)) (OLDITEMS (fetch (DINFOGRAPH HISTORY.ITEMS) of GRAPH)) (NEWITEM (if SEL then (LIST (if (LISTP SEL) then (CAR SEL) else SEL) (LIST (fetch (DINFONODE ID) of NODE) SEL) "Will re-lookup this term") elseif NODE then (LIST (fetch (DINFONODE LABEL) of NODE) (LIST (fetch (DINFONODE ID) of NODE) SEL) "Will re-visit this node"))) (ITEMS (if [AND NEWITEM (NOT (EQUAL NEWITEM (CAR OLDITEMS] then (CONS NEWITEM (for ITEM in OLDITEMS as I from 2 to DINFO.HISTORY.LENGTH collect ITEM)) else OLDITEMS))) (replace (DINFOGRAPH HISTORY.ITEMS) of GRAPH with ITEMS) (AND OLDWINDOW (PROGN (DETACHWINDOW OLDWINDOW) (CLOSEW OLDWINDOW))) (AND DISPLAY? ITEMS (LET [(HISTORYW (ATTACHMENU (create MENU MENUFONT _ (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT) TITLE _ "History" CENTERFLG _ T MENUCOLUMNS _ 1 ITEMS _ ITEMS WHENSELECTEDFN _ (FUNCTION DINFO.HISTORIC.UPDATE)) DINFOW 'LEFT 'TOP] (replace (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH with HISTORYW]) (DINFO.HISTORIC.UPDATE [LAMBDA (ITEM MENU BUTTONS) (* drc%: "25-Jan-86 18:24") (LET* [(ID (CAADR ITEM)) (SEL (CADADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (GRAPH (WINDOWPROP WINDOW 'DINFOGRAPH)) (NODE (FASSOC ID (fetch (DINFOGRAPH NODELST) of GRAPH] (if (NOT (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T)) then (FLASHWINDOW WINDOW) (PROMPTPRINT "DInfo is busy") elseif (NULL NODE) then (PRINTOUT (GETPROMPTWINDOW WINDOW) T "This node no longer exists") else (DINFO.UPDATE GRAPH NODE SEL]) ) (DEFINEQ (DINFO.UPDATE.GRAPH.DISPLAY [LAMBDA (DINFO.GRAPH NODE FORCE?) (* drc%: "27-Jan-86 16:19") (LET [(DINFOW (fetch (DINFOGRAPH WINDOW) of DINFO.GRAPH)) (LOCATION (CONS (fetch (DINFONODE PARENT) of NODE) (fetch (DINFONODE CHILDREN) of NODE] (if (AND (NOT FORCE?) (EQUAL LOCATION (fetch (DINFOGRAPH LAST.GRAPH.LOCATION) of DINFO.GRAPH))) then (* don't need to relayout grapher display --  just change which node is inverted.) (DINFO.INVERT.NODE (fetch (DINFOGRAPH GRAPH.WINDOW) of DINFO.GRAPH) NODE DINFO.GRAPH) else (DINFO.SHOWGRAPH (DINFO.LAYOUTGRAPH DINFO.GRAPH NODE) DINFO.GRAPH)) (replace (DINFOGRAPH LAST.GRAPH.LOCATION) of DINFO.GRAPH with LOCATION) (WINDOWPROP (fetch (DINFOGRAPH GRAPH.WINDOW) of DINFO.GRAPH) 'TITLE (CONCAT (fetch (DINFOGRAPH NAME) of DINFO.GRAPH) " - " (fetch (DINFONODE LABEL) of (fetch (DINFOGRAPH CURRENTNODE) of DINFO.GRAPH]) (DINFO.UPDATE.FROM.GRAPH [LAMBDA (GRAPHER.NODE GRAPH.WINDOW) (* drc%: "12-Dec-85 18:34") (AND GRAPHER.NODE (ADD.PROCESS `(DINFO.UPDATE (QUOTE %, (WINDOWPROP GRAPH.WINDOW 'DINFOGRAPH)) (QUOTE %, (fetch (GRAPHNODE NODEID) of GRAPHER.NODE))) 'NAME "DInfo From Graph"]) (DINFO.GET.GRAPH.WINDOW [LAMBDA (GRAPH REGION) (* drc%: "25-Jan-86 18:05") (LET ((W (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) (COND ((WINDOWP W)) (T (SETQ W (DINFO.CREATE.GRAPH.WINDOW GRAPH REGION)) [WINDOWPROP W 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'DINFOGRAPH NIL] (replace (DINFOGRAPH GRAPH.WINDOW) of GRAPH with W))) (WINDOWPROP W 'DINFOGRAPH GRAPH) W]) (DINFO.CREATE.GRAPH.WINDOW [LAMBDA (GRAPH REGION) (* drc%: "25-Jan-86 17:49") (LET* ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (DINFOREGION (WINDOWPROP DINFOW 'REGION)) (LEFT (DIFFERENCE (DIFFERENCE (fetch (REGION LEFT) of DINFOREGION) (fetch (REGION WIDTH) of REGION)) 10)) (BOTTOM (DIFFERENCE (DIFFERENCE (fetch (REGION BOTTOM) of DINFOREGION) (fetch (REGION HEIGHT) of REGION)) 50))) (CREATEW (CREATEREGION (if (GEQ LEFT 0) then LEFT else (RAND 0 10)) (if (GEQ BOTTOM 0) then BOTTOM else (RAND 0 10)) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION)) NIL NIL T]) (DINFO.SHOWGRAPH [LAMBDA (GRAPHER.GRAPH DINFO.GRAPH) (* drc%: "27-Jan-86 16:15") (LET* [(GRAPH.REGION (GRAPHREGION GRAPHER.GRAPH)) (GRAPH.WINDOW (DINFO.GET.GRAPH.WINDOW DINFO.GRAPH GRAPH.REGION)) (WINDOW.REGION (WINDOWPROP GRAPH.WINDOW 'REGION] [SHAPEW GRAPH.WINDOW (LET [(LEFT (fetch (REGION LEFT) of WINDOW.REGION)) (BOTTOM (fetch (REGION BOTTOM) of WINDOW.REGION)) (HEIGHT (HEIGHTIFWINDOW (fetch (REGION HEIGHT) of GRAPH.REGION) T)) (WIDTH (WIDTHIFWINDOW (fetch (REGION WIDTH) of GRAPH.REGION] (create REGION LEFT _ LEFT BOTTOM _ BOTTOM HEIGHT _ (if (GEQ (IPLUS BOTTOM HEIGHT) SCREENHEIGHT) then (IDIFFERENCE SCREENHEIGHT BOTTOM) else HEIGHT) WIDTH _ (if (GEQ (IPLUS LEFT WIDTH) SCREENWIDTH) then (IDIFFERENCE SCREENWIDTH LEFT) else WIDTH] (SHOWGRAPH GRAPHER.GRAPH GRAPH.WINDOW (FUNCTION DINFO.UPDATE.FROM.GRAPH) (FUNCTION DINFO.UPDATE.FROM.GRAPH]) (DINFO.INVERT.NODE [LAMBDA (WINDOW DINFO.NODE DINFO.GRAPH) (* drc%: "25-Jan-86 18:24") (LET* ((NODE (for NODE in (fetch (GRAPH GRAPHNODES) of (WINDOWPROP WINDOW 'GRAPH)) thereis (EQ (fetch (GRAPHNODE NODEID) of NODE) DINFO.NODE))) (LAST.NODE (fetch (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH))) (replace (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH with NODE) (if (NEQ NODE LAST.NODE) then (replace (GRAPHNODE NODELABELSHADE) of NODE with BLACKSHADE) (* (PRINTDISPLAYNODE NODE  (create POSITION XCOORD _ 0 YCOORD _ 0)  WINDOW)) (replace (GRAPHNODE NODELABELSHADE) of LAST.NODE with WHITESHADE) (* (PRINTDISPLAYNODE LAST.NODE  (create POSITION XCOORD _ 0 YCOORD _ 0)  WINDOW)) (REDISPLAYW WINDOW) else (OPENW WINDOW]) (DINFO.LAYOUTGRAPH [LAMBDA (DINFO.GRAPH NODE) (* drc%: "25-Jan-86 18:20") (LET* [(WINDOW (fetch (DINFOGRAPH WINDOW) of DINFO.GRAPH)) (FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of DINFO.GRAPH)) MENUFONT)) (NODELST (fetch (DINFOGRAPH NODELST) of DINFO.GRAPH)) (CHILDREN (for ID in (fetch (DINFONODE CHILDREN) of NODE) collect (FASSOC ID NODELST))) [CHILD.GRAPHER.NODES (for CHILD in CHILDREN collect (create GRAPHNODE NODEID _ CHILD NODELABEL _ (fetch (DINFONODE LABEL) of CHILD] (GRAPHER.NODE (create GRAPHNODE NODELABELSHADE _ BLACKSHADE NODEID _ NODE TONODES _ CHILDREN NODELABEL _ (fetch (DINFONODE LABEL) of NODE] (replace (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH with GRAPHER.NODE) (* so DINFO.INVERT.NODE will work  right) (if (fetch (DINFONODE PARENT) of NODE) then (LET* ((PARENT (FASSOC (fetch (DINFONODE PARENT) of NODE) NODELST)) (SIBLINGS (for ID in (fetch (DINFONODE CHILDREN) of PARENT) collect (FASSOC ID NODELST))) [SIBLING.GRAPHER.NODES (for SIBLING in SIBLINGS collect (if (EQ (fetch (DINFONODE ID) of SIBLING) (fetch (DINFONODE ID) of NODE)) then GRAPHER.NODE else (create GRAPHNODE NODEID _ SIBLING NODELABEL _ (fetch (DINFONODE LABEL) of SIBLING] (PARENT.GRAPHER.NODE (create GRAPHNODE NODEID _ PARENT NODELABEL _ (fetch (DINFONODE LABEL) of PARENT) TONODES _ SIBLINGS))) (LAYOUTGRAPH (CONS PARENT.GRAPHER.NODE (NCONC SIBLING.GRAPHER.NODES CHILD.GRAPHER.NODES)) (LIST PARENT) NIL FONT)) else (LAYOUTGRAPH (CONS GRAPHER.NODE CHILD.GRAPHER.NODES) (LIST NODE) NIL FONT]) ) (DEFINEQ (DINFO.UPDATE.TEXT.DISPLAY [LAMBDA (GRAPH NODE SEL OFF?) (* drc%: "25-Jan-86 18:18") (LET ((WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (FILENAME (DINFO.GET.FILENAME GRAPH NODE)) (FROM (fetch (DINFONODE FROMBYTE) of NODE)) (TO (fetch (DINFONODE TOBYTE) of NODE)) (PROPS (APPEND (LIST 'READONLY T 'NOTITLE T 'TITLEMENUFN 'DINFO.TITLEMENUFN) (fetch (DINFOGRAPH TEXTPROPS) of GRAPH))) (OLD.TEXTSTREAM (WINDOWPROP (fetch (DINFOGRAPH WINDOW) of GRAPH) 'TEXTSTREAM)) TEXTSTREAM FULLFILENAME) (* Default directory and host.) (if (OR OFF? (NULL FILENAME)) then (OPENTEXTSTREAM (if OFF? then "" else "This node has no text") WINDOW NIL NIL PROPS) (replace (DINFOGRAPH LAST.TEXT) of GRAPH with NIL) elseif (SETQ FULLFILENAME (MKATOM (INFILEP FILENAME))) then (SETQ TEXTSTREAM (DINFO.OPENTEXTSTREAM FULLFILENAME WINDOW FROM TO PROPS)) (DINFO.SHOWSEL TEXTSTREAM SEL) else (OPENTEXTSTREAM (CONCAT "Sorry, can't find the text for this node." (MKSTRING (CHARACTER (CHARCODE CR))) "Missing file is: " FILENAME) WINDOW NIL NIL PROPS) (replace (DINFOGRAPH LAST.TEXT) of GRAPH with NIL)) (CLOSEF? OLD.TEXTSTREAM) (WINDOWPROP WINDOW 'ICONFN 'DINFO.ICONFN) (WINDOWPROP WINDOW 'TEDIT.TITLEMENUFN 'DINFO.TITLEMENUFN]) (DINFO.TITLEMENUFN [LAMBDA (DINFOW) (* drc%: "25-Jan-86 18:19") (* * This is the TEdit TITLEMENUFN for a DInfo Window.  Uses the MENUFN of graph, defaulting to DINFO.DEFAULT.MENU.) (LET [(GRAPH (WINDOWPROP DINFOW 'DINFOGRAPH] (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then [LET ((MENUFN (fetch (DINFOGRAPH MENUFN) of GRAPH))) (if (FGETD MENUFN) then (OR (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH) (DINFO.ADD.FMENU GRAPH)) (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (APPLY* MENUFN GRAPH)) else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (DINFO.DEFAULT.MENU GRAPH] else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) (DINFO.OPENTEXTSTREAM [LAMBDA (FILE WINDOW FROM TO PROPS) (* drc%: "25-Jan-86 18:24") (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW WINDOW)) (LET ((TEXTSTREAM (WINDOWPROP WINDOW 'TEXTSTREAM)) (THIS.TEXT (LIST FILE FROM TO))) (if (AND (EQUAL THIS.TEXT (fetch (DINFOGRAPH LAST.TEXT) of (DINFOGRAPH WINDOW))) TEXTSTREAM) then (* Same text, and its still there, so  do nothing.) TEXTSTREAM else (AND TEXTSTREAM (TEDIT.KILL TEXTSTREAM)) (CLEARW T) (CLEARW WINDOW) [RESETSAVE NIL `(AND RESETSTATE (WINDOWPROP %, WINDOW 'LAST.TEXT NIL] (PRINTOUT T "Fetching text from " FILE "...") (PROG1 (OPENTEXTSTREAM FILE WINDOW FROM TO PROPS) (PRINTOUT T "OK.") (replace (DINFOGRAPH LAST.TEXT) of (DINFOGRAPH WINDOW) with THIS.TEXT]) (DINFO.SHOWSEL [LAMBDA (TEXTSTREAM SEL) (* drc%: "16-Jan-86 21:30") (if (LISTP SEL) then (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM (CADR SEL) 0)) elseif (STRINGP SEL) then [LET ((CHAR# (TEDIT.FIND TEXTSTREAM SEL))) (if CHAR# then (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM CHAR# (NCHARS SEL) NIL T] else (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 0]) (DINFO.GET.FILENAME [LAMBDA (GRAPH NODE) (* drc%: "10-Jan-86 14:47") (* * returns the filename of the documentation for NODE in GRAPH.  Defaults HOST and DIRECTORY to that of graph) (LET ((FILE (fetch (DINFONODE FILE) of NODE))) (AND FILE (PACKFILENAME 'HOST (OR (FILENAMEFIELD FILE 'HOST) (fetch (DINFOGRAPH DEFAULTHOST) of GRAPH)) 'DEVICE (OR (FILENAMEFIELD FILE 'DEVICE) (fetch (DINFOGRAPH DEFAULTDEVICE) of GRAPH)) 'DIRECTORY (OR (FILENAMEFIELD FILE 'DIRECTORY) (fetch (DINFOGRAPH DEFAULTDIR) of GRAPH)) 'BODY FILE]) ) (ADDTOVAR BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH) "Open a DInfo window for browsing documentation.")) (RPAQQ BackgroundMenu NIL) (RPAQ? DINFO.GRAPHS ) (RPAQ? DINFOMODES '(TEXT GRAPH)) (RPAQ? DINFO.HISTORY.LENGTH 20) (RPAQ? \DINFO.MAX.MENU.LEN 10) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DINFO.GRAPH.FILES DINFOMODES DINFO.HISTORY.LENGTH \DINFO.MAX.MENU.LEN) ) (PUTPROPS DINFO FILETYPE :COMPILE-FILE) (DECLARE%: DONTCOPY (SETTEMPLATE 'DINFOGRAPHPROP 'MACRO) ) (PUTPROPS DINFO COPYRIGHT ("Xerox Corporation" 1985 1986 1987 2020 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7732 24558 (DINFO 7742 . 9356) (DINFO.UPDATE 9358 . 12222) (DINFOGRAPH 12224 . 12642) ( DINFO.SPECIAL.UPDATE 12644 . 14342) (DINFO.READ.GRAPH 14344 . 16199) (DINFO.WRITE.GRAPH 16201 . 17291) (DINFO.SELECT.GRAPH 17293 . 18200) (DINFO.DEFAULT.MENU 18202 . 20726) (DINFO.FIND 20728 . 23112) ( DINFO.LOOKUP 23114 . 24556)) (24559 27253 (DINFO.READ.KOTO.GRAPH 24569 . 27251)) (27254 29568 ( DINFO.SETUP.WINDOW 27264 . 27945) (DINFO.CLOSEFN 27947 . 28380) (DINFO.SHRINKFN 28382 . 28578) ( DINFO.EXPANDFN 28580 . 29137) (DINFO.ICONFN 29139 . 29566)) (29569 40417 (DINFO.ADD.FMENU 29579 . 30674) (DINFO.CREATE.FMENU 30676 . 34213) (DINFO.FMW.CLOSEFN 34215 . 35060) (DINFO.FMENU.HANDLER 35062 . 35701) (DINFO.UPDATE.FMENU 35703 . 37908) (DINFO.TOGGLE.MENU 37910 . 38500) (DINFO.TOGGLE.GRAPH 38502 . 39001) (DINFO.TOGGLE.HISTORY 39003 . 39547) (DINFO.TOGGLE.TEXT 39549 . 40415)) (40418 48116 ( DINFO.UPDATE.MENU.DISPLAY 40428 . 44448) (DINFO.UPDATE.FROM.MENU 44450 . 44749) (DINFO.UPDATE.HISTORY 44751 . 47285) (DINFO.HISTORIC.UPDATE 47287 . 48114)) (48117 58283 (DINFO.UPDATE.GRAPH.DISPLAY 48127 . 49445) (DINFO.UPDATE.FROM.GRAPH 49447 . 49890) (DINFO.GET.GRAPH.WINDOW 49892 . 50477) ( DINFO.CREATE.GRAPH.WINDOW 50479 . 51596) (DINFO.SHOWGRAPH 51598 . 53323) (DINFO.INVERT.NODE 53325 . 54713) (DINFO.LAYOUTGRAPH 54715 . 58281)) (58284 64140 (DINFO.UPDATE.TEXT.DISPLAY 58294 . 60155) ( DINFO.TITLEMENUFN 60157 . 61282) (DINFO.OPENTEXTSTREAM 61284 . 62500) (DINFO.SHOWSEL 62502 . 63235) ( DINFO.GET.FILENAME 63237 . 64138))))) STOP \ No newline at end of file diff --git a/lispusers/DINFO.LCOM b/lispusers/DINFO.LCOM index 0cd47c56b1760a43f48f182a4a706708b256d70b..fb87677cb12bce45ed1991af8c6c1cc3d6292470 100644 GIT binary patch delta 768 zcmb7?&x_MQ6vv5+uq@6(ZM!b+E(}pI5gMANsT!qg$d5LfCfPJy6$PnnY`aa9+E%HG zdexijyZSfip?5*>;zh)x3ZA@(3wrS8!P#zCs$TT=nD>3(_nGg^gYVSG&(x!Ji_fNX z|7t3e&hR)RNIWlz0*x8E7InIq8t4&5rO^yTstO|zt_SziM$u8y?K82yxF7N6L#kO>7n}>AaP1~Um;2;4nX5&x{q=OSX&n^^9 zjq|h%-bBm5lb}SztFuX1D|Ar{K(Oc^}^XyR$ZydLSfLlhpr+ zlS&mrd*IR|)qDUx073%7wc;D}8z2N1Brb>p2RQL&#_K!?_?e)8Z!%ll2`aQ_O=T5x+#l}Iu+pctW zkB{$H4m*d#L8aT?@3ik%gnc?}9}g>z7r4~8RnCL<@Ta%Ve=1NqSN9+OwUlBZx_6=q z8HSOA{oNCU*K*T=(hYO9Y?f~1@|x~?KCvTWG2(!@G(&UMEUvr|tp&*o*2=5vYp{2) z+q=^qg2um_dy~I2xZH%nar@q3|8yv6y=P+2CCT^0bto0hQpqf$EZPg|P&zZt6%Y8G zqbo1xLD%?$qb2_6X!(+oDG42H4y3agSz!(N{Cl*`fB59$IW${$cP_X=4Ei;=h3=1c z<9U_m*)(ti1Qbz?FLpv+UZ3Z0Y|L}sG5O=pr8$lN-l_9Hw-(Ua>fYp!&M%_%b=TvM zyRWmiO1bnMb%t#GDOJ+SHo0_qSyX257D zOwR#3i6Rm(;Xx9UNaO+|AG0u`A$IFVgw#opc#PCz@G0F+LN@?$l;XETTr2TejUwpC zc1Xjsv9^jhUIcX-c#K9qwYQb{hDe8|7dW&Dns8hiFmQ!sjE<#VnN#y(1Zc^;>?}@` zs-Qh{=vy%}1bxt?=>-iE;X)g-L3yNrk&MMW8bAiE8g!A95wpk(Hb>2lJe+>qicy3- zS`o2nAU4Af{^LVWKPC^m-Y%uujC0qixZrKr?T5B;n(AC08`+XXUUM(N=fHVuZED7#{ z=Oc}gSBR4^^gZH;_I$!X$0jYm;CjS&a67F4KYg4+2m%o=ksZ)&D@rq8agv_`17}&U ziW^Rp-B7AYM6ryx^eSia9`hP7kvz%D3)gd>K@?aGb<|S~PBB%7RRxSKguaEls833O ze)~FTlMKYCt~``_<#8)nP5NVP1P6RI2$SKWK-W;A*fY&^S>`QIK_FvIgqE{$V$dbb zM%XDHSy0xO*Aohxrro}tPNd1S8qH~zLVl!|oMFOXHmY1zQAQ?J z@SjCB|12?+I8{FxPj)eqQB->#HiAD{Zld<{COg(M#s5FG>0+?|KUeMPAtJX;vFT&1 zG1Sa#1g_c*90A&D8b~vbZ__&aZCIQu#)RQd11=jr%cr(lCS=F*t>*dbr_QUGk8e=> E4@m+z>Hq)$ From c406cbf2addacf475601350be0f237c92a50c1d7 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Wed, 17 Feb 2021 14:00:23 -0800 Subject: [PATCH 05/31] Added 2 lines in SCROLL.HANDLER in WINDOWSCROLL so that vertical and horizontal scrollbar windows are recognizable and recognizably related to their main windows. This allows WHEELSCROLL to provide better wheel-scrolling behavior --- sources/WINDOWSCROLL | 361 +++----------------------------------- sources/WINDOWSCROLL.LCOM | Bin 15468 -> 15321 bytes 2 files changed, 28 insertions(+), 333 deletions(-) diff --git a/sources/WINDOWSCROLL b/sources/WINDOWSCROLL index f874f61c..2be029a0 100644 --- a/sources/WINDOWSCROLL +++ b/sources/WINDOWSCROLL @@ -1,54 +1,4 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "16-Feb-94 12:36:43" {DSK}nilsson>mnw>WINDOWSCROLL.;1 54529 - - changes to%: (FNS SCROLLW SCROLLBYREPAINTFN ADJUSTOFFSETS CREATESCROLLINGW IN/SCROLL/BAR? - RELDSPXOFFSET RELDSPYOFFSET SCROLL.HANDLER \SCROLL.HANDLER.DOIT - \DECODE.EXTENT.USE \UPDATE.EXTENT.IMAGE EXTENDPASTHORIZBOUNDARIES - EXTENDPASTVERTBOUNDARIES FILLWITHBACKGROUND UPDATE/SCROLL/REG WTODSX WTODSY - WXOFFSET WYOFFSET BITMAPSCROLLFN SCROLLBITMAP REDISPLAYBITMAP - ULREDISPLAYBITMAP EXTENDEXTENT WIDTHIFWINDOW HEIGHTIFWINDOW) - (VARS WINDOWSCROLLCOMS) - - previous date%: "29-Sep-93 14:57:22" {DSK}export>lispcore>sources>WINDOWSCROLL.;1) - - -(* ; " -Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT WINDOWSCROLLCOMS) - -(RPAQQ WINDOWSCROLLCOMS - [ (* ; "Scrolling stuff") - (FNS SCROLLW SCROLLBYREPAINTFN ADJUSTOFFSETS CREATESCROLLINGW IN/SCROLL/BAR? RELDSPXOFFSET - RELDSPYOFFSET SCROLL.HANDLER \SCROLL.HANDLER.DOIT \DECODE.EXTENT.USE - \UPDATE.EXTENT.IMAGE EXTENDPASTHORIZBOUNDARIES EXTENDPASTVERTBOUNDARIES REDISPLAYW - FILLWITHBACKGROUND UPDATE/SCROLL/REG WTODSX WTODSY WXOFFSET WYOFFSET BITMAPSCROLLFN - SCROLLBITMAP REDISPLAYBITMAP ULREDISPLAYBITMAP EXTENDEXTENT WIDTHIFWINDOW HEIGHTIFWINDOW - ) - (* ; - "this function should be on LLDISPLAY but Ron has it checked out. Move it later - rrb.") - (FNS \DSPUNTRANSFORMREGION) - (CURSORS VertScrollCursor ScrollUpCursor ScrollDownCursor HorizScrollCursor ScrollLeftCursor - ScrollRightCursor VertThumbCursor HorizThumbCursor WAITINGCURSOR) - (GLOBALVARS \LastInWindow VertScrollCursor ScrollUpCursor ScrollDownCursor ScrollLeftCursor - ScrollRightCursor HorizScrollCursor) - (INITVARS (SCROLLBARWIDTH 24) - (SCROLLWAITTIME 100) - (SCROLLBARSHADE 32800) - (WAITBEFORESCROLLTIME 750) - (WAITBETWEENSCROLLTIME 100)) - (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (GLOBALVARS SCROLLBARWIDTH SCROLLWAITTIME - SCROLLBARSHADE WAITBEFORESCROLLTIME - WAITBETWEENSCROLLTIME WAITINGCURSOR]) - - - -(* ; "Scrolling stuff") - -(DEFINEQ - -(SCROLLW +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "17-Feb-2021 13:49:06"  {DSK}kaplan>Local>medley3.5>git-medley>sources>WINDOWSCROLL.;2 54471 changes to%: (FNS SCROLL.HANDLER) previous date%: "16-Feb-94 12:36:43" {DSK}kaplan>Local>medley3.5>git-medley>sources>WINDOWSCROLL.;1) (* ; " Copyright (c) 1986, 1990, 1993, 1994, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT WINDOWSCROLLCOMS) (RPAQQ WINDOWSCROLLCOMS [ (* ; "Scrolling stuff") (FNS SCROLLW SCROLLBYREPAINTFN ADJUSTOFFSETS CREATESCROLLINGW IN/SCROLL/BAR? RELDSPXOFFSET RELDSPYOFFSET SCROLL.HANDLER \SCROLL.HANDLER.DOIT \DECODE.EXTENT.USE \UPDATE.EXTENT.IMAGE EXTENDPASTHORIZBOUNDARIES EXTENDPASTVERTBOUNDARIES REDISPLAYW FILLWITHBACKGROUND UPDATE/SCROLL/REG WTODSX WTODSY WXOFFSET WYOFFSET BITMAPSCROLLFN SCROLLBITMAP REDISPLAYBITMAP ULREDISPLAYBITMAP EXTENDEXTENT WIDTHIFWINDOW HEIGHTIFWINDOW ) (* ;  "this function should be on LLDISPLAY but Ron has it checked out. Move it later - rrb.") (FNS \DSPUNTRANSFORMREGION) (CURSORS VertScrollCursor ScrollUpCursor ScrollDownCursor HorizScrollCursor ScrollLeftCursor ScrollRightCursor VertThumbCursor HorizThumbCursor WAITINGCURSOR) (GLOBALVARS \LastInWindow VertScrollCursor ScrollUpCursor ScrollDownCursor ScrollLeftCursor ScrollRightCursor HorizScrollCursor) (INITVARS (SCROLLBARWIDTH 24) (SCROLLWAITTIME 100) (SCROLLBARSHADE 32800) (WAITBEFORESCROLLTIME 750) (WAITBETWEENSCROLLTIME 100)) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (GLOBALVARS SCROLLBARWIDTH SCROLLWAITTIME SCROLLBARSHADE WAITBEFORESCROLLTIME WAITBETWEENSCROLLTIME WAITINGCURSOR]) (* ; "Scrolling stuff") (DEFINEQ (SCROLLW [LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* ; "Edited 16-Feb-94 11:58 by nilsson") (* ;; "scrolls a window by DX in the X direction and DY in the Y direction. If CONTINUOUSFLG is non-NIL, this is part of a continuous scroll so that the window scrolling function can decide for example to scroll a constant smount.") @@ -56,9 +6,7 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (\CHECKCARET WINDOW) (APPLY* (OR (fetch SCROLLFN of WINDOW) (FUNCTION SCROLLBYREPAINTFN)) - WINDOW DX DY CONTINUOUSFLG]) - -(SCROLLBYREPAINTFN + WINDOW DX DY CONTINUOUSFLG]) (SCROLLBYREPAINTFN [LAMBDA (WINDOW XDELTA YDELTA CONTINUOUSFLG) (* ; "Edited 16-Feb-94 12:26 by nilsson") (* ;; "standard scrolling function that scrolls by blting existing bits and then calling the windows repaintfn to repaint the newly exposed bits.") @@ -263,23 +211,17 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (IMIN (IMINUS YDELTA) ONSHEIGHT] T))) - (RETURN]) - -(ADJUSTOFFSETS + (RETURN]) (ADJUSTOFFSETS [LAMBDA (WINDOW XDELTA YDELTA) (* ; "Edited 16-Feb-94 12:27 by nilsson") (PROG [(DSP (WINDOWPROP WINDOW 'DSP] (* ;  "determine the change in offsets caused by the scroll. and redisplay the graph.") (WYOFFSET YDELTA DSP) (WXOFFSET XDELTA DSP) - (RETURN]) - -(CREATESCROLLINGW + (RETURN]) (CREATESCROLLINGW [LAMBDA (TITLE BORDER) (* ; "Edited 16-Feb-94 12:27 by nilsson") (WINDOWPROP (CREATEW NIL TITLE BORDER) 'SCROLLFN - (FUNCTION SCROLLBYREPAINTFN]) - -(IN/SCROLL/BAR? + (FUNCTION SCROLLBYREPAINTFN]) (IN/SCROLL/BAR? [LAMBDA (WINDOW X Y) (* ; "Edited 16-Feb-94 12:27 by nilsson") (* ;  "is X, Y in the scroll bar for WINDOW?") @@ -325,165 +267,15 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (T (\DECODE.EXTENT.USE EXTENTUSE))) 'LIMIT] (T (EXTENDPASTHORIZBOUNDARIES (DSPCLIPPINGREGION NIL WINDOW) - EXTENT]) - -(RELDSPXOFFSET + EXTENT]) (RELDSPXOFFSET [LAMBDA (DX DISPLAYSTREAM) (* ; "Edited 16-Feb-94 12:28 by nilsson") (* ; "relative offsetting function.") (DSPXOFFSET (IPLUS DX (DSPXOFFSET NIL DISPLAYSTREAM)) - DISPLAYSTREAM]) - -(RELDSPYOFFSET + DISPLAYSTREAM]) (RELDSPYOFFSET [LAMBDA (DY DISPLAYSTREAM) (* ; "Edited 16-Feb-94 12:28 by nilsson") (* ; "relative offsetting function.") (DSPYOFFSET (IPLUS DY (DSPYOFFSET NIL DISPLAYSTREAM)) - DISPLAYSTREAM]) - -(SCROLL.HANDLER - [LAMBDA (WINDOW) (* ; "Edited 16-Feb-94 12:29 by nilsson") - - (* ;; "cursor has moved into scroll region. region of a window that has a scrollfn and has been IN/SCROLL/BAR? Handle interaction to determine type of scroll, if any, desired.") - (* ; - "returns non-NIL if scrolling was applicable.") - (PROG (SCROLLREG SCROLLW BUTTON DIRECTION SCROLLCURSOR LEFTCURSOR RIGHTCURSOR MIDDLECURSOR - TIMEDOWN CONTINUOUSSCROLL? TIMEIN TIMEINTIMER) - (* ; - "create a window as the easiest thing to do. Fairly inefficient.") - - (* ;; "if the main window is not open, it was probably closed before we got control here. Don't do anything.") - - (OR (OPENWP WINDOW) - (RETURN)) - (GETMOUSESTATE) - (COND - ((AND (INSIDE? (SETQ SCROLLREG (fetch (WINDOW VERTSCROLLREG) of WINDOW)) - LASTMOUSEX LASTMOUSEY) - (PROGN (DISMISS SCROLLWAITTIME) - (GETMOUSESTATE) - (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY))) - [COND - ((SETQ SCROLLW (fetch (WINDOW VERTSCROLLWINDOW) of WINDOW)) - (* ; - "if there is one already, reopen it.") - (OPENW SCROLLW)) - ((SETQ SCROLLW (replace (WINDOW VERTSCROLLWINDOW) of WINDOW - with (CREATEW SCROLLREG NIL 2] - (SETQ DIRECTION 'VERT) - (SETQ SCROLLCURSOR VertScrollCursor) - (SETQ LEFTCURSOR ScrollUpCursor) - (SETQ RIGHTCURSOR ScrollDownCursor) - (SETQ MIDDLECURSOR VertThumbCursor)) - ((AND (INSIDE? (SETQ SCROLLREG (fetch (WINDOW HORIZSCROLLREG) of WINDOW)) - LASTMOUSEX LASTMOUSEY) - (PROGN (DISMISS SCROLLWAITTIME) - (GETMOUSESTATE) - (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY))) - [COND - ((SETQ SCROLLW (fetch (WINDOW HORIZSCROLLWINDOW) of WINDOW)) - (* ; - "if there is one already, reopen it.") - (OPENW SCROLLW)) - ((SETQ SCROLLW (replace (WINDOW HORIZSCROLLWINDOW) of WINDOW - with (CREATEW SCROLLREG NIL 2] - (SETQ DIRECTION 'HORIZ) - (SETQ SCROLLCURSOR HorizScrollCursor) - (SETQ LEFTCURSOR ScrollLeftCursor) - (SETQ MIDDLECURSOR HorizThumbCursor) - (SETQ RIGHTCURSOR ScrollRightCursor)) - (T (* ; "moved out quickly") - (RETURN NIL))) - (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION WINDOW) - - (* ;; "set up the timer for when to bring the window to the top. This gives the user a chance to notice that the scroll bar has come up and get out of it if it was unintentional.") - - (SETQ TIMEIN (SETUPTIMER 1200)) - (RETURN (RESETFORM (CURSOR SCROLLCURSOR) - (PROG NIL - LP (GETMOUSESTATE) - (COND - ((NOT (OPENWP WINDOW)) (* ; - "the user closed the window, quit.") - (CLOSEW SCROLLW) - (SETQ \LastInWindow NIL) - (RETURN T))) - (COND - ((AND TIMEIN (TIMEREXPIRED? TIMEIN)) - - (* ;; "after a little while, bring the window to the top. This avoids bringing it up if nothing is happening.") - - (SETQ TIMEIN NIL) - (TOTOPW WINDOW))) - (COND - ((NOT (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY)) - (* ; - "if cursor is no longer in scroll region quit.") - (CLOSEW SCROLLW) - - (* ;; "if the mouse is in the window, set last in window so window will get control again. If it is outside, don't set it so that the cursoroutfn for WINDOW will get called.") - - (AND (INSIDE? (WINDOWPROP WINDOW 'REGION) - LASTMOUSEX LASTMOUSEY) - (SETQ \LastInWindow NIL)) - (RETURN T))) (* ; - "bring the scroll window to the top so that it will be visible.") - (TOTOPW SCROLLW) - [COND - [(LASTMOUSESTATE UP) (* ; - "no buttons down; if there was one down, take action; otherwise, wait for one to go down.") - (COND - (BUTTON (COND - (CONTINUOUSSCROLL? - (* ; - "were continuously scrolling, stop it.") - (SETQ CONTINUOUSSCROLL? NIL)) - (T (\SCROLL.HANDLER.DOIT WINDOW BUTTON DIRECTION - SCROLLREG LASTMOUSEX LASTMOUSEY) - (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION - WINDOW))) - (CURSOR SCROLLCURSOR) - (SETQ BUTTON) (* ; - "if a button went up, reset the timedown for scrolling.") - (SETQ TIMEDOWN) - (SETQ CONTINUOUSSCROLL? NIL)) - (T (BLOCK] - [(LASTMOUSESTATE (OR LEFT RIGHT)) - (COND - ((AND (LASTMOUSESTATE LEFT) - (NEQ BUTTON 'LEFT)) - (* ; "LEFT button just when down.") - (SETQ BUTTON 'LEFT) - (SETQ TIMEDOWN (CLOCK 0)) - (CURSOR LEFTCURSOR)) - ((AND (LASTMOUSESTATE RIGHT) - (NEQ BUTTON 'RIGHT)) - (* ; "RIGHT button just when down.") - (SETQ BUTTON 'RIGHT) - (SETQ TIMEDOWN (CLOCK 0)) - (CURSOR RIGHTCURSOR)) - ((AND CONTINUOUSSCROLL? (\CLOCKGREATERP TIMEDOWN - WAITBETWEENSCROLLTIME)) - (* ; - "button is still down, keep scrolling.") - (* ; - "note time before calling scroll fn so time to display is included in the wait time.") - (SETQ TIMEDOWN (\CLOCK0 TIMEDOWN)) - (\SCROLL.HANDLER.DOIT WINDOW BUTTON DIRECTION SCROLLREG - LASTMOUSEX LASTMOUSEY T) - (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION WINDOW)) - ((\CLOCKGREATERP TIMEDOWN WAITBEFORESCROLLTIME) - (* ; - "has enough time past to start continuous scroll?") - (SETQ CONTINUOUSSCROLL? T] - ((LASTMOUSESTATE MIDDLE) - (COND - ((NEQ BUTTON 'MIDDLE) (* ; "MIDDLE button just when down.") - (SETQ BUTTON 'MIDDLE) (* ; - "don't keep track of time down for middle buttons.") - (CURSOR MIDDLECURSOR)) - (T NIL] - (GO LP]) - -(\SCROLL.HANDLER.DOIT + DISPLAYSTREAM]) (SCROLL.HANDLER [LAMBDA (WINDOW) (* ; "Edited 17-Feb-2021 13:48 by rmk:") (* ;  "Edited 16-Feb-94 12:29 by nilsson") (* ;; "cursor has moved into scroll region. region of a window that has a scrollfn and has been IN/SCROLL/BAR? Handle interaction to determine type of scroll, if any, desired.") (* ;  "returns non-NIL if scrolling was applicable.") (PROG (SCROLLREG SCROLLW BUTTON DIRECTION SCROLLCURSOR LEFTCURSOR RIGHTCURSOR MIDDLECURSOR TIMEDOWN CONTINUOUSSCROLL? TIMEIN TIMEINTIMER) (* ;  "create a window as the easiest thing to do. Fairly inefficient.") (* ;; "if the main window is not open, it was probably closed before we got control here. Don't do anything.") (OR (OPENWP WINDOW) (RETURN)) (GETMOUSESTATE) (COND ((AND (INSIDE? (SETQ SCROLLREG (fetch (WINDOW VERTSCROLLREG) of WINDOW)) LASTMOUSEX LASTMOUSEY) (PROGN (DISMISS SCROLLWAITTIME) (GETMOUSESTATE) (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY))) [COND ((SETQ SCROLLW (fetch (WINDOW VERTSCROLLWINDOW) of WINDOW)) (* ;  "if there is one already, reopen it.") (OPENW SCROLLW)) ((SETQ SCROLLW (replace (WINDOW VERTSCROLLWINDOW) of WINDOW with (CREATEW SCROLLREG NIL 2))) (* ;;  "RMK: So that the scroll bar is recognizable and connected (unreferenced) to its scrollee window") (WINDOWPROP SCROLLW 'VERTICALSCROLLBARFOR (LOC WINDOW] (SETQ DIRECTION 'VERT) (SETQ SCROLLCURSOR VertScrollCursor) (SETQ LEFTCURSOR ScrollUpCursor) (SETQ RIGHTCURSOR ScrollDownCursor) (SETQ MIDDLECURSOR VertThumbCursor)) ((AND (INSIDE? (SETQ SCROLLREG (fetch (WINDOW HORIZSCROLLREG) of WINDOW)) LASTMOUSEX LASTMOUSEY) (PROGN (DISMISS SCROLLWAITTIME) (GETMOUSESTATE) (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY))) [COND ((SETQ SCROLLW (fetch (WINDOW HORIZSCROLLWINDOW) of WINDOW)) (* ;  "if there is one already, reopen it.") (OPENW SCROLLW)) ((SETQ SCROLLW (replace (WINDOW HORIZSCROLLWINDOW) of WINDOW with (CREATEW SCROLLREG NIL 2))) (WINDOWPROP SCROLLW 'HORIZONTALSCROLLBARFOR (LOC WINDOW] (SETQ DIRECTION 'HORIZ) (SETQ SCROLLCURSOR HorizScrollCursor) (SETQ LEFTCURSOR ScrollLeftCursor) (SETQ MIDDLECURSOR HorizThumbCursor) (SETQ RIGHTCURSOR ScrollRightCursor)) (T (* ; "moved out quickly") (RETURN NIL))) (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION WINDOW) (* ;; "set up the timer for when to bring the window to the top. This gives the user a chance to notice that the scroll bar has come up and get out of it if it was unintentional.") (SETQ TIMEIN (SETUPTIMER 1200)) (RETURN (RESETFORM (CURSOR SCROLLCURSOR) (PROG NIL LP (GETMOUSESTATE) (COND ((NOT (OPENWP WINDOW)) (* ;  "the user closed the window, quit.") (CLOSEW SCROLLW) (SETQ \LastInWindow NIL) (RETURN T))) (COND ((AND TIMEIN (TIMEREXPIRED? TIMEIN)) (* ;; "after a little while, bring the window to the top. This avoids bringing it up if nothing is happening.") (SETQ TIMEIN NIL) (TOTOPW WINDOW))) (COND ((NOT (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY)) (* ;  "if cursor is no longer in scroll region quit.") (CLOSEW SCROLLW) (* ;; "if the mouse is in the window, set last in window so window will get control again. If it is outside, don't set it so that the cursoroutfn for WINDOW will get called.") (AND (INSIDE? (WINDOWPROP WINDOW 'REGION) LASTMOUSEX LASTMOUSEY) (SETQ \LastInWindow NIL)) (RETURN T))) (* ;  "bring the scroll window to the top so that it will be visible.") (TOTOPW SCROLLW) [COND [(LASTMOUSESTATE UP) (* ;  "no buttons down; if there was one down, take action; otherwise, wait for one to go down.") (COND (BUTTON (COND (CONTINUOUSSCROLL? (* ;  "were continuously scrolling, stop it.") (SETQ CONTINUOUSSCROLL? NIL)) (T (\SCROLL.HANDLER.DOIT WINDOW BUTTON DIRECTION SCROLLREG LASTMOUSEX LASTMOUSEY) (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION WINDOW))) (CURSOR SCROLLCURSOR) (SETQ BUTTON) (* ;  "if a button went up, reset the timedown for scrolling.") (SETQ TIMEDOWN) (SETQ CONTINUOUSSCROLL? NIL)) (T (BLOCK] [(LASTMOUSESTATE (OR LEFT RIGHT)) (COND ((AND (LASTMOUSESTATE LEFT) (NEQ BUTTON 'LEFT)) (* ; "LEFT button just when down.") (SETQ BUTTON 'LEFT) (SETQ TIMEDOWN (CLOCK 0)) (CURSOR LEFTCURSOR)) ((AND (LASTMOUSESTATE RIGHT) (NEQ BUTTON 'RIGHT)) (* ; "RIGHT button just when down.") (SETQ BUTTON 'RIGHT) (SETQ TIMEDOWN (CLOCK 0)) (CURSOR RIGHTCURSOR)) ((AND CONTINUOUSSCROLL? (\CLOCKGREATERP TIMEDOWN WAITBETWEENSCROLLTIME)) (* ;  "button is still down, keep scrolling.") (* ;  "note time before calling scroll fn so time to display is included in the wait time.") (SETQ TIMEDOWN (\CLOCK0 TIMEDOWN)) (\SCROLL.HANDLER.DOIT WINDOW BUTTON DIRECTION SCROLLREG LASTMOUSEX LASTMOUSEY T) (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION WINDOW)) ((\CLOCKGREATERP TIMEDOWN WAITBEFORESCROLLTIME) (* ;  "has enough time past to start continuous scroll?") (SETQ CONTINUOUSSCROLL? T] ((LASTMOUSESTATE MIDDLE) (COND ((NEQ BUTTON 'MIDDLE) (* ; "MIDDLE button just when down.") (SETQ BUTTON 'MIDDLE) (* ;  "don't keep track of time down for middle buttons.") (CURSOR MIDDLECURSOR)) (T NIL] (GO LP]) (\SCROLL.HANDLER.DOIT [LAMBDA (WINDOW BUTTON DIRECTION SCROLLREGION XPOS YPOS CONTINUOUS?) (* ; "Edited 16-Feb-94 12:29 by nilsson") @@ -548,9 +340,7 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (IPLUS 4 SIZEOFORIGIN]) (SHOULDNT))) (T 0)) - CONTINUOUS?]) - -(\DECODE.EXTENT.USE + CONTINUOUS?]) (\DECODE.EXTENT.USE [LAMBDA (EXTENTUSE) (* ; "Edited 16-Feb-94 12:30 by nilsson") (* ;;; "decodes an indicator of how the extent should be used to limit scrolling.") @@ -560,9 +350,7 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r ((LIMIT T + - +-) EXTENTUSE) (-+ '+-) - T]) - -(\UPDATE.EXTENT.IMAGE + T]) (\UPDATE.EXTENT.IMAGE [LAMBDA (SCROLLBARW DIRECTION SCROLLINGW) (* ; "Edited 16-Feb-94 12:32 by nilsson") (* ;  "paints the appropriate grey region in the scrolling bar window.") @@ -634,40 +422,30 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r 'TEXTURE 'REPLACE (OR (TEXTUREP SCROLLBARSHADE) - 32800]) - -(EXTENDPASTHORIZBOUNDARIES + 32800]) (EXTENDPASTHORIZBOUNDARIES [LAMBDA (VIEW EXTENT) (* ; "Edited 16-Feb-94 12:32 by nilsson") (* ;  "does VIEW entirely cover the hoizontal dimensions of EXTENT?") (OR (IGREATERP (fetch (REGION LEFT) of VIEW) (fetch (REGION LEFT) of EXTENT)) (IGREATERP (fetch (REGION RIGHT) of EXTENT) - (fetch (REGION RIGHT) of VIEW]) - -(EXTENDPASTVERTBOUNDARIES + (fetch (REGION RIGHT) of VIEW]) (EXTENDPASTVERTBOUNDARIES [LAMBDA (VIEW EXTENT) (* ; "Edited 16-Feb-94 12:33 by nilsson") (* ;  "does VIEW entirely cover the vertical dimensions of EXTENT?") (OR (IGREATERP (fetch (REGION BOTTOM) of VIEW) (fetch (REGION BOTTOM) of EXTENT)) (IGREATERP (fetch (REGION TOP) of EXTENT) - (fetch (REGION TOP) of VIEW]) - -(REDISPLAYW + (fetch (REGION TOP) of VIEW]) (REDISPLAYW [LAMBDA (WINDOW REGION ALWAYSFLG) (WINDOWOP 'REDISPLAYFN (fetch (WINDOW SCREEN) of WINDOW) - WINDOW REGION ALWAYSFLG]) - -(FILLWITHBACKGROUND + WINDOW REGION ALWAYSFLG]) (FILLWITHBACKGROUND [LAMBDA (WIN REG) (* ; "Edited 16-Feb-94 12:33 by nilsson") (* ;  "fills a window with its background. This is the default window repainting function.") (DSPFILL REG (DSPTEXTURE NIL WIN) 'REPLACE - (WINDOWPROP WIN 'DSP]) - -(UPDATE/SCROLL/REG + (WINDOWPROP WIN 'DSP]) (UPDATE/SCROLL/REG [LAMBDA (WINDOW) (* ; "Edited 16-Feb-94 12:34 by nilsson") (* ;  "updates the scroll region field of the WINDOW") @@ -706,23 +484,17 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r of IMAGEREG) SCROLLBARWIDTH)) WIDTH _ (fetch (REGION WIDTH) of IMAGEREG) - HEIGHT _ SCROLLBARWIDTH]) - -(WTODSX + HEIGHT _ SCROLLBARWIDTH]) (WTODSX [LAMBDA (WX WINDOW) (* ; "Edited 16-Feb-94 12:34 by nilsson") (* ;; "converts from the window natural coordinates which have 0,0 at lower left corner of the window and the displaystreams coordinates.") - (IPLUS WX (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL (fetch DSP of WINDOW]) - -(WTODSY + (IPLUS WX (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL (fetch DSP of WINDOW]) (WTODSY [LAMBDA (WY WINDOW) (* ; "Edited 16-Feb-94 12:34 by nilsson") (* ;; "converts from the window natural coordinates which have 0,0 at lower left corner of the window and the displaystreams coordinates.") - (IPLUS WY (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL (fetch DSP of WINDOW]) - -(WXOFFSET + (IPLUS WY (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL (fetch DSP of WINDOW]) (WXOFFSET [LAMBDA (DX WINDOW) (* ; "Edited 16-Feb-94 12:26 by nilsson") (* ;; "offsets a displaystream by a given delta but leaves its clipping region where it was. Used for offsetting display streams under window.") @@ -738,9 +510,7 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (add (fetch (REGION LEFT) of CR) (IMINUS DX)) (* ;  "recall DSPCLIPPINGREGION to update dependent fields in DS.") - (DSPCLIPPINGREGION CR DS))))]) - -(WYOFFSET + (DSPCLIPPINGREGION CR DS))))]) (WYOFFSET [LAMBDA (DY WINDOW) (* ; "Edited 16-Feb-94 12:26 by nilsson") (* ;; "offsets a displaystream by a given delta but leaves its clipping region where it was. Used for offsetting display streams under window.") @@ -756,15 +526,11 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (add (fetch (REGION BOTTOM) of CR) (IMINUS DY)) (* ;  "recall DSPCLIPPINGREGION to update dependent fields in DS.") - (DSPCLIPPINGREGION CR DS))))]) - -(BITMAPSCROLLFN + (DSPCLIPPINGREGION CR DS))))]) (BITMAPSCROLLFN [LAMBDA (WINDOW XDELTA YDELTA) (* ; "Edited 16-Feb-94 12:34 by nilsson") (* ; "scrolls a bitmap under a window") (SCROLLBITMAP (WINDOWPROP WINDOW 'BITMAP) - WINDOW XDELTA YDELTA]) - -(SCROLLBITMAP + WINDOW XDELTA YDELTA]) (SCROLLBITMAP [LAMBDA (BITMAP WINDOW XDELTA YDELTA) (* ; "Edited 16-Feb-94 12:35 by nilsson") (* ;  "scrolls a bitmap under a window.") @@ -785,9 +551,7 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (IDIFFERENCE (fetch (REGION WIDTH) of REGION) (fetch (BITMAP BITMAPWIDTH) of BITMAP))) DSP) (* ; "stuff new image over old") - (BITBLT BITMAP 0 0 DSP]) - -(REDISPLAYBITMAP + (BITBLT BITMAP 0 0 DSP]) (REDISPLAYBITMAP [LAMBDA (BITMAP WINDOW) (* ; "Edited 16-Feb-94 12:35 by nilsson") (* ;; "blts a bitmap into a window so that the lower left corner of the bitmap is in the lower left corner of the window.") @@ -798,9 +562,7 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r WREGION) (SETQ WREGION (DSPCLIPPINGREGION NIL DSP)) (RETURN (BITBLT BITMAP 0 0 DSP (fetch (REGION LEFT) of WREGION) - (fetch (REGION BOTTOM) of WREGION]) - -(ULREDISPLAYBITMAP + (fetch (REGION BOTTOM) of WREGION]) (ULREDISPLAYBITMAP [LAMBDA (BITMAP WNEW) (* ; "Edited 16-Feb-94 12:35 by nilsson") (* ;; "blts a bitmap into a window so that the upper left corner of the bitmap is in the upper left corner of the window.") @@ -813,24 +575,18 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (RETURN (BITBLT BITMAP 0 0 DSP (fetch (REGION LEFT) of REGION) (IDIFFERENCE (IPLUS (fetch (REGION BOTTOM) of REGION) (fetch (REGION HEIGHT) of REGION)) - (fetch BITMAPHEIGHT of BITMAP]) - -(EXTENDEXTENT + (fetch BITMAPHEIGHT of BITMAP]) (EXTENDEXTENT [LAMBDA (WINDOW INCLUDEREGION) (* ; "Edited 16-Feb-94 12:35 by nilsson") (* ;  "destructively changes the EXTENT region of a WINDOW to include INCLUDEREGION") (PROG [(EXTENT (WINDOWPROP WINDOW 'EXTENT] (RETURN (COND (EXTENT (EXTENDREGION EXTENT INCLUDEREGION)) - (T (WINDOWPROP WINDOW 'EXTENT (create REGION using INCLUDEREGION]) - -(WIDTHIFWINDOW + (T (WINDOWPROP WINDOW 'EXTENT (create REGION using INCLUDEREGION]) (WIDTHIFWINDOW [LAMBDA (INTERIORWIDTH BORDER) (* ; "Edited 16-Feb-94 12:35 by nilsson") (* ;  "returns the exterior width of a window with interior dimension INTERIORWIDTH") - (IPLUS INTERIORWIDTH (ITIMES 2 (OR BORDER WBorder]) - -(HEIGHTIFWINDOW + (IPLUS INTERIORWIDTH (ITIMES 2 (OR BORDER WBorder]) (HEIGHTIFWINDOW [LAMBDA (INTERIORHEIGHT TITLEFLG BORDER SCREEN) (* ; "Edited 16-Feb-94 12:36 by nilsson") (* ;  "returns the exterior height of a window which has interior height dimension INTERIORHEIGHT") @@ -839,16 +595,7 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r [TITLEFLG (IMINUS (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of SCREEN] (T 0)) - (ITIMES 2 (OR BORDER WBorder]) -) - - - -(* ; "this function should be on LLDISPLAY but Ron has it checked out. Move it later - rrb.") - -(DEFINEQ - -(\DSPUNTRANSFORMREGION + (ITIMES 2 (OR BORDER WBorder]) ) (* ; "this function should be on LLDISPLAY but Ron has it checked out. Move it later - rrb.") (DEFINEQ (\DSPUNTRANSFORMREGION [LAMBDA (REGION DISPLAYDATA) (* rmk%: "30-AUG-83 13:19") (* translates a region from  destination coordinates into display @@ -858,56 +605,4 @@ Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights r (\DSPUNTRANSFORMY (fetch (REGION BOTTOM) of REGION) DISPLAYDATA) (fetch (REGION WIDTH) of REGION) - (fetch (REGION HEIGHT) of REGION]) -) -(RPAQ VertScrollCursor (CURSORCREATE (QUOTE #*(16 16)@A@@@CH@@CH@@GL@@GL@@ON@@CH@@CH@@CH@@CH@@ON@@GL@@GL@@CH@@CH@@A@@ -) (QUOTE NIL) 7 15)) -(RPAQ ScrollUpCursor (CURSORCREATE (QUOTE #*(16 16)@A@@@CH@@CH@@GL@@GL@@ON@@ON@AOO@AOO@@CH@@CH@@CH@@CH@@CH@@CH@@CH@ -) (QUOTE NIL) 7 15)) -(RPAQ ScrollDownCursor (CURSORCREATE (QUOTE #*(16 16)@CH@@CH@@CH@@CH@@CH@@CH@@CH@AOO@AOO@@ON@@ON@@GL@@GL@@CH@@CH@@A@@ -) (QUOTE NIL) 7 15)) -(RPAQ HorizScrollCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@HB@AHC@CHCHGHCLOOONOOONGHCLCHCHAHC@@HB@ -) (QUOTE NIL) 7 5)) -(RPAQ ScrollLeftCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@H@@CH@@OH@COH@OOOOOOOOCOH@@OH@@CH@@@H@ -) (QUOTE NIL) 8 5)) -(RPAQ ScrollRightCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@A@@@AL@@AO@@AOLOOOOOOOO@AOL@AO@@AL@@A@@ -) (QUOTE NIL) 7 5)) -(RPAQ VertThumbCursor (CURSORCREATE (QUOTE #*(16 16)@@@@OH@@@@@@OO@@@@@@OON@@@@@OOOH@@@@OON@@@@@OO@@@@@@OH@@@@@@@@@@ -) (QUOTE NIL) 6 8)) -(RPAQ HorizThumbCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@B@@@B@@@JH@@JH@@JH@BJJ@BJJ@BJJ@JJJHJJJHJJJHJJJHJJJH -) (QUOTE NIL) 6 6)) -(RPAQ WAITINGCURSOR (CURSORCREATE (QUOTE #*(16 16)OOONL@@FF@ALCMGHAOO@@ON@@FL@@CH@@BH@@FL@@MF@AIC@CGMHFGNLOOONOOON -) (QUOTE NIL) 7 8)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \LastInWindow VertScrollCursor ScrollUpCursor ScrollDownCursor ScrollLeftCursor - ScrollRightCursor HorizScrollCursor) -) - -(RPAQ? SCROLLBARWIDTH 24) - -(RPAQ? SCROLLWAITTIME 100) - -(RPAQ? SCROLLBARSHADE 32800) - -(RPAQ? WAITBEFORESCROLLTIME 750) - -(RPAQ? WAITBETWEENSCROLLTIME 100) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(ADDTOVAR GLOBALVARS SCROLLBARWIDTH SCROLLWAITTIME SCROLLBARSHADE WAITBEFORESCROLLTIME - WAITBETWEENSCROLLTIME WAITINGCURSOR) -) -(PUTPROPS WINDOWSCROLL COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1993 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (2653 51801 (SCROLLW 2663 . 3186) (SCROLLBYREPAINTFN 3188 . 16871) (ADJUSTOFFSETS 16873 - . 17264) (CREATESCROLLINGW 17266 . 17497) (IN/SCROLL/BAR? 17499 . 20160) (RELDSPXOFFSET 20162 . 20473 -) (RELDSPYOFFSET 20475 . 20786) (SCROLL.HANDLER 20788 . 30242) (\SCROLL.HANDLER.DOIT 30244 . 34675) ( -\DECODE.EXTENT.USE 34677 . 35019) (\UPDATE.EXTENT.IMAGE 35021 . 40034) (EXTENDPASTHORIZBOUNDARIES -40036 . 40575) (EXTENDPASTVERTBOUNDARIES 40577 . 41115) (REDISPLAYW 41117 . 41274) (FILLWITHBACKGROUND - 41276 . 41672) (UPDATE/SCROLL/REG 41674 . 44559) (WTODSX 44561 . 44927) (WTODSY 44929 . 45297) ( -WXOFFSET 45299 . 46264) (WYOFFSET 46266 . 47235) (BITMAPSCROLLFN 47237 . 47550) (SCROLLBITMAP 47552 . -48907) (REDISPLAYBITMAP 48909 . 49506) (ULREDISPLAYBITMAP 49508 . 50280) (EXTENDEXTENT 50282 . 50813) -(WIDTHIFWINDOW 50815 . 51170) (HEIGHTIFWINDOW 51172 . 51799)) (51904 52636 (\DSPUNTRANSFORMREGION -51914 . 52634))))) -STOP + (fetch (REGION HEIGHT) of REGION]) ) (RPAQ VertScrollCursor (CURSORCREATE (QUOTE #*(16 16)@A@@@CH@@CH@@GL@@GL@@ON@@CH@@CH@@CH@@CH@@ON@@GL@@GL@@CH@@CH@@A@@ ) (QUOTE NIL) 7 15)) (RPAQ ScrollUpCursor (CURSORCREATE (QUOTE #*(16 16)@A@@@CH@@CH@@GL@@GL@@ON@@ON@AOO@AOO@@CH@@CH@@CH@@CH@@CH@@CH@@CH@ ) (QUOTE NIL) 7 15)) (RPAQ ScrollDownCursor (CURSORCREATE (QUOTE #*(16 16)@CH@@CH@@CH@@CH@@CH@@CH@@CH@AOO@AOO@@ON@@ON@@GL@@GL@@CH@@CH@@A@@ ) (QUOTE NIL) 7 15)) (RPAQ HorizScrollCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@HB@AHC@CHCHGHCLOOONOOONGHCLCHCHAHC@@HB@ ) (QUOTE NIL) 7 5)) (RPAQ ScrollLeftCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@H@@CH@@OH@COH@OOOOOOOOCOH@@OH@@CH@@@H@ ) (QUOTE NIL) 8 5)) (RPAQ ScrollRightCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@A@@@AL@@AO@@AOLOOOOOOOO@AOL@AO@@AL@@A@@ ) (QUOTE NIL) 7 5)) (RPAQ VertThumbCursor (CURSORCREATE (QUOTE #*(16 16)@@@@OH@@@@@@OO@@@@@@OON@@@@@OOOH@@@@OON@@@@@OO@@@@@@OH@@@@@@@@@@ ) (QUOTE NIL) 6 8)) (RPAQ HorizThumbCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@B@@@B@@@JH@@JH@@JH@BJJ@BJJ@BJJ@JJJHJJJHJJJHJJJHJJJH ) (QUOTE NIL) 6 6)) (RPAQ WAITINGCURSOR (CURSORCREATE (QUOTE #*(16 16)OOONL@@FF@ALCMGHAOO@@ON@@FL@@CH@@BH@@FL@@MF@AIC@CGMHFGNLOOONOOON ) (QUOTE NIL) 7 8)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LastInWindow VertScrollCursor ScrollUpCursor ScrollDownCursor ScrollLeftCursor ScrollRightCursor HorizScrollCursor) ) (RPAQ? SCROLLBARWIDTH 24) (RPAQ? SCROLLWAITTIME 100) (RPAQ? SCROLLBARSHADE 32800) (RPAQ? WAITBEFORESCROLLTIME 750) (RPAQ? WAITBETWEENSCROLLTIME 100) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR GLOBALVARS SCROLLBARWIDTH SCROLLWAITTIME SCROLLBARSHADE WAITBEFORESCROLLTIME WAITBETWEENSCROLLTIME WAITINGCURSOR) ) (PUTPROPS WINDOWSCROLL COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1993 1994 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2131 51738 (SCROLLW 2141 . 2664) (SCROLLBYREPAINTFN 2666 . 16349) (ADJUSTOFFSETS 16351 . 16742) (CREATESCROLLINGW 16744 . 16975) (IN/SCROLL/BAR? 16977 . 19638) (RELDSPXOFFSET 19640 . 19951 ) (RELDSPYOFFSET 19953 . 20264) (SCROLL.HANDLER 20266 . 30179) (\SCROLL.HANDLER.DOIT 30181 . 34612) ( \DECODE.EXTENT.USE 34614 . 34956) (\UPDATE.EXTENT.IMAGE 34958 . 39971) (EXTENDPASTHORIZBOUNDARIES 39973 . 40512) (EXTENDPASTVERTBOUNDARIES 40514 . 41052) (REDISPLAYW 41054 . 41211) (FILLWITHBACKGROUND 41213 . 41609) (UPDATE/SCROLL/REG 41611 . 44496) (WTODSX 44498 . 44864) (WTODSY 44866 . 45234) ( WXOFFSET 45236 . 46201) (WYOFFSET 46203 . 47172) (BITMAPSCROLLFN 47174 . 47487) (SCROLLBITMAP 47489 . 48844) (REDISPLAYBITMAP 48846 . 49443) (ULREDISPLAYBITMAP 49445 . 50217) (EXTENDEXTENT 50219 . 50750) (WIDTHIFWINDOW 50752 . 51107) (HEIGHTIFWINDOW 51109 . 51736)) (51841 52573 (\DSPUNTRANSFORMREGION 51851 . 52571))))) STOP \ No newline at end of file diff --git a/sources/WINDOWSCROLL.LCOM b/sources/WINDOWSCROLL.LCOM index d279a7f5426d4e8f6c034e20a3b1cb876d41165b..3ea83382a93f7bb06657a633abe78d94d6dcecbb 100644 GIT binary patch delta 1315 zcmbVLzi-n}5N;_T5JUn|k+y(1j4CxlBER=+CpIWFBo49a*p=-xO;xE%Q`1Jcb>yU! z7NJN;upl9jCq|eUDOKloLrl#41uP8w2k;U*4gDboJXm-4?tS-tclUli`M&X{IE<3< zyuBF5EJlEc#EB9syj>V=mzuWMOh2kNoa$Oyb!$~8y=pHx_9jX2>E(JW9(d`dyYAKO zX1c6sIlXLV4P8|ecW?|C5aXGKN0C_;P)cHvL@)!9MbECetBty2FF|dky0&aL$0Z0a z7BX5+l?|x3*MKQ@>j5nY`E|zubCVWp0pj|M6Nv-^OVt*|iZFj4U?lNaB7})WCi03Z zXAL=H$vI$7(o0!A&6!ir?)F8u|4TLS9G65rS^^sVdcefr}6h~60dOaX8CzoTbjuR>6! zvODyAd*IDc;IUz5Pamu7)_i@WY9Gga9pb(mnBZ6r^l4cu0}%z7E?L1MO&j_&jUZ6< zERZA*rXop(Y|2(i>txUv3-iSpRWU6f0uTQFrQtEc@sKSUrfvYiDVWdF+fyvHS-*;} zwsDd`un1+qBngUUDmnQcV9de;*(&NKQ#LKSCx8(LImIk0rU^()9b_Up-GD6;$Pu=P zPj%TMmXheMTN#r5A_9B)ND-d%-;bhpiid)3D08}IWz=9#?q`gAM}xo~*GdPyw?7G)BZOMcb*4TGoVauQ+WlJ> NsVa4krQKZ14S#02*6=Iys{zy03Z_YU@6-@b2u ziWT9T-bm2OfQT;3x+Fd5t(_eN$<4~l;L4AKWD-STQVIK{5(de*AH_Z?i4Xo<-6uuh zi742;SkPp^qE3h|N<7@?N4Lh|`2hqY;CR~~g#H~sl2F|p&H_uN5)Xsk#2)~^K#{Ct zRhP6op$)1fujv8>WX1hOP!4f;F1(a=v|5`C#dq0yqir2;CXZM3n>r4P}$^l!AuyvN*H zdIlS(xlPlvt5-9cMhh}010nqte;sg5!@Sb;%trQL5en_9OX2P3YmQBeFpmA7f@n86 zOqjjSV@;s`SkMToh%T!-#yoIYJ~xBWu;SkyNAcvi)U3`=t1AbeEeGl6Ibr3mD7A9@ zmUa1qCAMBd_nDr#&7E-N;~926e+s5fzB?VxcK>`ov(FFhi$nWw=gjp_rcajceKb3H z{D1mi?)37b^mXp5bHB}5`R=p3@3O9+;-}7fcbZ;Y?J3#SKb8taR>8Syv^qc}6{xA} zu0aiNyEQ8W!!TU4+m=Z^AVhtb&#fU9YTGV#Tp*$d*J_qi+Y$k5IK7Zx-Io-|zP$q& zNnp09SvM{L(p0!&c($`m4eGJ3U z9blr)`vovoj@*4LYG74qmTi|!m9*G?3#hEjyRlO>JeJuX OH^2C>Smau!#k~RRG(9E& From 57680d588dcba4f6ab42fa26000b917028434641 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Wed, 17 Feb 2021 22:52:31 -0800 Subject: [PATCH 06/31] WHEELSCROLL: no action if the wheel moves while in a pop-up scroll bar --- lispusers/WHEELSCROLL | 2 +- lispusers/WHEELSCROLL.LCOM | Bin 3301 -> 2587 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL index e71d6c40..5cb1b473 100644 --- a/lispusers/WHEELSCROLL +++ b/lispusers/WHEELSCROLL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-Feb-2021 22:36:05"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;11 5620 changes to%: (FNS \TEDIT.WHEELSCROLL \SCROLLBARTOMAIN?) previous date%: "16-Feb-2021 16:10:43" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;8) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL CREATESCROLLBARWINDOW \SCROLLBARTOMAIN?) (FNS \TEDIT.WHEELSCROLL) (INITVARS (WHEELSCROLLDELTA 10)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (UP) (* ; "Edited 16-Feb-2021 15:35 by rmk:") (LET ((W (\SCROLLBARTOMAIN?))) (CL:WHEN W (SCROLLW W 0 (CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 16-Feb-2021 14:38 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (INTERRUPTCHAR 520 '(WHEELSCROLL T) T) (INTERRUPTCHAR 521 '(WHEELSCROLL NIL) T) (CHANGENAME 'SCROLL.HANDLER 'CREATEW 'CREATESCROLLBARWINDOW) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window. Otherwise the generic function is called on the Tedit window if the cursor is inside it.") (TEDIT.SETFUNCTION 520 [FUNCTION (LAMBDA NIL (\TEDIT.WHEELSCROLL T] TEDIT.READTABLE) (TEDIT.SETFUNCTION 521 [FUNCTION (LAMBDA NIL (\TEDIT.WHEELSCROLL NIL] TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (SEDIT:ADD-COMMAND 520 '(WHEELSCROLL T)) (SEDIT:ADD-COMMAND 521 '(WHEELSCROLL)) (SEDIT:RESET-COMMANDS))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 15-Feb-2021 14:50 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND [LIST (LIST 520 '(WHEELSCROLL T)) (LIST 521 '(WHEELSCROLL] (LISPINTERRUPTS.WSORIG]) (CREATESCROLLBARWINDOW [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS) (* ; "Edited 16-Feb-2021 14:37 by rmk:") (* ;; "This replaces CREATEW inside SCROLL.HANDLER. WINDOW should be bound to the window that this scroll bar will control. The purpose is to create an unreferenced (LOC) pointer from the controller to the controllee, so that wheel scrolling in the scrollbar can be redirected to the controllee.") (DECLARE (USEDFREE WINDOW)) (LET ((SBW (CREATEW REGION TITLE BORDERSIZE NOOPENFLG PROPS))) (WINDOWPROP SBW 'CONTROLLEELOC (LOC WINDOW)) SBW]) (\SCROLLBARTOMAIN? [LAMBDA NIL (* ; "Edited 16-Feb-2021 22:13 by rmk:") (* ;; "Returns the window that should be wheel scrolled, moving from a scrollbar to its scrollee if necessary.") (LET ((W (WHICHW))) (CL:WHEN W (CL:WHEN (WINDOWPROP W 'CONTROLLEELOC) [SETQ W (VAG (WINDOWPROP W 'CONTROLLEELOC] (GETMOUSESTATE) (\CURSORPOSITION [IPLUS 10 (FETCH LEFT OF (WINDOWPROP W 'REGION] LASTMOUSEY) (SETCURSOR DEFAULTCURSOR) (GETMOUSESTATE))) (* ;; "IN/SCROLL/BAR? in WINDOWSCROLL does nothing if the window doesn't have a SCROLLFN, even though SCROLLW applies SCROLLBYREPAINTFN as a default in that case. So a direct call to SCROLLW might scroll a window that can't be scrolled by moving the mouse into the scrollbar (or so it seems). If we don't exclude this, then odd things like menus would be scrolled that shouldn't be.") (AND (WINDOWPROP W 'SCROLLFN) W]) ) (DEFINEQ (\TEDIT.WHEELSCROLL [LAMBDA (UP) (* ; "Edited 16-Feb-2021 22:35 by rmk:") (* ;; "Called from the TEDIT.READTABLE when the wheel moves and the caret is in the TEDIT (WHICHW) window or its scrollbar.") (LET ((WINDOW (\SCROLLBARTOMAIN?))) (CL:WHEN WINDOW [PROCESS.EVAL (FIND.PROCESS 'MOUSE) `(SCROLLW ,WINDOW 0 ,(CL:IF UP (IMINUS WHEELSCROLLDELTA) WHEELSCROLLDELTA)])]) ) (RPAQ? WHEELSCROLLDELTA 10) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (875 4891 (ENABLEWHEELSCROLL 885 . 1310) (WHEELSCROLL 1312 . 1636) (INSTALL-WHEELSCROLL 1638 . 2819) (LISPINTERRUPTS.WHEELSCROLL 2821 . 3170) (CREATESCROLLBARWINDOW 3172 . 3785) ( \SCROLLBARTOMAIN? 3787 . 4889)) (4892 5475 (\TEDIT.WHEELSCROLL 4902 . 5473))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "17-Feb-2021 22:37:01"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;31 5760 changes to%: (FNS WHEELSCROLL) previous date%: "17-Feb-2021 22:22:29" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;28) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME) (INITVARS (WHEELSCROLLDELTA 10) (WHEELSCROLLSETTLETIME 50)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (DIRECTION DELTA) (* ; "Edited 17-Feb-2021 22:35 by rmk:") (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. Here we try to detect and ignore wheel motions in the first case, we don't yet have the information to solve the second. (This should not be an issue with a trackpad)") (* ;; "") (* ;; "Below we ignore a motion interrupt if it is received when a mouse button is down. We also ignore if the MIDDLE shows up within an interval of WHEELSCROLLSETTLETIME milliseconds.") (CL:WHEN (LET ((W (WHICHW))) (* ;; "Returns the window that should be wheel scrolled, skipping windows that have no SCROLLFN or are pop-up scrollbar window for some other window. ") (* ;; "The behavior of pop-up scrollbars (via IN/SCROLL/BAR? in WINDOWSCROLL) is inconsistent with a direct call to SCROLLW in that SCROLLW uses SCROLLBYREPAINTFN for a window without a SCROLLFN while the pop-up does nothing. We implement th pop-up behavior, otherwise odd windows like those holding menus would scroll in a funky way.") (CL:WHEN [AND W (WINDOWPROP W 'SCROLLFN) (NOT (WINDOWPROP W (CL:IF (EQ DIRECTION 'VERTICAL) 'VERTICALSCROLLBARFOR 'HORIZONTALSCROLLBARFOR)] (CL:WHEN [OR T (AND (MOUSESTATE UP) (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME] (* ;; "Always scroll from the MOUSE process. Need the KWOTE because PROCESS.EVAL uses CL:EVAL which doesn't like raw windows") [PROCESS.EVAL (FIND.PROCESS 'MOUSE) (CL:IF (EQ DIRECTION 'VERTICAL) `(SCROLLW ,(KWOTE W) 0 ,DELTA) `(SCROLLW ,(KWOTE W) ,DELTA 0))]))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I) (CADR I) (CADDR I)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME) ) (RPAQ? WHEELSCROLLDELTA 10) (RPAQ? WHEELSCROLLSETTLETIME 50) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1046 5231 (ENABLEWHEELSCROLL 1056 . 1481) (WHEELSCROLL 1483 . 3887) ( INSTALL-WHEELSCROLL 3889 . 4952) (LISPINTERRUPTS.WHEELSCROLL 4954 . 5229))))) STOP \ No newline at end of file diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM index 4dca4a1dcb9ed46a749d9d56e26f087b90b278cf..f3c48249f5b7fd0308ab6d52cb58f4996952a6cd 100644 GIT binary patch literal 2587 zcmb_dPjBN?5O>N2SXnCC3(BDyA|cs_SpE~oNkHAc*e}gf9ow~?MvE$>ZWFbEw27J) zu^?{y1vu~pICEGEd*+DvHv18n_nb{$lCoN)jU3xEZ{EC_-*0BD1+>E=TJ5lqR$0`E zVK1d5$Voe-P+?I{(~xCJ1@;o+ACbc~rLJmxpN~6o8bHPJs-4lZs%_d9*mleDTBcP2 zt#UrSnvEx;Axy8K0_u-JcJ$Mi{rTu-zW?pnY;tzJA5PEDCi_>T;bipOG2H!&@olw` z_9x@{>`vGYx|D{QpT=QmeBoF+`f66m>;?}sO|TkxTFbHVfM++O<&mTBXE*cDTOe(Q zF^16-X8|4tox8~dvgh;Z-7Ux|7=}@S;n^()uCC=~IW5=1tMYCDysw18_39>^U!GlG zjOK7V#jLbWlz}Scro-%J^xb%RHy4qk$y(&d3cs4~iv_!(t2E-pBE>%al$7r9*WZ;FA93lQy+42G9tccc{~{hQ#9biy z$JgRr7%pt?D?-&B-aj6WU;pOpzIs$BF3aU_$YuHETh@u-s9Y`!=ew5(y;UeL7SwVI0dJ^G%vg^^mcQp=WJV8 zESjn7Dh7xy!s=Gxa*h~ukRxeHOv1FETk|Uv$=>Pqj{$v6^-H5 zp&j?5AOXa08MWUfDaWoCp9Emn#q$X?;j|e4L4wdUTnI_89T4!W%>=>mfPV*;4l_U; z*ENO&7hscYu4c&FAz1Z|1uTwD%hjC6uypmmmy4$A@TOYrS;dI7s0wyeB08!lXDntD zPDzr`2&V$3yq1+Q5K-!C#6o_wmZUV#pZakxNzt!-4C*p8NE32=ys5`=zz6g8WR${0 za<&WbExGEToscvGP4cly6||zM_fi+c7b~U literal 3301 zcmb_e&2HO95SCh`NKz0;uRa75p#jK)R4pm$udQR6TuE#wk|rq&E_{d+3yE6AGAz4j zP!#Ap^xCH|a>&i+zCrso{dQNfsGp=ok-(uiv%{I4*>ApC-QyiUu{Y;-Z({qf{{a&opCOkbQ#c3+Q9C!;r3#om26zAP(g zcQT%xUrF0xkMkgPlPCx(Uo&RFSF7xtUm#$$O03zgvbJR+!1IgIZOGBj=NGfbZ92vd z{j8GnL1XNuFGCVyQs-(iq4dpcdUZ*xw#=kbsg&sStyG3fka^wW5HHIpgf+m%ye^){=v zYu3j)rKX|rP+%!v_qNy6bf2meg$5P&3xz^)@A}b8{1&F-abG;v#0P8gn)slg*DZR= zj~qAiqmXLNoM4$bfi;!_&ds(cc07};ruY@GRdPd$Fd(~0y59|>gj0poi$OJOi_&b6 zuG_#q{u?=CW=ee(`f5&ZXd6X|QIsKx(hOqi5Tl%h$Aip4y>^PlLh-IB(HF%+@AQu! z_I^J-`1`km&xHzgFfCGtKBO9Lp1&6Qfu`7JXXcu-SO3?U^rLrB7uChL6oq=cD-`Ewk>0OM5*qR$fpoJjpM7#y!fY%ncJ|4= zoV2u+Z_+}(Dc^)|r5MYV8+@D><-2^y$ZsDlLP>EENeZ&KI4#y>lnQ2QCp_g@*^T;r zC-hQcjrx4S@w|na7*MXvSG0h8muE3CKwVV`zB+?YH3I|Yw`g(J`_UluVrnsRdrsIz ztM)lH7)jnw25|;;LUvzzzYLFObxA~=nimhr^ zMg*F9eKm~|zl(!dTR^j|TQ0|y;1Pzp>bY(+hzV-RX(%(OZm+7)i3ZuLU&7AN-XCn) zbdN>vE-?6NXJ>&xyy8znP=XOSw7?Zk9PbrcLqV`4iZ!fTY82qDFT%wef`~%6|TQko0FB78+<2E;%0KcC&fQM zEB^INzTa+~nE#K`8Q8Uo`S{h!e0=+*th_9&eCsXdB|2bdX9543grdvSw89UafN;UWwb-j5 zO`+UANp;|7F>09&Dnwyq4tkvMEIR_1#|fw=KgFR-VUxtp!NIy7w*+yI+q^L4n`;Y4 z(uc@kdn0ZD+E91M%_}4p{Ls%1og~#(+Fag8&^rb!JnjZg!f~7Q&^w}ndqL!QklZLf lB0UyPHn<%hZswX9nt^|+L{IW1x($fS;}&Pyc4y+c^A9(m2#Wv! From 97cbd66288686ec55ef64b80d538789b6020c8d9 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Wed, 17 Feb 2021 23:41:40 -0800 Subject: [PATCH 07/31] MACINTERFACE: more consistent recognition of corner and titlebar clicking, and more appropriate ghost regions of reshaping and moving --- lispusers/MACINTERFACE | 2 +- lispusers/MACINTERFACE.LCOM | Bin 6027 -> 7715 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/MACINTERFACE b/lispusers/MACINTERFACE index 7546fc94..76123d56 100644 --- a/lispusers/MACINTERFACE +++ b/lispusers/MACINTERFACE @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "27-Dec-2020 12:06:04"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;54 15486 previous date%: "13-Dec-2020 21:50:49" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;57) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP) (INITVARS (MACINTERFACECORNERMARGIN 25))) (* ;; "Internals") [COMS (FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the write circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMACWINDOW [LAMBDA (WINDOW) (* ; "Edited 7-Dec-2020 17:57 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL)) WINDOW]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (* ;; "Internals") (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-Dec-2020 21:45 by rmk:") (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (* ;; "X and Y in window coordinates") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 13-Dec-2020 20:35 by rmk:") (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET (REGION CORNER (MOUSEX LASTMOUSEX) (MOUSEY LASTMOUSEY)) (SETQ CORNER (INCORNER WINDOW)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "WINDOWREGION includes the attached windows") (SETQ REGION (WINDOWREGION WINDOW 'SHAPEW)) (LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION)) STARTINGREGION) (* ;;  "The hot cornerr of the starting region is the mouse position") [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP MOUSEX MOUSEY)) (LEFTBOTTOM (LIST RIGHT TOP MOUSEX MOUSEY)) (RIGHTTOP (LIST LEFT BOTTOM MOUSEX MOUSEY)) (LEFTTOP (LIST RIGHT BOTTOM MOUSEX MOUSEY)) (SHOULDNT] (SHAPEW WINDOW STARTINGREGION)) T ELSEIF (OR ANYWHERE (INTITLEBAR WINDOW)) THEN (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 3-Dec-2020 14:24 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN WINDOW NIL T]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:58 by rmk:") (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3314 7073 (MACWINDOW 3324 . 3965) (MACWINDOW.SETUP 3967 . 5883) (UNMACWINDOW 5885 . 6264) (MACWINDOW.UNSETUP 6266 . 7071)) (7142 12254 (INTITLEBAR 7152 . 7372) (INCORNER 7374 . 8947) ( MACWINDOW.BUTTONEVENTFN 8949 . 11885) (MACWINDOW.BUTTONEVENTFN.ANYWHERE 11887 . 12252)) (12312 13289 ( MACINT-ADD-EXEC 12322 . 12746) (MACINT-SNAPW 12748 . 13287)) (13290 14249 (TEDIT.MACINTERFACE 13300 . 13918) (TEDIT.SELECTALL 13920 . 14247))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Feb-2021 20:50:07"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;75 21496 changes to%: (FNS MACWINDOW.BUTTONEVENTFN) previous date%: "14-Feb-2021 21:51:47" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;74) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP) (INITVARS (MACWINDOWMARGIN 25))) (* ;; "Internals") [COMS (FNS MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (FNS FB.MAKEHEADINGWINDOW.MACINTERFACE TOTOPW.MACINTERFACE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (specialized to filebrowser)") (MACWINDOW.SETUP 'FB.MAKEHEADINGWINDOW 'FB.MAKEHEADINGWINDOW.MACINTERFACE) (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 13-Feb-2021 19:53 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMACWINDOW [LAMBDA (WINDOW) (* ; "Edited 7-Dec-2020 17:57 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL)) WINDOW]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACWINDOWMARGIN 25) (* ;; "Internals") (DEFINEQ (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 14-Feb-2021 21:51 by rmk:") (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MACWINDOWMARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW WINDOW STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 3-Dec-2020 14:24 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:22 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:58 by rmk:") (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (FB.MAKEHEADINGWINDOW.MACINTERFACE [LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* ; "Edited 13-Feb-2021 23:21 by rmk:") (* ;; "This makes the heading window for a filebrowser, the little black window that has the column headings over the main window. It looks like a titlebar of the main window, our goal here is to make clicking in the heading window behave as if the click had happened in a true title window, so that corners will cause a SHAPE and middle will cause a MOVE. This is achieved by replacing the TOTOPW BUTTONEVENTFN of this window by a function that does the TOTOPW and then invokes the BUTTONEVENTFN of the main window") (* ;; "This function essentially advises the FB.MAKEHEADINGWINDOW in FILEBROWSER--works only if FILEBROWSER was loaded first.") (LET ((HW (MACORIG-FB.MAKEHEADINGWINDOW BROWSERWINDOW WIDTH HEIGHT FONT))) (* ;; "We also mark the height of the attached %"title%" window as the TOPMARGIN of the main window, so that MACWINDOW.BUTTONEVENTFN knows to look outside the putative region.") (WINDOWPROP HW 'BUTTONEVENTFN 'TOTOPW.MACINTERFACE) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HW]) (TOTOPW.MACINTERFACE [LAMBDA (WINDOW) (* ; "Edited 13-Feb-2021 23:27 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MACWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (specialized to filebrowser)") (MACWINDOW.SETUP 'FB.MAKEHEADINGWINDOW 'FB.MAKEHEADINGWINDOW.MACINTERFACE) (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4304 8063 (MACWINDOW 4314 . 4955) (MACWINDOW.SETUP 4957 . 6873) (UNMACWINDOW 6875 . 7254) (MACWINDOW.UNSETUP 7256 . 8061)) (8123 16305 (MACWINDOW.BUTTONEVENTFN 8133 . 13155) ( MACWINDOW.BUTTONEVENTFN.ANYWHERE 13157 . 13522) (NEARTOP 13524 . 13960) (NEARESTCORNER 13962 . 14841) (INCORNER.REGION 14843 . 16303)) (16363 17340 (MACINT-ADD-EXEC 16373 . 16797) (MACINT-SNAPW 16799 . 17338)) (17341 18300 (TEDIT.MACINTERFACE 17351 . 17969) (TEDIT.SELECTALL 17971 . 18298)) (18301 19950 (FB.MAKEHEADINGWINDOW.MACINTERFACE 18311 . 19518) (TOTOPW.MACINTERFACE 19520 . 19948))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.LCOM b/lispusers/MACINTERFACE.LCOM index 72cc73fb3494ead7d92491498fbb494f4acfa099..71a2a9eeed84acc4a890206543d6d9b489b420fe 100644 GIT binary patch delta 2810 zcmai0-H#Jh6rX7kmXE@A*-UrMrp=-EC#N7PfR( zQ6FsN%@B<+A;v@>#1J24-S}cOYodwa4=`bUAwKxdzG;lnbMH()DRG)i=bm%!`TU)8 z?~NC}Jo|BWoC};zRu@k5ex3u~9|`y)e(7d;-XR5Uem`|^p;=vAx!kDLs}-oe-Ds{J zkC^L@BlEQ@;K?LY(7StPX2t`R@*0YIdg)v!!b=g3^Y~oeq?%FUc||sqM88nS^i_3Q z3INZE;UFw7m9Jc?uEN^N@d$X6S^>=8M-HF#L8DoHtG4pyDm8~Z4=46S!9@aGM3in` zRUMMJ@h9tg%5?5KWd1c04;p$dE9X>FR5BWFIhHxz<#*f!8k`4 zd^RtVcYW6%^&OAyth0-BxlBIiqPq#pdf(p}y+l@f$jj|D1~%jb-SgrzBb?o}GL(9ul4OjbjJC6n!FI=Y$F`V{H=vzjI3we?JA`Xta$Ml;Xt zIdgSab2qFiXBIlKYVV7DE zL`p#%fWQk-NXt1Q$WcXh@dbYn8G133&R_*w7=B!e3lWEVrO@)AE)MngOSL#jdRz>nyP#@?VqUTG0^u;Inic7c9ZM(# zNnJD2ikeCrAcY2YNd6%S3=n%=Y&%TNaTNxmjuWtNrR-8 z7ebIH7U{yzQASM1Wfr(#z~Z&nVh9qtcG3W3bo(>F*~Kw`+xt>o>r`0A1;eBfJwh0AMSD8Z$;e9sgb*pMj;T65%zMnFAoTPUV$0Am z!=?VPI0<4!_q3m=ve#6t5NWf2rHje=(N8-((VYs zyyuvDo)`N^58%8c2eYLP$iyIiViT(w^T6ocofgCVY4jA{6^@wGZaC3_PJg2hbclJz zeLYO>7{e0OpNAn4o8P&oS(o{%TQDcb51BCbH0#8p!JgH{6u~cn(kl-?BCl6)hTrM+j=miCDXm~x-^n~K;Navb(3tYQKZ$D&9 z=cWS)w`|Ua9vD7+h{7M-Q)X!*h8g*E;+S2NjbA2yWX;^<;TMPbj@zurhB5mC%T7)^ UjF|bxq%SbkY1fn8BQSCO2T^R!>;M1& delta 1368 zcmZux&2JM&6yMzdPTCq06o(Ka@o?4R6(a1c*Xs}UkY&BLCt2@W>!nUW6@@q=StU*Q z>aDWsYo)5`sH*xQRc`q>aG~4j$H*eniz4!K) z5573}Rc%_$oh_}co>di90i+fcy@(3CS5~B~w)<%A>aEr7t)0!&E!g-3Qg*olNE?~Y z&(Eizb>-Gt3sU=WC0|q&>M141(`9U1re_(xRf5#(Zz1{LJEi|y*s|SadT&N`^MUC_qdeJ^{^B_*v5{JecL*3cu*|m z<7o^EG_g~1n=%L>3WB&WA<(tH@D}@<5{0THRwYRipKks8^ypwxNFx_p)8rF&&cd#8#%W>?OuIE_8r|O_Wdj;x%V43a;m>ytys2N@bJ5-D! zfimPMYSLIOuWXnW_rmRHnD=9%AQ^X>hp$TgVVpc@zE7Ela8=y~R=P~%^8q02yp?i-4d(gEzflUqXa(sP~dZ1Z{N$>q0)CS#JC#W$`&xfAg;OKGS z47yGyaG2d=?ny|i`>DAMs4!w`8BpeRE@@LBT>}qSs{VP`_uU#bEAX@L)}f$)ZIvUH zu7@Y8p!a0b7iY;<%sf3Lo^d{`5aXTKCnP@gJa*3-?or}YO??xp(q?l%w3?vO3Ewv#DpH_PHR@D@3I%p^$RsLcsKUKqmmD8*nc@6I zgP;R`KkEBT4t$rErU@FmA9CLC>8#UQsXF=m?U^w(lOul~OniiLv`=VRS%pzHJ1RHI za7EM#NdI4J==mr}EjQ|{6`;AkoXBMod*{nu^2mcRa(lXaXEPZwPK?=E@<;MS@7c^h(xfcQkS Date: Fri, 19 Feb 2021 11:46:03 -0800 Subject: [PATCH 08/31] EMACS: Removed outdated copies of Tedit functions and dependency on old BQUOTE emulation, so that it now at least loads and compiles. But it doesn't work. --- lispusers/EMACS | 2 +- lispusers/EMACS.LCOM | Bin 38635 -> 33639 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/EMACS b/lispusers/EMACS index 4b9abe8a..b543c34e 100644 --- a/lispusers/EMACS +++ b/lispusers/EMACS @@ -1 +1 @@ -(FILECREATED "27-Jul-86 17:26:37" {ERIS}LISPCORE>EMACS.;7 102965 changes to: (FNS EMACS.OPERATE) previous date: "12-Jul-86 16:55:09" {ERIS}LISPCORE>EMACS.;6) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT EMACSCOMS) (RPAQQ EMACSCOMS ((* EMACS -- By Kelly Roach *) (COMS (* EMACS *) (INITVARS (BytesPerPage 512) (EMACS.COMMANDS NIL) (EMACS.MCOMMANDS NIL) (EMACS.XCOMMANDS NIL) (EMACS.LIST '((1 EMACS.GOTO.BOL) (2 EMACS.BACK.BYTE) (4 EMACS.FWD.DELETE.BYTE) (5 EMACS.GOTO.EOL) (6 EMACS.FWD.BYTE) (9 EMACS.TAB) (11 EMACS.KILL.LINE) (12 EMACS.REDISPLAY) (14 EMACS.NEXT.LINE) (16 EMACS.PREVIOUS.LINE) (17 EMACS.QUOTE.BYTE) (19 EMACS.SEARCH) (20 EMACS.TRANSPOSE.BYTES) (22 EMACS.NEXT.SCREENFULL) (24 EMACS.CX) (26 EMACS.CZ) (41 EMACS.RPAREN) (93 EMACS.RBRACKET) (125 EMACS.RBRACE) (127 EMACS.BACK.DELETE.BYTE))) (EMACS.MLIST '((1 EMACS.GOTO.BOD) (2 EMACS.SAFE.BACK.SEXPR) (5 EMACS.GOTO.EOD) (6 EMACS.FWD.SEXPR) (11 EMACS.KILL.SEXPR) (60 EMACS.GOTO.BOF) (62 EMACS.GOTO.EOF) (66 EMACS.BACK.WORD) (68 EMACS.FWD.DELETE.WORD) (69 EMACS.EDIT) (70 EMACS.FWD.WORD) (71 EMACS.GRIND) (52 EMACS.SNARF) (86 EMACS.PREVIOUS.SCREENFULL) (94 EMACS.JOIN.LINES) (127 EMACS.BACK.DELETE.WORD))) (EMACS.XLIST '((22 EMACS.CXCV) (23 EMACS.CXCW) (26 EMACS.CXCZ))) (\BQUOTE.LEVEL 0)) (RECORDS EMACSSTREAM) (FNS EMACS.INIT EMACS.INIT.BACKGROUND DEDITEmacs EMACS.INIT.COMMANDS EMACS.COMMAND EMACS.OPERATE EMACS.GETKEY EMACS EMACS.PROCESS EMACS.TEDIT1 EMACS.WINDOW EMACS.SETFILEPTR EMACS.GETCARETPTR EMACS.SETCARETPTR EMACS.SHOWCARET EMACS.BOL EMACS.EOL EMACS.DELETE.BYTES EMACS.BOFP EMACS.EOFP EMACS.CCHAR EMACS.PEEKBIN EMACS.FBYTE EMACS.FWORD EMACS.BYTEP EMACS.FSKIP EMACS.FSKIPTO EMACS.BBYTE EMACS.BCHAR EMACS.BPEEKCHAR EMACS.BWORD EMACS.BSKIP EMACS.BSKIPTO EMACS.SET.EOF EMACS.GOTO.BOL EMACS.BACK.BYTE EMACS.FWD.DELETE.BYTE EMACS.GOTO.EOL EMACS.FWD.BYTE EMACS.KILL.LINE EMACS.DELETE.CHARS EMACS.REDISPLAY EMACS.NEXT.LINE EMACS.PREVIOUS.LINE EMACS.QUOTE.BYTE EMACS.SEARCH EMACS.TRANSPOSE.BYTES EMACS.NEXT.SCREENFULL EMACS.CXCV EMACS.CXCW EMACS.CXCZ EMACS.FWD.SEXPR EMACS.BACK.DELETE.BYTE EMACS.GOTO.BOD EMACS.BOD EMACS.GOTO.EOD EMACS.EOD EMACS.KILL.SEXPR EMACS.GOTO.BOF EMACS.GOTO.EOF EMACS.BACK.WORD EMACS.FWD.DELETE.WORD EMACS.EDIT EMACS.FWD.WORD EMACS.GRIND EMACS.SNARF EMACS.MT EMACS.PREVIOUS.SCREENFULL EMACS.JOIN.LINES EMACS.BACK.DELETE.WORD NEW.TEDIT.SELECT.LINE.SCANNER) (FNS \TEDIT1 \TEDIT.COMMAND.LOOP)) (COMS (* BALANCE *) (PROPS (ACCESSFNS EMACS.TAB) (DATATYPE EMACS.TAB) (DEFEXPR EMACS.TAB) (DEFFEXPR EMACS.TAB) (DEFVAR EMACS.TAB) (DO EMACS.TAB) (FOR EMACS.TAB) (LAMBDA EMACS.TAB) (PROG EMACS.TAB) (RECORD EMACS.TAB) (SELECT EMACS.TAB) (SELECTQ EMACS.TAB) (UNTIL EMACS.TAB) (WHILE EMACS.TAB)) (INITVARS (EMACS.DELIMS NIL) (EMACS.SDELIMS NIL) (EMACS.LDELIMS NIL) (EMACS.RDELIMS NIL) (EMACS.SCACHE NIL) (EMACS.BCACHE NIL) (EMACS.SYNTAX NIL) (EMACS.CR 1) (EMACS.WS 2) (EMACS.SD 4) (EMACS.NONCR 8) (EMACS.NONWS 16) (EMACS.NONSD 32) (EMACS.BQ 64) (EMACS.ALPHA 128) (EMACS.BD 256) (EMACS.SPACE 512)) (FNS EMACS.DELIMS EMACS.CR EMACS.RPAREN EMACS.RBRACKET EMACS.RBRACE EMACS.RANGLE EMACS.SDELIM.COMMAND EMACS.LDELIM.COMMAND EMACS.RDELIM.COMMAND EMACS.SDELIM EMACS.LDELIM EMACS.RDELIM EMACS.OPEN.STRING EMACS.CLOSE.STRING EMACS.OPEN.BALANCE EMACS.CLOSE.BALANCE EMACS.FLUSH.CACHE EMACS.SCACHE EMACS.BCACHE EMACS.SAFE.BACK.SEXPRS EMACS.SAFE.BACK.SEXPR EMACS.BACK.SEXPR EMACS.BACK.WORD EMACS.BACK.SKIPSEPRS EMACS.BACK.ESCAPEDP EMACS.TAB EMACS.TAB.INDENT EMACS.INIT.SYNTAX)) (DECLARE: DONTEVAL@LOAD DOCOPY (P (EMACS.INIT) (MOVD? 'TEDIT.SELECT.LINE.SCANNER ' OLD.TEDIT.SELECT.LINE.SCANNER) (MOVD 'NEW.TEDIT.SELECT.LINE.SCANNER ' TEDIT.SELECT.LINE.SCANNER) (MOVD 'EMACS 'TEDIT))))) (* EMACS -- By Kelly Roach *) (* EMACS *) (RPAQ? BytesPerPage 512) (RPAQ? EMACS.COMMANDS NIL) (RPAQ? EMACS.MCOMMANDS NIL) (RPAQ? EMACS.XCOMMANDS NIL) (RPAQ? EMACS.LIST '((1 EMACS.GOTO.BOL) (2 EMACS.BACK.BYTE) (4 EMACS.FWD.DELETE.BYTE) (5 EMACS.GOTO.EOL) (6 EMACS.FWD.BYTE) (9 EMACS.TAB) (11 EMACS.KILL.LINE) (12 EMACS.REDISPLAY) (14 EMACS.NEXT.LINE) (16 EMACS.PREVIOUS.LINE) (17 EMACS.QUOTE.BYTE) (19 EMACS.SEARCH) (20 EMACS.TRANSPOSE.BYTES) (22 EMACS.NEXT.SCREENFULL) (24 EMACS.CX) (26 EMACS.CZ) (41 EMACS.RPAREN) (93 EMACS.RBRACKET) (125 EMACS.RBRACE) (127 EMACS.BACK.DELETE.BYTE))) (RPAQ? EMACS.MLIST '((1 EMACS.GOTO.BOD) (2 EMACS.SAFE.BACK.SEXPR) (5 EMACS.GOTO.EOD) (6 EMACS.FWD.SEXPR) (11 EMACS.KILL.SEXPR) (60 EMACS.GOTO.BOF) (62 EMACS.GOTO.EOF) (66 EMACS.BACK.WORD) (68 EMACS.FWD.DELETE.WORD) (69 EMACS.EDIT) (70 EMACS.FWD.WORD) (71 EMACS.GRIND) (52 EMACS.SNARF) (86 EMACS.PREVIOUS.SCREENFULL) (94 EMACS.JOIN.LINES) (127 EMACS.BACK.DELETE.WORD))) (RPAQ? EMACS.XLIST '((22 EMACS.CXCV) (23 EMACS.CXCW) (26 EMACS.CXCZ))) (RPAQ? \BQUOTE.LEVEL 0) [DECLARE: EVAL@COMPILE (ACCESSFNS EMACSSTREAM ((TEXTOBJ (fetch (STREAM F3) of DATUM)) (WINDOW (fetch (TEXTOBJ SELWINDOW) of (fetch (EMACSSTREAM TEXTOBJ) of DATUM))) (SELECTION (fetch (TEXTOBJ SEL) of (fetch (EMACSSTREAM TEXTOBJ) of DATUM))) (CARETPTR (EMACS.GETCARETPTR DATUM)) (FILEPTR (GETFILEPTR DATUM)) (DIRTY (fetch (TEXTOBJ \DIRTY) of (fetch (EMACSSTREAM TEXTOBJ) of DATUM))) (BCACHE (EMACS.BCACHE DATUM)) (SCACHE (EMACS.SCACHE DATUM)))) ] (DEFINEQ (EMACS.INIT (LAMBDA NIL (* kbr: "12-Jul-86 16:54") (* Initializes EMACS.  *) (PROG NIL (SETQ TEDIT.INTERRUPTS (QUOTE ((7 HELP)))) (SETQ EMACS.READTABLE (COPYREADTABLE FILERDTBL)) (EMACS.INIT.COMMANDS) (EMACS.INIT.SYNTAX) (EMACS.INIT.BACKGROUND) (ADDTOVAR *DEDIT-MENU-COMMANDS* (Emacs DEDITEmacs)) (CHANGECCODE (QUOTE NILL) (QUOTE TTYDISPLAYSTREAM) (QUOTE \TEDIT.COMMAND.LOOP))))) (EMACS.INIT.BACKGROUND (LAMBDA NIL (* kbr: "24-Jul-85 16:36") (* Fix up BackgroundMenu. *) (PROG NIL (SETQ BackgroundMenuCommands (FOR BUCKET IN BackgroundMenuCommands WHEN (NOT (EQ (CAR BUCKET) (QUOTE TEdit))) COLLECT BUCKET)) (ADDTOVAR BackgroundMenuCommands (EMACS (QUOTE (EMACS)) "Opens an Edit Window.")) (SETQ BackgroundMenu NIL) (* BackgroundMenu recreated by WINDOW package next time user buttons background. *) ))) (DEDITEmacs (LAMBDA NIL (* kbr: "24-Jul-85 16:36") (* Fn to let DEDIT call EMACS on DEDIT top selection. *) (PROG (EXPR) (CURSOR T) (SETQ EXPR (CAR (TOPSELECTION))) (SETQ EXPR (READ (EMACS (MKSTRING EXPR) NIL T) EMACS.READTABLE)) (DEDITZAPCAR (TOPSELECTION) EXPR)))) (EMACS.INIT.COMMANDS (LAMBDA NIL (* kbr: "24-Jul-85 16:36") (* Initialize TEDIT.READTABLE. *) (PROG NIL (SETQ EMACS.COMMANDS (ARRAY 128 (QUOTE POINTER) NIL 0)) (SETQ EMACS.MCOMMANDS (ARRAY 128 (QUOTE POINTER) NIL 0)) (SETQ EMACS.XCOMMANDS (ARRAY 128 (QUOTE POINTER) NIL 0)) (FOR BUCKET IN EMACS.LIST DO (SETA EMACS.COMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR BUCKET IN EMACS.MLIST DO (SETA EMACS.MCOMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR BUCKET IN EMACS.XLIST DO (SETA EMACS.XCOMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR I FROM 0 TO 255 DO (TEDIT.SETFUNCTION I (EMACS.COMMAND I) TEDIT.READTABLE))))) (EMACS.COMMAND (LAMBDA (I) (* kbr: "24-Jul-85 16:36") (BQUOTE (LAMBDA (STREAM) (EMACS.OPERATE (\, I) STREAM))))) (EMACS.OPERATE (LAMBDA (STREAM) (* kbr: "27-Jul-86 17:26") (* Accept token from user *) (PROG (TEXTOBJ I N FN PTR CH) (TTYDISPLAYSTREAM (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ TEXTOBJ (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) (while (\SYSBUFP) do (* Handle user type-in) (SETQ I (\GETKEY)) (SETFILEPTR STREAM (fetch (EMACSSTREAM CARETPTR) of STREAM)) (SETQ N 1) (while (EQ I (CHARCODE ^U)) do (SETQ N (ITIMES 4 N)) (SETQ I (\GETKEY))) (SELCHARQ I ((ESC ^Z) (SETQ FN (ELT EMACS.MCOMMANDS (\GETKEY)))) (^X (SETQ FN (ELT EMACS.XCOMMANDS (\GETKEY)))) (COND ((ILESSP I 128) (SETQ FN (ELT EMACS.COMMANDS I))) ((ILESSP I 256) (SETQ FN (ELT EMACS.MCOMMANDS (IDIFFERENCE I 128)))))) (COND ((NULL FN) (* Insert char I N times. *) (* Handle blue pending delete, if there is one.) (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ) (SETQ PTR (GETFILEPTR STREAM)) (COND ((AND (NOT (ZEROP PTR)) (EQ (\BACKPEEKBIN STREAM) (CHARCODE CR)) (NOT (MEMB I (CHARCODE (SP TAB))))) (* Start of a def *) (EMACS.FLUSH.CACHE))) (COND ((IEQP N 1) (TEDIT.\INSERT I SEL TEXTOBJ)) (T (SETQ CH (MKSTRING (CHARACTER I))) (TEDIT.INSERT STREAM (ALLOCSTRING N CH)))) (SETFILEPTR STREAM (IPLUS PTR N))) (T (for J from 1 to N do (APPLY* FN STREAM)) (COND ((AND (ILESSP I 256) (NOT (BITTEST (ELT EMACS.SYNTAX I) (LOGOR EMACS.CR EMACS.SD EMACS.BD)))) (EMACS.FLUSH.CACHE)))))) (EMACS.SHOWCARET STREAM)))) (EMACS.GETKEY (LAMBDA NIL (* kbr: "24-Jul-85 16:36") (PROG (CODE) (CARET (QUOTE OFF)) (SETQ CODE (\GETKEY)) (CARET T) (RETURN CODE)))) (EMACS (LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* kbr: "24-Jul-85 16:36") (PROG (PROCESS) (* Get TEXT. *) (COND ((AND (NOT (NULL TEXT)) (LITATOM TEXT)) (SETQ TEXT (OPENFILE TEXT (QUOTE INPUT) (QUOTE OLD))))) (* Get WINDOW. *) (COND ((NULL WINDOW) (SETQ WINDOW (EMACS.WINDOW DONTSPAWN PROPS)))) (COND (DONTSPAWN (* Don't spawn a process. *) (RETURN (EMACS.TEDIT1 TEXT WINDOW T PROPS))) (T (* Spawn a process. *) (SETQ PROCESS (ADD.PROCESS (BQUOTE (EMACS.PROCESS (QUOTE (\, TEXT)) (QUOTE (\, WINDOW)) (QUOTE (\, PROPS)))) (QUOTE EMACS) (QUOTE NO))) (TTY.PROCESS PROCESS) (RETURN PROCESS)))))) (EMACS.PROCESS (LAMBDA (TEXT WINDOW PROPS) (* kbr: "24-Jul-85 16:36") (PROG NIL (WINDOWPROP WINDOW (QUOTE PROCESS) (THIS.PROCESS)) (RETURN (EMACS.TEDIT1 TEXT WINDOW NIL PROPS))))) (EMACS.TEDIT1 (LAMBDA (TEXT WINDOW UNSPAWNED PROPS) (* kbr: "24-Jul-85 16:36") (PROG (ANSWER) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (RESETSAVE NIL (LIST (QUOTE INPUT) (INFILE T))) (RESETSAVE NIL (LIST (QUOTE OUTPUT) (OUTFILE T))) (SETQ ANSWER (\TEDIT1 TEXT WINDOW UNSPAWNED PROPS))) (RETURN ANSWER)))) (EMACS.WINDOW (LAMBDA (DONTSPAWN PROPS) (* kbr: "24-Jul-85 16:36") (PROG (WINDOW) (COND ((AND DONTSPAWN TEDIT.DEFAULT.WINDOW) (SETQ WINDOW TEDIT.DEFAULT.WINDOW)) (T (SETQ WINDOW (TEDIT.CREATEW "Indicate region for EMACS")))) (WINDOWPROP WINDOW (QUOTE TEDIT.PROPS) PROPS) (RETURN WINDOW)))) (EMACS.SETFILEPTR (LAMBDA (STREAM PTR) (* kbr: "24-Jul-85 16:36") (* Patch around bug in TEDIT SETFILEPTR. *) (PROG NIL (COND ((IGREATERP (GETEOFPTR STREAM) 0) (SETFILEPTR STREAM PTR) (SETFILEPTR STREAM PTR)))))) (EMACS.GETCARETPTR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (PROG (SELECTION ANSWER) (SETQ SELECTION (fetch (EMACSSTREAM SELECTION) of STREAM)) (SETQ ANSWER (SELECTQ (fetch (SELECTION POINT) of SELECTION) (LEFT (SUB1 (fetch (SELECTION CH#) of SELECTION))) (RIGHT (fetch (SELECTION CHLIM) of SELECTION)) (SHOULDNT))) (RETURN ANSWER)))) (EMACS.SETCARETPTR (LAMBDA (STREAM PTR) (* kbr: "24-Jul-85 16:36") (* Move caret to new filepos. *) (PROG (EOF) (SETQ EOF (GETEOFPTR STREAM)) (SETQ PTR (IMIN (IMAX PTR 0) EOF)) (TEDIT.SETSEL STREAM (ADD1 PTR) 0 (QUOTE LEFT)) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.SHOWCARET (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.SETCARETPTR STREAM PTR) (TEDIT.NORMALIZECARET (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.BOL (LAMBDA (STREAM PTR) (* kbr: "24-Jul-85 16:36") (* Beginning of line wrt filepos PTR. *) (PROG (OLDPTR BOL) (SETQ OLDPTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.BSKIP STREAM EMACS.NONCR) (SETQ BOL (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM OLDPTR) (RETURN BOL)))) (EMACS.EOL (LAMBDA (STREAM PTR) (* kbr: "24-Jul-85 16:36") (* End of line wrt filepos PTR. *) (PROG (OLDPTR EOL) (SETQ OLDPTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.FSKIP STREAM EMACS.NONCR) (SETQ EOL (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM OLDPTR) (RETURN EOL)))) (EMACS.DELETE.BYTES (LAMBDA (STREAM PTR1 PTR2) (* kbr: "19-Feb-85 15:11") (* Delete between PTR1 & PTR2 inclusive. *) (PROG (PTR LENGTH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ PTR1 (IMAX 0 PTR1)) (SETQ PTR2 (IMIN (GETEOFPTR STREAM) PTR2)) (SETQ LENGTH (IPLUS PTR2 (IMINUS PTR1) 1)) (TEDIT.DELETE STREAM (ADD1 PTR1) LENGTH) (COND ((ILEQ PTR PTR1) (EMACS.SETFILEPTR STREAM PTR)) ((ILEQ PTR PTR2) (EMACS.SETFILEPTR STREAM PTR1)) (T (EMACS.SETFILEPTR STREAM (IDIFFERENCE PTR LENGTH))))))) (EMACS.BOFP (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (ZEROP (GETFILEPTR STREAM)))) (EMACS.EOFP (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (IEQP (GETFILEPTR STREAM) (GETEOFPTR STREAM)))) (EMACS.CCHAR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Caret char. Char being pointed at by caret. *) (PROG (ANSWER) (SETQ ANSWER (\BIN STREAM)) (\BACKBIN STREAM) (RETURN ANSWER)))) (EMACS.PEEKBIN (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (SETQ ANSWER (\BIN STREAM)) (EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.FBYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:11") (* Forward a char. *) (COND ((NOT (EMACS.EOFP STREAM)) (\BIN STREAM))))) (EMACS.FWORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Forward a word. *) (PROG NIL (EMACS.FSKIP STREAM EMACS.WS) (EMACS.FSKIP STREAM EMACS.NONWS)))) (EMACS.BYTEP (LAMBDA (N) (* kbr: "24-Jul-85 16:38") (AND (SMALLP N) (ILESSP N 256) N))) (EMACS.FSKIP (LAMBDA (STREAM CLASS LIMIT) (* kbr: "24-Jul-85 16:36") (* Skip chars in CLASS. *) (COND ((NULL LIMIT) (SETQ LIMIT (GETEOFPTR STREAM)))) (PROG NIL (while (AND (ILESSP (GETFILEPTR STREAM) LIMIT) (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (EMACS.PEEKBIN STREAM)) 256)) CLASS)) do (\BIN STREAM))))) (EMACS.FSKIPTO (LAMBDA (STREAM CLASS) (* kbr: "24-Jul-85 16:36") (* Skip chars in CLASS. *) (PROG NIL (WHILE (AND (NOT (EMACS.EOFP STREAM)) (NOT (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BIN STREAM)) 256)) CLASS))) DO (* Continue reading. *))))) (EMACS.BBYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Backward a byte. *) (COND ((NOT (EMACS.BOFP STREAM)) (\BACKBIN STREAM))))) (EMACS.BCHAR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backward a char. *) (PROG NIL (COND ((NOT (EMACS.BOFP STREAM)) (\BACKBIN STREAM)))))) (EMACS.BPEEKCHAR (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Backwards peek at char. *) (PROG (PTR BYTE) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BYTE (EMACS.BCHAR STREAM)) (SETFILEPTR STREAM PTR) (RETURN BYTE)))) (EMACS.BWORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backward a word. *) (PROG NIL (EMACS.BSKIP STREAM EMACS.WS) (EMACS.BSKIP STREAM EMACS.NONWS)))) (EMACS.BSKIP (LAMBDA (STREAM CLASS LIMIT) (* kbr: "24-Jul-85 16:36") (* Skip chars in CLASS. *) (COND ((NULL LIMIT) (SETQ LIMIT 0))) (PROG NIL (while (AND (IGREATERP (GETFILEPTR STREAM) LIMIT) (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BACKPEEKBIN STREAM)) 256)) CLASS)) do (\BACKBIN STREAM))))) (EMACS.BSKIPTO (LAMBDA (STREAM CLASS) (* kbr: "24-Jul-85 16:36") (* Skip chars in CLASS. *) (PROG NIL (WHILE (AND (NOT (EMACS.BOFP STREAM)) (NOT (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BACKBIN STREAM)) 256)) CLASS))) DO (* Continue reading. *))))) (EMACS.SET.EOF (LAMBDA (STREAM PTR) (* kbr: "19-Feb-85 15:12") (* Temporarily reset eof of STREAM. *) (PROG NIL (replace (STREAM EPAGE) of STREAM with (LRSH PTR 8)) (replace (STREAM EOFFSET) of STREAM with (LOGAND PTR 255)) (replace (TEXTOBJ TEXTLEN) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with PTR)))) (EMACS.GOTO.BOL (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to beginning of line. *) (PROG NIL (EMACS.BSKIP STREAM EMACS.NONCR)))) (EMACS.BACK.BYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Go back a byte. *) (PROG NIL (EMACS.BBYTE STREAM)))) (EMACS.FWD.DELETE.BYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Delete byte. *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.DELETE.BYTES STREAM PTR PTR)))) (EMACS.GOTO.EOL (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to end of line. *) (PROG NIL (EMACS.FSKIP STREAM EMACS.NONCR)))) (EMACS.FWD.BYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Go forward a byte. *) (PROG NIL (EMACS.FBYTE STREAM)))) (EMACS.KILL.LINE (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Delete a line. *) (PROG (PTR EOL) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.FSKIP STREAM EMACS.NONCR) (SETQ EOL (GETFILEPTR STREAM)) (COND ((IGREATERP EOL PTR) (EMACS.DELETE.CHARS STREAM PTR (SUB1 EOL))) ((ILESSP EOL (GETEOFPTR STREAM)) (EMACS.DELETE.CHARS STREAM EOL EOL))) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.DELETE.CHARS (LAMBDA (STREAM PTR1 PTR2) (* kbr: "18-Jun-86 23:23") (* Delete between PTR1 & PTR2 inclusive. *) (PROG (PTR LENGTH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ PTR1 (IMAX 0 PTR1)) (SETQ PTR2 (IMIN (GETEOFPTR STREAM) PTR2)) (SETQ LENGTH (IPLUS PTR2 (IMINUS PTR1) 1)) (TEDIT.DELETE STREAM (ADD1 PTR1) LENGTH) (COND ((ILEQ PTR PTR1) (SETFILEPTR STREAM PTR)) ((ILEQ PTR PTR2) (SETFILEPTR STREAM PTR1)) (T (SETFILEPTR STREAM (IDIFFERENCE PTR LENGTH))))))) (EMACS.REDISPLAY (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Redisplay EMACS screen. *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (REDISPLAYW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.NEXT.LINE (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go down a line. *) (PROG (PTR BOL EOL NBOL NEOL OFFSET) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* First char on line is at OFFSET = 0.0 *) (SETQ OFFSET (IPLUS PTR (IMINUS BOL))) (SETQ EOL (EMACS.EOL STREAM PTR)) (SETQ NBOL (ADD1 EOL)) (COND ((ILEQ (GETEOFPTR STREAM) NBOL) (EMACS.SETFILEPTR STREAM (GETEOFPTR STREAM))) (T (SETQ NEOL (EMACS.EOL STREAM NBOL)) (SETQ OFFSET (IMIN OFFSET (IDIFFERENCE NEOL NBOL))) (EMACS.SETFILEPTR STREAM (IPLUS NBOL OFFSET))))))) (EMACS.PREVIOUS.LINE (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go up a line. *) (PROG (PTR BOL PBOL PEOL OFFSET) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* First char on line is at OFFSET = 0.0 *) (SETQ OFFSET (IPLUS PTR (IMINUS BOL))) (SETQ PEOL (SUB1 BOL)) (COND ((IGEQ 0 PEOL) (EMACS.SETFILEPTR STREAM 0)) (T (SETQ PBOL (EMACS.BOL STREAM PEOL)) (SETQ OFFSET (IMIN OFFSET (IDIFFERENCE PEOL PBOL))) (EMACS.SETFILEPTR STREAM (IPLUS PBOL OFFSET))))))) (EMACS.QUOTE.BYTE (LAMBDA (STREAM) (* kbr: "18-Jun-86 22:59") (* Quote next byte. *) (PROG (PTR CH) (* TBW: Fix use TEDIT's use of terminal table. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ CH (\GETKEY)) (TEDIT.INSERT STREAM CH (ADD1 PTR)) (EMACS.SETFILEPTR STREAM (ADD1 PTR))))) (EMACS.SEARCH (LAMBDA (STREAM) (* kbr: "18-Jun-86 23:12") (* Case sensitive search, with "*" and "#" wildcards  *) (PROG (PTR TEXTOBJ W OFILE SEL CH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ TEXTOBJ (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) (SETQ W (fetch (EMACSSTREAM WINDOW) of STREAM)) (ERSETQ (RESETLST (RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ) (QUOTE (AND (\TEDIT.MARKINACTIVE OLDVALUE)))) (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with (QUOTE Find)) (SETQ OFILE (WINDOWPROP W (QUOTE TEDIT.LAST.FIND.STRING))) (SETQ OFILE (TEDIT.GETINPUT STREAM "Text to find: " OFILE (CHARCODE (EOL LF ESC ^S)))) (COND (OFILE (WINDOWPROP W (QUOTE TEDIT.LAST.FIND.STRING) OFILE) (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING OFILE) NIL NIL T))) (COND (CH (* We found the target text.) (* Set up SELECTION to be the found text) (replace (SELECTION CH#) of SEL with (CAR CH)) (replace (SELECTION CHLIM) of SEL with (CADR CH)) (replace (SELECTION DCH) of SEL with (ADD1 (IDIFFERENCE (CADR CH) (CAR CH)))) (replace (SELECTION POINT) of SEL with (QUOTE RIGHT)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* And never pending a deletion.) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (EMACS.SETFILEPTR STREAM (EMACS.GETCARETPTR STREAM)) (* And get it into the window *) ) (T (FRESHLINE PROMPTWINDOW) (printout PROMPTWINDOW "String '" OFILE "' not found." T) (\SHOWSEL SEL NIL T) (EMACS.SETFILEPTR STREAM PTR))))) (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with -1)))))) (EMACS.TRANSPOSE.BYTES (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Transpose bytes. *) (PROG (PTR CODE CH) (COND ((OR (EMACS.BOFP STREAM) (EMACS.EOFP STREAM)) (RETURN))) (SETQ PTR (GETFILEPTR STREAM)) (SETQ CODE (\BIN STREAM)) (COND ((NUMBERP CODE) (SETQ CH (MKSTRING (CHARACTER CODE)))) (T (* IMAGEOBJ *) (SETQ CH CODE))) (EMACS.DELETE.BYTES STREAM PTR PTR) (EMACS.SETFILEPTR STREAM (SUB1 PTR)) (TEDIT.INSERT STREAM CH PTR) (EMACS.SETFILEPTR STREAM (ADD1 PTR))))) (EMACS.NEXT.SCREENFULL (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Forward one screenfull. *) (PROG (WINDOW DELTAX DELTAY) (SETQ WINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ DELTAX 0) (SETQ DELTAY (IDIFFERENCE (WINDOWPROP WINDOW (QUOTE HEIGHT)) (FONTPROP (DSPFONT NIL WINDOW) (QUOTE HEIGHT)))) (replace (TEXTOBJ EDITOPACTIVE) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with NIL) (\TEDIT.SCROLLFN WINDOW DELTAX DELTAY)))) (EMACS.CXCV (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Visit a file. *) (PROG (FILE) (SETQ FILE (TEDIT.GETINPUT (fetch (EMACSSTREAM TEXTOBJ) of STREAM) "File to GET:")) (COND ((NULL FILE) (RETURN))) (COND ((fetch (EMACSSTREAM DIRTY) of STREAM) (EMACS.CXCW STREAM))) (TEDIT.GET (fetch (EMACSSTREAM TEXTOBJ) of STREAM) FILE) (EMACS.SETFILEPTR STREAM 0)))) (EMACS.CXCW (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Write buffer out to file. *) (PROG NIL (TEDIT.PUT (fetch (EMACSSTREAM TEXTOBJ) of STREAM))))) (EMACS.CXCZ (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Eval FORM in front of caret in lisp EXEC process. *) (PROG (FORM) (SETQ FORM (READ STREAM EMACS.READTABLE)) (PROCESS.EVAL (QUOTE EXEC) FORM)))) (EMACS.FWD.SEXPR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go forward a sexpr. *) (PROG NIL (RESETLST (* Accept uncaught BQUOTE commas. *) (RESETSAVE \BQUOTELEVEL (IQUOTIENT MAX.FIXP 2)) (READ STREAM EMACS.READTABLE))))) (EMACS.BACK.DELETE.BYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Delete byte in backwards direction. *) (* TBW: Delete selection if there is a selection. *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.DELETE.BYTES STREAM (SUB1 PTR) (SUB1 PTR))))) (EMACS.GOTO.BOD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to top of definition. *) (PROG (CODE) (* Find non-WS immediately preceded by CR. *) (EMACS.BCHAR STREAM) (DO (COND ((EMACS.BOFP STREAM) (RETURN))) (EMACS.BSKIP STREAM EMACS.NONCR) (COND ((BITTEST (ELT EMACS.SYNTAX (EMACS.CCHAR STREAM)) EMACS.NONWS) (RETURN))) (EMACS.BCHAR STREAM))))) (EMACS.BOD (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Determine top of definition. *) (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* Find lparen preceded by CR. *) (EMACS.BSKIP STREAM EMACS.CR) (DO (COND ((EMACS.BOFP STREAM) (RETURN))) (EMACS.BSKIP STREAM EMACS.NONCR) (COND ((EMACS.BOFP STREAM) (RETURN))) (COND ((OR (EMACS.BOFP STREAM) (EQ (\PEEKBIN STREAM) (CHARCODE "("))) (RETURN))) (EMACS.BBYTE STREAM)) (SETQ ANSWER (GETFILEPTR STREAM)) (SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.GOTO.EOD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to top of next definition. *) (PROG (CODE) (* Find non-WS immediately preceded by CR. *) (EMACS.FCHAR STREAM) (DO (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FSKIP STREAM EMACS.NONCR) (EMACS.FCHAR STREAM) (COND ((BITTEST (ELT EMACS.SYNTAX (EMACS.CCHAR STREAM)) EMACS.NONWS) (RETURN))))))) (EMACS.EOD (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Determine top of next definition. *) (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* Find two CRs. *) (EMACS.FSKIP STREAM EMACS.CR) (DO (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FSKIP STREAM EMACS.NONCR) (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FBYTE STREAM) (COND ((OR (EMACS.EOFP STREAM) (EQ (\PEEKBIN STREAM) (CHARCODE CR))) (\BACKBIN STREAM) (RETURN)))) (SETQ ANSWER (GETFILEPTR STREAM)) (SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.KILL.SEXPR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Delete expression. *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (READ STREAM EMACS.READTABLE) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (EMACS.SETFILEPTR STREAM PTR1)))) (EMACS.GOTO.BOF (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to beginning of file. *) (PROG NIL (EMACS.SETFILEPTR STREAM 0)))) (EMACS.GOTO.EOF (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to end of file. *) (PROG NIL (EMACS.SETFILEPTR STREAM (GETEOFPTR STREAM))))) (EMACS.BACK.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backward a word. *) (PROG NIL (EMACS.BWORD STREAM)))) (EMACS.FWD.DELETE.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Delete word. *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (EMACS.FSKIP STREAM EMACS.WS) (EMACS.FSKIP STREAM EMACS.NONWS) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (EMACS.SETFILEPTR STREAM PTR1)))) (EMACS.EDIT (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* DEDIT expression. *) (PROG (EXPR PTR1 PTR2) (SKIPSEPRS STREAM) (SETQ PTR1 (GETFILEPTR STREAM)) (SETQ EXPR (READ STREAM EMACS.READTABLE)) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (SETQ EXPR (EDITE EXPR)) (PRINTDEF EXPR NIL NIL NIL NIL STREAM)))) (EMACS.FWD.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Forward a word. *) (PROG NIL (EMACS.FWORD STREAM)))) (EMACS.GRIND (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Grind expression. *) (PROG (EXPR PTR1 PTR2) (SKIPSEPRS STREAM) (SETQ PTR1 (GETFILEPTR STREAM)) (SETQ EXPR (READ STREAM EMACS.READTABLE)) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (PRINTDEF EXPR NIL NIL NIL NIL STREAM)))) (EMACS.SNARF (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Snarf expression from DEDIT window. *) (PROG (EXPR) (SETQ EXPR (CAR (TOPSELECTION))) (PRINTDEF EXPR NIL NIL NIL NIL STREAM)))) (EMACS.MT (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Transpose words. *) (PROG (PTR BPTR1 BPTR2 FPTR1 FPTR2) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.BSKIP STREAM EMACS.WS) (SETQ BPTR2 (GETFILEPTR STREAM)) (EMACS.BWORD) (SETQ BPTR1 (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.FSKIP STREAM EMACS.WS) (SETQ FPTR1 (GETFILEPTR STREAM)) (EMACS.FWORD STREAM) (SETQ FPTR2 (GETFILEPTR STREAM)) (* How do I move? *) ))) (EMACS.PREVIOUS.SCREENFULL (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backwards a screenfull. *) (PROG (WINDOW DELTAX DELTAY) (SETQ WINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ DELTAX 0) (SETQ DELTAY (IDIFFERENCE (FONTPROP (DSPFONT NIL WINDOW) (QUOTE HEIGHT)) (WINDOWPROP WINDOW (QUOTE HEIGHT)))) (replace (TEXTOBJ EDITOPACTIVE) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with NIL) (\TEDIT.SCROLLFN WINDOW DELTAX DELTAY)))) (EMACS.JOIN.LINES (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Move current line up *) (PROG (PTR BOL EOL PBOL PEOL PTR1 PTR2) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (SETQ EOL (EMACS.EOL STREAM PTR)) (COND ((ZEROP BOL) (RETURN))) (SETQ PEOL (SUB1 BOL)) (SETQ PBOL (EMACS.BOL STREAM PEOL)) (EMACS.SETFILEPTR STREAM BOL) (EMACS.BSKIP STREAM EMACS.WS) (SETQ PTR1 (IMAX (GETFILEPTR STREAM) PBOL)) (EMACS.SETFILEPTR STREAM BOL) (EMACS.FSKIP STREAM EMACS.WS) (SETQ PTR2 (IMIN (GETFILEPTR STREAM) (ADD1 EOL))) (EMACS.SETFILEPTR STREAM PTR1) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (\BOUT STREAM (CHARCODE SP)) (EMACS.SETFILEPTR STREAM (ADD1 PTR1))))) (EMACS.BACK.DELETE.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Delete backward a word. *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (EMACS.BWORD STREAM) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR2 (SUB1 PTR1))))) (NEW.TEDIT.SELECT.LINE.SCANNER (LAMBDA (X Y TEXTOBJ LINE.LIST REGION WORDSELFLG SELOPERATION WINDOW) (* kbr: "24-Jul-85 16:49") (PROG (SELECTION PTR) (SETQ SELECTION (OLD.TEDIT.SELECT.LINE.SCANNER X Y TEXTOBJ LINE.LIST REGION WORDSELFLG SELOPERATION WINDOW)) (COND ((EQ (TYPENAME SELECTION) (QUOTE SELECTION)) (replace (SELECTION POINT) of SELECTION with (QUOTE LEFT)) (EMACS.SETFILEPTR (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (SUB1 (fetch (SELECTION CH#) of SELECTION))))) (EMACS.FLUSH.CACHE) (RETURN SELECTION)))) ) (DEFINEQ (\TEDIT1 (LAMBDA (TEXT WINDOW UNSPAWNED PROPS) (* kbr: "11-Jun-86 23:06") (* Does the actual editing work, and  re-coercion or process kill when done.  Called by TEDIT directly, or  ADD.PROCESSed by it.) (SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL PROPS)) (* Open the text for editing) (\TEDIT.COMMAND.LOOP TEXT) (* Run the editing engine) (CLOSEW WINDOW) (replace \WINDOW of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) with NIL) (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) (QUOTE AFTERQUITFN)) (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) (QUOTE AFTERQUITFN)) WINDOW TEXT)) (* Apply any post-window-close  (and post-QUIT) function) (COND (UNSPAWNED (* We're not a distinct process: Send  back the edited text in some suitable  form) (COND ((NEQ (fetch EDITFINISHEDFLG of (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) T) (PROG1 (fetch EDITFINISHEDFLG of (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) (replace EDITFINISHEDFLG of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) with NIL))) ((STRINGP (fetch TXTFILE of (fetch (TEXTSTREAM TEXTOBJ) of TEXT))) (COERCETEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT) (QUOTE STRINGP))) (T TEXT)))))) (\TEDIT.COMMAND.LOOP (LAMBDA (STREAM RTBL) (* kbr: " 9-Jul-86 18:03") (* Main command loop for the TEDIT  editor. Includes keyboard polling and  command dispatch) (PROG (TEXTOBJ ISCRSTRING SEL WINDOW LINES IPASSSTRING TTYWINDOW) (COND ((type? STREAM STREAM) (SETQ TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) ((type? TEXTOBJ STREAM) (SETQ TEXTOBJ STREAM) (SETQ STREAM (TEXTSTREAM TEXTOBJ))) (T (HELP))) (SETQ ISCRSTRING (ALLOCSTRING \SCRATCHLEN " ")) (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (SETQ WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) (SETQ LINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) (SETQ IPASSSTRING (SUBSTRING ISCRSTRING 1)) (* Used inside \INSERT\TTY\BUFFER) (SETQ RTBL (OR RTBL (fetch (TEXTOBJ TXTRTBL) of TEXTOBJ) TEDIT.READTABLE)) (* Used to derive command characters  from type-in) (for WW inside WINDOW do (WINDOWPROP WW (QUOTE PROCESS) (THIS.PROCESS))) (* And the window to this process) (while (NOT (TTY.PROCESSP)) do (* Wait until we really have the TTY  before proceeding.) (DISMISS 250)) (TTYDISPLAYSTREAM (fetch (EMACSSTREAM WINDOW) of STREAM)) (RESETLST (RESETSAVE (\TEDIT.COMMAND.RESET.SETUP (LIST TEXTOBJ WINDOW) T)) (PROG (CH FN TCH DIRTY BLANKSEEN INSCH# CRSEEN TLEN CHNO READSA TERMSA TEDITSA TEDITFNHASH LOOPFN CHARFN COMMANDFN) (SETQ DIRTY NIL) (SETQ BLANKSEEN NIL) (SETQ CRSEEN NIL) (SETQ READSA (fetch (READTABLEP READSA) of #CURRENTRDTBL#)) (SETQ TERMSA (OR (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ) \PRIMTERMSA)) (SETQ TEDITSA (fetch (READTABLEP READSA) of RTBL)) (SETQ TEDITFNHASH (fetch (READTABLEP READMACRODEFS) of RTBL)) (SETQ LOOPFN (TEXTPROP TEXTOBJ (QUOTE LOOPFN))) (SETQ CHARFN (TEXTPROP TEXTOBJ (QUOTE CHARFN))) (while (NOT (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) do (ERSETQ (PROGN (\WAITFORSYSBUFP 25) (* Await type-in or mouse action) (while (OR TEDIT.SELPENDING (fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ)) do (* Don't do anything while he's  selecting or one of the lock-out ops  is active.) (COND ((EQ TEDIT.SELPENDING TEXTOBJ) (* (OR (EQ TEDIT.SELPENDING TEXTOBJ)  (fetch TCUP of (fetch CARET of TEXTOBJ)))) (* If this TEdit is the one being  selected in, or the caret is  explicitly visible, flash it) (TEDIT.FLASHCARET (fetch (TEXTOBJ CARET) of TEXTOBJ)) )) (BLOCK)) (COND ((fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) (T (COND ((fetch (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ) (* We got here somehow with the window  not in sync with the text.  Run an update.) (\SHOWSEL SEL NIL NIL) (TEDIT.UPDATE.SCREEN TEXTOBJ NIL T) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T))) (TEDIT.FLASHCARET (fetch (TEXTOBJ CARET) of TEXTOBJ)) (* Flash the caret periodically  (BUT not while we're here only to  cleanup and quit.)) (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with T) (* Before starting to work, note that  we're doing something.) (* Process any pending selections) (ERSETQ (COND (TEDIT.COPY.PENDING (* Have to copy the shifted SEL to  caret.) (SETQ TEDIT.COPY.PENDING NIL) (\COPYSEL TEDIT.SHIFTEDSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) (TEDIT.COPY (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ)) (replace (SELECTION SET) of TEDIT.SHIFTEDSELECTION with NIL) (replace (SELECTION L1) of TEDIT.SHIFTEDSELECTION with NIL) (replace (SELECTION LN) of TEDIT.SHIFTEDSELECTION with NIL) (\COPYSEL TEDIT.SHIFTEDSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (TEDIT.COPYLOOKS.PENDING (* Have to copy the shifted SEL to  caret.) (SETQ TEDIT.COPYLOOKS.PENDING NIL) (\COPYSEL TEDIT.COPYLOOKSSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) (COND ((EQ (QUOTE PARA) (fetch (SELECTION SELKIND) of (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (* copy the paragraph looks, since the  source selection type was paragraph) (TEDIT.COPY.PARALOOKS TEXTOBJ (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ))) (T (* copy the character looks) (TEDIT.COPY.LOOKS TEXTOBJ (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ)))) (\SHOWSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) NIL NIL) (replace (SELECTION SET) of TEDIT.COPYLOOKSSELECTION with NIL) (replace (SELECTION L1) of TEDIT.COPYLOOKSSELECTION with NIL) (replace (SELECTION LN) of TEDIT.COPYLOOKSSELECTION with NIL) (\COPYSEL TEDIT.COPYLOOKSSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (TEDIT.MOVE.PENDING (* Have to move the ctrl-shift SEL to  caret.) (SETQ TEDIT.MOVE.PENDING NIL) (\COPYSEL TEDIT.MOVESELECTION (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ ) (TEDIT.MOVE (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ)) (replace (SELECTION SET) of TEDIT.MOVESELECTION with NIL) (replace (SELECTION L1) of TEDIT.MOVESELECTION with NIL) (replace (SELECTION LN) of TEDIT.MOVESELECTION with NIL) (\COPYSEL TEDIT.MOVESELECTION (fetch (TEXTOBJ MOVESEL) of TEXTOBJ))) (TEDIT.DEL.PENDING (* Delete the current selection.) (SETQ TEDIT.DEL.PENDING NIL) (* Above all, reset the demand flag  first) (COND ((fetch (SELECTION SET) of TEDIT.DELETESELECTION ) (* Only try the deletion if he really  set the selection.) (\SHOWSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) NIL NIL) (* Turn off the selection highlights) (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) NIL NIL) (replace (SELECTION SET) of (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) with NIL) (\COPYSEL TEDIT.DELETESELECTION (fetch (TEXTOBJ SEL) of TEXTOBJ)) (\TEDIT.SET.SEL.LOOKS (fetch (TEXTOBJ SEL) of TEXTOBJ) (QUOTE NORMAL)) (* Grab the selection we're to use) (\TEDIT.DELETE (fetch (TEXTOBJ SEL) of TEXTOBJ) (fetch (SELECTION \TEXTOBJ) of (fetch (TEXTOBJ SEL) of TEXTOBJ)) NIL) (replace (SELECTION L1) of TEDIT.DELETESELECTION with NIL) (replace (SELECTION LN) of TEDIT.DELETESELECTION with NIL)))))) (UNINTERRUPTABLY (replace (STRINGP OFFST) of ISCRSTRING with 0) (replace (STRINGP LENGTH) of ISCRSTRING with \SCRATCHLEN )) (COND ((\SYSBUFP) (ERSETQ (EMACS.OPERATE STREAM)))))) (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL))) (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL))))))) ) (* BALANCE *) (PUTPROPS ACCESSFNS EMACS.TAB 2) (PUTPROPS DATATYPE EMACS.TAB 2) (PUTPROPS DEFEXPR EMACS.TAB 2) (PUTPROPS DEFFEXPR EMACS.TAB 2) (PUTPROPS DEFVAR EMACS.TAB 2) (PUTPROPS DO EMACS.TAB 1) (PUTPROPS FOR EMACS.TAB 1) (PUTPROPS LAMBDA EMACS.TAB 2) (PUTPROPS PROG EMACS.TAB 2) (PUTPROPS RECORD EMACS.TAB 2) (PUTPROPS SELECT EMACS.TAB 2) (PUTPROPS SELECTQ EMACS.TAB 2) (PUTPROPS UNTIL EMACS.TAB 1) (PUTPROPS WHILE EMACS.TAB 1) (RPAQ? EMACS.DELIMS NIL) (RPAQ? EMACS.SDELIMS NIL) (RPAQ? EMACS.LDELIMS NIL) (RPAQ? EMACS.RDELIMS NIL) (RPAQ? EMACS.SCACHE NIL) (RPAQ? EMACS.BCACHE NIL) (RPAQ? EMACS.SYNTAX NIL) (RPAQ? EMACS.CR 1) (RPAQ? EMACS.WS 2) (RPAQ? EMACS.SD 4) (RPAQ? EMACS.NONCR 8) (RPAQ? EMACS.NONWS 16) (RPAQ? EMACS.NONSD 32) (RPAQ? EMACS.BQ 64) (RPAQ? EMACS.ALPHA 128) (RPAQ? EMACS.BD 256) (RPAQ? EMACS.SPACE 512) (DEFINEQ (EMACS.DELIMS (LAMBDA (LCHARCODE RCHARCODE) (* kbr: "19-Feb-85 15:13") (* Make LCHARCODE & RCHARCODE into delimiters. If LCHARCODE = RCHARCODE, then string style. Otherwise paren style. *) (PROG (BUCKET) (SETQ BUCKET (CONS LCHARCODE RCHARCODE)) (COND ((MEMBER BUCKET EMACS.DELIMS) (* Already there. *) (RETURN))) (PUSH EMACS.DELIMS BUCKET) (COND ((IEQP LCHARCODE RCHARCODE) (SETSYNTAX LCHARCODE (QUOTE STRINGDELIM) EMACS.READTABLE) (SETA EMACS.SYNTAX LCHARCODE (LOGOR EMACS.NONWS EMACS.NONCR EMACS.SD)) (SETA EMACS.COMMANDS LCHARCODE (EMACS.SDELIM.COMMAND (MKSTRING (CHARACTER LCHARCODE)))) (PUSH EMACS.SDELIMS LCHARCODE)) (T (SETSYNTAX LCHARCODE (QUOTE LEFTPAREN) EMACS.READTABLE) (SETSYNTAX RCHARCODE (QUOTE RIGHTPAREN) EMACS.READTABLE) (FOR I IN (LIST LCHARCODE RCHARCODE) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONCR EMACS.NONWS EMACS.NONSD EMACS.BD))) (SETA EMACS.COMMANDS LCHARCODE (EMACS.LDELIM.COMMAND (MKSTRING (CHARACTER LCHARCODE)))) (SETA EMACS.COMMANDS RCHARCODE (EMACS.RDELIM.COMMAND (MKSTRING (CHARACTER RCHARCODE)))) (PUSH EMACS.LDELIMS LCHARCODE) (PUSH EMACS.RDELIMS RCHARCODE)))))) (EMACS.CR (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM (CHARACTER (CHARCODE CR))) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((NOT (EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE))) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETCARETPTR STREAM EMACS.SCACHE) (DISMISS 1000) (EMACS.SETCARETPTR STREAM (ADD1 PTR)) (SETQ EMACS.SCACHE (QUOTE OUTSIDE)) (SETQ EMACS.BCACHE NIL)))))) (EMACS.RPAREN (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM ")") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.RBRACKET (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM "]") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.RBRACE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM "}") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.RANGLE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM ">") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.SDELIM.COMMAND (LAMBDA (SDELIM) (* kbr: "19-Feb-85 15:14") (* Return sdelim fn to be inserted in EMACS.COMMANDS. SDELIM = 1 letter string. *) (PROG (ANSWER) (SETQ ANSWER (\BQUOTE (LAMBDA (STREAM) (EMACS.SDELIM (\COMMA SDELIM) STREAM)))) (RETURN ANSWER)))) (EMACS.LDELIM.COMMAND (LAMBDA (LDELIM) (* kbr: "19-Feb-85 15:14") (* Return LDELIM fn to be inserted in EMACS.COMMANDS. LDELIM = 1 letter string. *) (PROG (ANSWER) (SETQ ANSWER (\BQUOTE (LAMBDA (STREAM) (EMACS.LDELIM (\COMMA LDELIM) STREAM)))) (RETURN ANSWER)))) (EMACS.RDELIM.COMMAND (LAMBDA (RDELIM) (* kbr: "19-Feb-85 15:14") (* Return RDELIM fn to be inserted in EMACS.COMMANDS. RDELIM = 1 letter string. *) (PROG (ANSWER) (SETQ ANSWER (\BQUOTE (LAMBDA (STREAM) (EMACS.RDELIM (\COMMA RDELIM) STREAM)))) (RETURN ANSWER)))) (EMACS.SDELIM (LAMBDA (SDELIM STREAM) (* kbr: "19-Feb-85 15:14") (* Insert string delimiter SDELIM & update caches. SDELIM = 1 letter string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM SDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.OPEN.STRING STREAM)) (T (EMACS.CLOSE.STRING STREAM)))))) (EMACS.LDELIM (LAMBDA (LDELIM STREAM) (* kbr: "19-Feb-85 15:14") (* Insert LDELIM & update caches. LDELIM = 1 letter string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM LDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.OPEN.BALANCE STREAM)))))) (EMACS.RDELIM (LAMBDA (RDELIM STREAM) (* kbr: "19-Feb-85 15:14") (* Insert RDELIM & update caches. RDELIM = 1 letter string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM RDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.OPEN.STRING (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (LPTR) (* We should be 1 char after left delim. *) (SETQ LPTR (SUB1 (GETFILEPTR STREAM))) (SETQ EMACS.SCACHE LPTR)))) (EMACS.CLOSE.STRING (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (LPTR RPTR LDELIM RDELIM MATCHED) (* We should be 1 char after right delim. *) (SETQ EMACS.SCACHE (QUOTE OUTSIDE)) (SETQ RPTR (SUB1 (GETFILEPTR STREAM))) (EMACS.SETFILEPTR STREAM RPTR) (SETQ RDELIM (\PEEKBIN STREAM)) (EMACS.BSKIP STREAM EMACS.NONSD) (EMACS.BBYTE STREAM) (SETQ LPTR (GETFILEPTR STREAM)) (SETQ LDELIM (\PEEKBIN STREAM)) (SETQ MATCHED (IEQP LDELIM RDELIM)) (COND (MATCHED (EMACS.SETCARETPTR STREAM LPTR) (DISMISS 200)) (T (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETCARETPTR STREAM LPTR) (DISMISS 1000))) (EMACS.SETCARETPTR STREAM (ADD1 RPTR)) (EMACS.SETFILEPTR STREAM (ADD1 RPTR))))) (EMACS.OPEN.BALANCE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (LPTR) (* We should be 1 char after left delim. *) (SETQ LPTR (SUB1 (GETFILEPTR STREAM))) (COND ((NUMBERP EMACS.BCACHE) (* We were at top level. *) (SETQ EMACS.BCACHE (LIST LPTR))) (T (push EMACS.BCACHE LPTR)))))) (EMACS.CLOSE.BALANCE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR LPTR RPTR LDELIM RDELIM BALANCED) (* LPTR & RPTR point at balancing delims *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ RPTR (SUB1 PTR)) (EMACS.SETFILEPTR STREAM RPTR) (SETQ RDELIM (\PEEKBIN STREAM)) (EMACS.BCACHE STREAM) (SETQ BALANCED (NOT (NUMBERP EMACS.BCACHE))) (COND (BALANCED (SETQ LPTR (CAR EMACS.BCACHE)) (EMACS.SETFILEPTR STREAM LPTR) (SETQ LDELIM (\PEEKBIN STREAM)) (EMACS.SETCARETPTR STREAM LPTR) (COND ((IEQP (CDR (ASSOC LDELIM EMACS.DELIMS)) RDELIM) (* Correct match *) (DISMISS 200)) (T (* Flash incorrect match. *) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (DISMISS 1000))) (pop EMACS.BCACHE)) (T (* Flash beginning of non-list def. *) (EMACS.SETCARETPTR STREAM EMACS.BCACHE) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (DISMISS 1000))) (EMACS.SETCARETPTR STREAM PTR) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.FLUSH.CACHE (LAMBDA NIL (* kbr: "19-Feb-85 15:14") (* Lose cached info about string & paren balancing. *) (PROG NIL (* Hopefully we can change things so that not all  commands flush all of cache. *) (SETQ EMACS.SCACHE NIL) (SETQ EMACS.BCACHE NIL)))) (EMACS.SCACHE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Return or OUTSIDE, computing if necessary. *) (PROG (PTR ANSWER) (COND (EMACS.SCACHE (RETURN EMACS.SCACHE))) (* Recompute. *) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM (EMACS.BOL STREAM PTR)) (SETQ ANSWER (QUOTE OUTSIDE)) (while (ILESSP (GETFILEPTR STREAM) PTR) do (* Find opening. *) (EMACS.FSKIP STREAM EMACS.NONSD PTR) (EMACS.FBYTE STREAM) (COND ((IGEQ (GETFILEPTR STREAM) PTR) (RETURN))) (SETQ ANSWER (GETFILEPTR STREAM)) (* Find closing. *) (EMACS.FSKIP STREAM EMACS.NONSD PTR) (EMACS.FBYTE STREAM) (COND ((IGEQ (GETFILEPTR STREAM) PTR) (RETURN))) (SETQ ANSWER (QUOTE OUTSIDE))) (* Store ANSWER, restore fileptr, & return *) (SETQ EMACS.SCACHE ANSWER) (EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.BCACHE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Return ( ... ) or OUTSIDE *) (PROG (PTR SCACHE ANSWER) (COND (EMACS.BCACHE (RETURN EMACS.BCACHE))) (* Recompute. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ SCACHE (EMACS.SCACHE STREAM)) (COND ((NOT (EQ SCACHE (QUOTE OUTSIDE))) (* Move off string. *) (EMACS.SETFILEPTR STREAM SCACHE) (COND ((OR (EMACS.BOFP STREAM) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* A string def! *) (SETQ ANSWER SCACHE) (GO EXIT))))) (COND ((NULL (EMACS.SAFE.BACK.SEXPRS STREAM)) (* Unsuccessful read = unbalanced parens. Treat as if top level. *) (SETQ ANSWER (GETFILEPTR STREAM))) ((OR (ZEROP (GETFILEPTR STREAM)) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* Top level. *) (SETQ ANSWER (GETFILEPTR STREAM))) (T (* Opening delim present. *) (SETQ ANSWER (LIST (SUB1 (GETFILEPTR STREAM)))))) EXIT(EMACS.SETFILEPTR STREAM PTR) (SETQ EMACS.BCACHE ANSWER) (RETURN ANSWER)))) (EMACS.SAFE.BACK.SEXPRS (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Backwards read sexprs up to but not including opening delim. Return T if successful backwards read. Otherwise NIL & leave fileptr near failure point. *) (PROG (ANSWER) (DO (EMACS.BACK.SKIPSEPRS STREAM) (COND ((OR (ZEROP (GETFILEPTR STREAM)) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR)) (AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM)))) (* Up against delimiter. *) (SETQ ANSWER T) (RETURN)) ((NULL (NLSETQ (EMACS.BACK.SEXPR STREAM))) (* Error reading backwards. *) (FLASHWINDOW STREAM) (RETURN)))) (RETURN ANSWER)))) (EMACS.SAFE.BACK.SEXPR (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Return T if successful backwards read. Otherwise NIL & leave fileptr near failure point. *) (PROG NIL (COND ((NULL (NLSETQ (EMACS.BACK.SEXPR STREAM))) (* Error reading backwards. *) (FLASHWINDOW STREAM) (RETURN NIL))) (RETURN T)))) (EMACS.BACK.SEXPR (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (RDELIM LDELIM) (EMACS.BACK.SKIPSEPRS STREAM) (COND ((EMACS.BOFP STREAM) (ERROR!)) ((EMACS.BACK.ESCAPEDP STREAM) (* Atom *) (EMACS.BACK.WORD STREAM) (RETURN))) (SETQ RDELIM (\BACKPEEKBIN STREAM)) (SETQ LDELIM (for BUCKET in EMACS.DELIMS when (IEQP (CDR BUCKET) RDELIM) do (RETURN (CAR BUCKET)))) (COND ((NULL LDELIM) (* Atom *) (EMACS.BACK.WORD STREAM)) ((IEQP LDELIM RDELIM) (* String delimiters *) (\BACKBIN STREAM) (WHILE (AND (NOT (EMACS.BOFP STREAM)) (OR (NOT (IEQP (\BACKPEEKBIN STREAM) LDELIM)) (EMACS.BACK.ESCAPEDP STREAM))) DO (\BACKBIN STREAM)) (COND ((EMACS.BOFP STREAM) (ERROR!))) (\BACKBIN STREAM)) (T (* Left Right delimters *) (\BACKBIN STREAM) (do (EMACS.BACK.SKIPSEPRS STREAM) (COND ((EMACS.BOFP STREAM) (ERROR!)) ((AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM))) (RETURN))) (EMACS.BACK.SEXPR STREAM) (COND ((OR (EMACS.BOFP STREAM) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* At top of definition in middle of read. *) (ERROR!)))) (\BACKBIN STREAM) (EMACS.BSKIP STREAM EMACS.BQ)))))) (EMACS.BACK.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backward a word. *) (PROG NIL (EMACS.BWORD STREAM)))) (EMACS.BACK.SKIPSEPRS (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Backwards SKIPSEPRS. *) (PROG (SA CH SNX) (SETQ SA (fetch (READTABLEP READSA) of EMACS.READTABLE)) (COND ((EMACS.BOFP STREAM) (RETURN))) (SETQ CH (\BACKPEEKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((NOT (EQ SNX SEPRCHAR.RC)) (RETURN))) (\BACKBIN STREAM) (do (COND ((EMACS.BOFP STREAM) (RETURN))) (SETQ CH (\BACKPEEKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((EQ SNX SEPRCHAR.RC) (\BACKBIN STREAM)) ((EQ SNX ESCAPE.RC) (\BIN STREAM) (COND ((NOT (EMACS.BACK.ESCAPEDP STREAM)) (\BACKBIN STREAM))) (RETURN)) (T (RETURN))))))) (EMACS.BACK.ESCAPEDP (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Is the previous byte escaped? *) (PROG (PTR SA CH SNX ANSWER) (* T if previous byte preceded by odd number of %%'s. *) (SETQ PTR (GETFILEPTR STREAM)) (COND ((ILEQ PTR 1) (RETURN NIL))) (SETQ SA (fetch (READTABLEP READSA) of EMACS.READTABLE)) (\BACKBIN STREAM) (do (SETQ CH (\BACKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((EQ SNX ESCAPE.RC) (SETQ ANSWER (NOT ANSWER))) (T (RETURN))) (COND ((EMACS.BOFP STREAM) (RETURN)))) (SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.TAB (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Lisp indent. *) (PROG (PTR BOL EOL CODE INDENT OFFSET TABFLG) (* INDENT = how much we want to indent. OFFSET = how many chars to nonws. TABFLG = any tabs present at beginning of line. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ INDENT (EMACS.TAB.INDENT STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* Calc OFFSET. *) (SETQ EOL (EMACS.EOL STREAM PTR)) (EMACS.SETFILEPTR STREAM BOL) (SETQ OFFSET 0) (for I from BOL to (SUB1 EOL) do (SETQ CODE (\BIN STREAM)) (COND ((EQUAL CODE (CHARCODE TAB)) (SETQ TABFLG T))) (COND ((NOT (BITTEST (ELT EMACS.SYNTAX (OR (NUMBERP CODE) 256)) EMACS.WS)) (RETURN))) (SETQ OFFSET (ADD1 OFFSET))) (* Insert and/or delete whitespace. *) (COND (TABFLG (EMACS.DELETE.BYTES STREAM BOL (IPLUS BOL OFFSET -1)) (COND ((NOT (ZEROP INDENT)) (TEDIT.INSERT STREAM (ALLOCSTRING INDENT " ") (ADD1 BOL))))) ((IEQP OFFSET INDENT) (* Do nothing. *) ) ((IGREATERP OFFSET INDENT) (EMACS.DELETE.BYTES STREAM BOL (IPLUS BOL (IDIFFERENCE OFFSET INDENT) -1))) ((ILESSP OFFSET INDENT) (TEDIT.INSERT STREAM (ALLOCSTRING (IDIFFERENCE INDENT OFFSET) " ") (ADD1 BOL))) (T (SHOULDNT))) (* Reposition fileptr. *) (COND ((ILEQ PTR (IPLUS BOL OFFSET)) (EMACS.SETFILEPTR STREAM (IPLUS BOL INDENT))) (T (EMACS.SETFILEPTR STREAM (IPLUS PTR (IDIFFERENCE INDENT OFFSET)))))))) (EMACS.TAB.INDENT (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Amount to indent for Lisp indent. *) (PROG (PTR BOD SISTER1PTR SISTER2PTR LDELIMFLG SISTER1 SISTERPTR OFFSET BOL ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* SETQ BOD (EMACS.BOD STREAM PTR)) (SETQ BOD 0) (EMACS.SETFILEPTR STREAM (EMACS.BOL STREAM PTR)) (EMACS.BSKIP STREAM EMACS.WS BOD) (* Get SISTER1PTR, SISTER2PTR, & LDELIMFLG *) (do (EMACS.BSKIP STREAM EMACS.SPACE) (COND ((ILEQ (GETFILEPTR STREAM) BOD) (RETURN))) (COND ((AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM))) (SETQ LDELIMFLG T) (RETURN))) (EMACS.SAFE.BACK.SEXPR STREAM) (SETQ SISTER2PTR SISTER1PTR) (SETQ SISTER1PTR (GETFILEPTR STREAM))) (* Get SISTER1. *) (COND (SISTER1PTR (EMACS.SETFILEPTR STREAM SISTER1PTR) (SETQ SISTER1 (RATOM STREAM)))) (* Get SISTERPTR & OFFSET. *) (SETQ SISTERPTR (OR SISTER1PTR (GETFILEPTR STREAM))) (COND ((AND SISTER1 (LITATOM SISTER1)) (SETQ OFFSET (GETPROP SISTER1 (QUOTE EMACS.TAB))))) (COND (OFFSET (SETQ OFFSET (SUB1 OFFSET))) ((NULL SISTER1) (SETQ OFFSET 1)) ((NULL LDELIMFLG) (SETQ OFFSET 0)) ((NULL SISTER2PTR) (SETQ OFFSET 0)) (T (SETQ SISTERPTR SISTER2PTR) (SETQ OFFSET 0))) (* Get ANSWER. *) (SETQ BOL (EMACS.BOL STREAM SISTERPTR)) (EMACS.SETFILEPTR STREAM BOL) (SETQ ANSWER OFFSET) (for I from BOL to (SUB1 SISTERPTR) do (COND ((IEQP (\BIN STREAM) (CHARCODE TAB)) (SETQ ANSWER (IPLUS ANSWER 8))) (T (SETQ ANSWER (ADD1 ANSWER))))) EXIT(EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.INIT.SYNTAX (LAMBDA NIL (* kbr: "19-Feb-85 15:14") (PROG NIL (* "Character" 256 is used to handle IMAGEOBJs. *) (SETQ EMACS.SYNTAX (ARRAY 257 (QUOTE WORD) 0 0)) (FOR I FROM 0 TO 256 DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONCR EMACS.NONWS EMACS.NONSD EMACS.ALPHA))) (FOR I IN (CHARCODE (TAB LF SP)) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.WS EMACS.NONCR EMACS.NONSD EMACS.SPACE))) (SETA EMACS.SYNTAX (CHARCODE CR) (LOGOR EMACS.WS EMACS.CR EMACS.NONSD)) (FOR I IN (QUOTE (39 44 64 96)) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONWS EMACS.NONCR EMACS.NONSD EMACS.BQ EMACS.ALPHA))) (SETQ EMACS.DELIMS NIL) (SETQ EMACS.SDELIMS NIL) (SETQ EMACS.LDELIMS NIL) (SETQ EMACS.RDELIMS NIL) (EMACS.DELIMS (CHARCODE "(") (CHARCODE ")")) (EMACS.DELIMS (CHARCODE "[") (CHARCODE "]")) (EMACS.DELIMS (CHARCODE "{") (CHARCODE "}")) (EMACS.DELIMS 34 34)))) ) (DECLARE: DONTEVAL@LOAD DOCOPY (EMACS.INIT) (MOVD? 'TEDIT.SELECT.LINE.SCANNER 'OLD.TEDIT.SELECT.LINE.SCANNER) (MOVD 'NEW.TEDIT.SELECT.LINE.SCANNER 'TEDIT.SELECT.LINE.SCANNER) (MOVD 'EMACS 'TEDIT) ) (PUTPROPS EMACS COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (9473 52815 (EMACS.INIT 9483 . 10172) (EMACS.INIT.BACKGROUND 10174 . 10893) (DEDITEmacs 10895 . 11408) (EMACS.INIT.COMMANDS 11410 . 12431) (EMACS.COMMAND 12433 . 12629) (EMACS.OPERATE 12631 . 15717) (EMACS.GETKEY 15719 . 15982) (EMACS 15984 . 17010) (EMACS.PROCESS 17012 . 17288) ( EMACS.TEDIT1 17290 . 17746) (EMACS.WINDOW 17748 . 18175) (EMACS.SETFILEPTR 18177 . 18578) ( EMACS.GETCARETPTR 18580 . 19075) (EMACS.SETCARETPTR 19077 . 19692) (EMACS.SHOWCARET 19694 . 20060) ( EMACS.BOL 20062 . 20647) (EMACS.EOL 20649 . 21228) (EMACS.DELETE.BYTES 21230 . 22211) (EMACS.BOFP 22213 . 22362) (EMACS.EOFP 22364 . 22538) (EMACS.CCHAR 22540 . 22913) (EMACS.PEEKBIN 22915 . 23232) ( EMACS.FBYTE 23234 . 23507) (EMACS.FWORD 23509 . 23816) (EMACS.BYTEP 23818 . 23982) (EMACS.FSKIP 23984 . 24527) (EMACS.FSKIPTO 24529 . 25027) (EMACS.BBYTE 25029 . 25307) (EMACS.BCHAR 25309 . 25617) ( EMACS.BPEEKCHAR 25619 . 26020) (EMACS.BWORD 26022 . 26330) (EMACS.BSKIP 26332 . 26856) (EMACS.BSKIPTO 26858 . 27360) (EMACS.SET.EOF 27362 . 27891) (EMACS.GOTO.BOL 27893 . 28168) (EMACS.BACK.BYTE 28170 . 28425) (EMACS.FWD.DELETE.BYTE 28427 . 28751) (EMACS.GOTO.EOL 28753 . 29022) (EMACS.FWD.BYTE 29024 . 29281) (EMACS.KILL.LINE 29283 . 29939) (EMACS.DELETE.CHARS 29941 . 30904) (EMACS.REDISPLAY 30906 . 31309) (EMACS.NEXT.LINE 31311 . 32266) (EMACS.PREVIOUS.LINE 32268 . 33102) (EMACS.QUOTE.BYTE 33104 . 33694) (EMACS.SEARCH 33696 . 38017) (EMACS.TRANSPOSE.BYTES 38019 . 38951) (EMACS.NEXT.SCREENFULL 38953 . 39650) (EMACS.CXCV 39652 . 40382) (EMACS.CXCW 40384 . 40699) (EMACS.CXCZ 40701 . 41083) ( EMACS.FWD.SEXPR 41085 . 41534) (EMACS.BACK.DELETE.BYTE 41536 . 42065) (EMACS.GOTO.BOD 42067 . 42708) ( EMACS.BOD 42710 . 43596) (EMACS.GOTO.EOD 43598 . 44260) (EMACS.EOD 44262 . 45148) (EMACS.KILL.SEXPR 45150 . 45640) (EMACS.GOTO.BOF 45642 . 45979) (EMACS.GOTO.EOF 45981 . 46268) (EMACS.BACK.WORD 46270 . 46526) (EMACS.FWD.DELETE.WORD 46528 . 47066) (EMACS.EDIT 47068 . 47650) (EMACS.FWD.WORD 47652 . 47906) (EMACS.GRIND 47908 . 48448) (EMACS.SNARF 48450 . 48813) (EMACS.MT 48815 . 49569) ( EMACS.PREVIOUS.SCREENFULL 49571 . 50272) (EMACS.JOIN.LINES 50274 . 51483) (EMACS.BACK.DELETE.WORD 51485 . 51926) (NEW.TEDIT.SELECT.LINE.SCANNER 51928 . 52813)) (52816 73467 (\TEDIT1 52826 . 54975) ( \TEDIT.COMMAND.LOOP 54977 . 73465)) (74455 102685 (EMACS.DELIMS 74465 . 76054) (EMACS.CR 76056 . 76838 ) (EMACS.RPAREN 76840 . 77286) (EMACS.RBRACKET 77288 . 77736) (EMACS.RBRACE 77738 . 78184) ( EMACS.RANGLE 78186 . 78632) (EMACS.SDELIM.COMMAND 78634 . 79085) (EMACS.LDELIM.COMMAND 79087 . 79538) (EMACS.RDELIM.COMMAND 79540 . 79991) (EMACS.SDELIM 79993 . 80800) (EMACS.LDELIM 80802 . 81543) ( EMACS.RDELIM 81545 . 82287) (EMACS.OPEN.STRING 82289 . 82635) (EMACS.CLOSE.STRING 82637 . 83809) ( EMACS.OPEN.BALANCE 83811 . 84316) (EMACS.CLOSE.BALANCE 84318 . 86090) (EMACS.FLUSH.CACHE 86092 . 86605 ) (EMACS.SCACHE 86607 . 88255) (EMACS.BCACHE 88257 . 90050) (EMACS.SAFE.BACK.SEXPRS 90052 . 90992) ( EMACS.SAFE.BACK.SEXPR 90994 . 91529) (EMACS.BACK.SEXPR 91531 . 93407) (EMACS.BACK.WORD 93409 . 93665) (EMACS.BACK.SKIPSEPRS 93667 . 94698) (EMACS.BACK.ESCAPEDP 94700 . 95631) (EMACS.TAB 95633 . 98287) ( EMACS.TAB.INDENT 98289 . 101361) (EMACS.INIT.SYNTAX 101363 . 102683))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Feb-2021 11:40:35"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>EMACS.;9 86790 changes to%: (VARS EMACSCOMS) previous date%: "19-Feb-2021 11:24:35" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>EMACS.;6) (* ; " Copyright (c) 1985, 1986, 2021 by Xerox Corporation. ") (PRETTYCOMPRINT EMACSCOMS) (RPAQQ EMACSCOMS [(* EMACS -- By Kelly Roach *) (* ;; "Patched by Ron Kaplan (2021) to require TEDIT and to eliminate a dependency on a historical attempt at BQUOTE.") (* ;; "So it loads, but it really doesn't work.") (* ;; "This has to be compiled with EXPORTS.ALL") (DECLARE%: (FILES TEDIT)) (COMS (* EMACS *) (INITVARS (BytesPerPage 512) (EMACS.COMMANDS NIL) (EMACS.MCOMMANDS NIL) (EMACS.XCOMMANDS NIL) (EMACS.LIST %' ((1 EMACS.GOTO.BOL) (2 EMACS.BACK.BYTE) (4 EMACS.FWD.DELETE.BYTE) (5 EMACS.GOTO.EOL) (6 EMACS.FWD.BYTE) (9 EMACS.TAB) (11 EMACS.KILL.LINE) (12 EMACS.REDISPLAY) (14 EMACS.NEXT.LINE) (16 EMACS.PREVIOUS.LINE) (17 EMACS.QUOTE.BYTE) (19 EMACS.SEARCH) (20 EMACS.TRANSPOSE.BYTES) (22 EMACS.NEXT.SCREENFULL) (24 EMACS.CX) (26 EMACS.CZ) (41 EMACS.RPAREN) (93 EMACS.RBRACKET) (125 EMACS.RBRACE) (127 EMACS.BACK.DELETE.BYTE))) (EMACS.MLIST %' ((1 EMACS.GOTO.BOD) (2 EMACS.SAFE.BACK.SEXPR) (5 EMACS.GOTO.EOD) (6 EMACS.FWD.SEXPR) (11 EMACS.KILL.SEXPR) (60 EMACS.GOTO.BOF) (62 EMACS.GOTO.EOF) (66 EMACS.BACK.WORD) (68 EMACS.FWD.DELETE.WORD) (69 EMACS.EDIT) (70 EMACS.FWD.WORD) (71 EMACS.GRIND) (52 EMACS.SNARF) (86 EMACS.PREVIOUS.SCREENFULL) (94 EMACS.JOIN.LINES) (127 EMACS.BACK.DELETE.WORD))) (EMACS.XLIST %' ((22 EMACS.CXCV) (23 EMACS.CXCW) (26 EMACS.CXCZ))) (\BQUOTE.LEVEL 0)) (RECORDS EMACSSTREAM) (FNS EMACS.INIT EMACS.INIT.BACKGROUND DEDITEmacs EMACS.INIT.COMMANDS EMACS.COMMAND EMACS.OPERATE EMACS.GETKEY EMACS EMACS.PROCESS EMACS.TEDIT1 EMACS.WINDOW EMACS.SETFILEPTR EMACS.GETCARETPTR EMACS.SETCARETPTR EMACS.SHOWCARET EMACS.BOL EMACS.EOL EMACS.DELETE.BYTES EMACS.BOFP EMACS.EOFP EMACS.CCHAR EMACS.PEEKBIN EMACS.FBYTE EMACS.FWORD EMACS.BYTEP EMACS.FSKIP EMACS.FSKIPTO EMACS.BBYTE EMACS.BCHAR EMACS.BPEEKCHAR EMACS.BWORD EMACS.BSKIP EMACS.BSKIPTO EMACS.SET.EOF EMACS.GOTO.BOL EMACS.BACK.BYTE EMACS.FWD.DELETE.BYTE EMACS.GOTO.EOL EMACS.FWD.BYTE EMACS.KILL.LINE EMACS.DELETE.CHARS EMACS.REDISPLAY EMACS.NEXT.LINE EMACS.PREVIOUS.LINE EMACS.QUOTE.BYTE EMACS.SEARCH EMACS.TRANSPOSE.BYTES EMACS.NEXT.SCREENFULL EMACS.CXCV EMACS.CXCW EMACS.CXCZ EMACS.FWD.SEXPR EMACS.BACK.DELETE.BYTE EMACS.GOTO.BOD EMACS.BOD EMACS.GOTO.EOD EMACS.EOD EMACS.KILL.SEXPR EMACS.GOTO.BOF EMACS.GOTO.EOF EMACS.BACK.WORD EMACS.FWD.DELETE.WORD EMACS.EDIT EMACS.FWD.WORD EMACS.GRIND EMACS.SNARF EMACS.MT EMACS.PREVIOUS.SCREENFULL EMACS.JOIN.LINES EMACS.BACK.DELETE.WORD NEW.TEDIT.SELECT.LINE.SCANNER)) (COMS (* BALANCE *) (PROPS (ACCESSFNS EMACS.TAB) (DATATYPE EMACS.TAB) (DEFEXPR EMACS.TAB) (DEFFEXPR EMACS.TAB) (DEFVAR EMACS.TAB) (DO EMACS.TAB) (FOR EMACS.TAB) [LAMBDA EMACS.TAB] (PROG EMACS.TAB) (RECORD EMACS.TAB) (SELECT EMACS.TAB) (SELECTQ EMACS.TAB) (UNTIL EMACS.TAB) (WHILE EMACS.TAB)) (INITVARS (EMACS.DELIMS NIL) (EMACS.SDELIMS NIL) (EMACS.LDELIMS NIL) (EMACS.RDELIMS NIL) (EMACS.SCACHE NIL) (EMACS.BCACHE NIL) (EMACS.SYNTAX NIL) (EMACS.CR 1) (EMACS.WS 2) (EMACS.SD 4) (EMACS.NONCR 8) (EMACS.NONWS 16) (EMACS.NONSD 32) (EMACS.BQ 64) (EMACS.ALPHA 128) (EMACS.BD 256) (EMACS.SPACE 512)) (FNS EMACS.DELIMS EMACS.CR EMACS.RPAREN EMACS.RBRACKET EMACS.RBRACE EMACS.RANGLE EMACS.SDELIM.COMMAND EMACS.LDELIM.COMMAND EMACS.RDELIM.COMMAND EMACS.SDELIM EMACS.LDELIM EMACS.RDELIM EMACS.OPEN.STRING EMACS.CLOSE.STRING EMACS.OPEN.BALANCE EMACS.CLOSE.BALANCE EMACS.FLUSH.CACHE EMACS.SCACHE EMACS.BCACHE EMACS.SAFE.BACK.SEXPRS EMACS.SAFE.BACK.SEXPR EMACS.BACK.SEXPR EMACS.BACK.SKIPSEPRS EMACS.BACK.ESCAPEDP EMACS.TAB EMACS.TAB.INDENT EMACS.INIT.SYNTAX)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (EMACS.INIT) (MOVD? %'TEDIT.SELECT.LINE.SCANNER %' OLD.TEDIT.SELECT.LINE.SCANNER) (MOVD %'NEW.TEDIT.SELECT.LINE.SCANNER %' TEDIT.SELECT.LINE.SCANNER) (MOVD %'EMACS %'TEDIT]) (* EMACS -- By Kelly Roach *) (* ;; "Patched by Ron Kaplan (2021) to require TEDIT and to eliminate a dependency on a historical attempt at BQUOTE." ) (* ;; "So it loads, but it really doesn't work.") (* ;; "This has to be compiled with EXPORTS.ALL") (DECLARE%: (FILESLOAD TEDIT) ) (* EMACS *) (RPAQ? BytesPerPage 512) (RPAQ? EMACS.COMMANDS NIL) (RPAQ? EMACS.MCOMMANDS NIL) (RPAQ? EMACS.XCOMMANDS NIL) (RPAQ? EMACS.LIST %' ((1 EMACS.GOTO.BOL) (2 EMACS.BACK.BYTE) (4 EMACS.FWD.DELETE.BYTE) (5 EMACS.GOTO.EOL) (6 EMACS.FWD.BYTE) (9 EMACS.TAB) (11 EMACS.KILL.LINE) (12 EMACS.REDISPLAY) (14 EMACS.NEXT.LINE) (16 EMACS.PREVIOUS.LINE) (17 EMACS.QUOTE.BYTE) (19 EMACS.SEARCH) (20 EMACS.TRANSPOSE.BYTES) (22 EMACS.NEXT.SCREENFULL) (24 EMACS.CX) (26 EMACS.CZ) (41 EMACS.RPAREN) (93 EMACS.RBRACKET) (125 EMACS.RBRACE) (127 EMACS.BACK.DELETE.BYTE))) (RPAQ? EMACS.MLIST %' ((1 EMACS.GOTO.BOD) (2 EMACS.SAFE.BACK.SEXPR) (5 EMACS.GOTO.EOD) (6 EMACS.FWD.SEXPR) (11 EMACS.KILL.SEXPR) (60 EMACS.GOTO.BOF) (62 EMACS.GOTO.EOF) (66 EMACS.BACK.WORD) (68 EMACS.FWD.DELETE.WORD) (69 EMACS.EDIT) (70 EMACS.FWD.WORD) (71 EMACS.GRIND) (52 EMACS.SNARF) (86 EMACS.PREVIOUS.SCREENFULL) (94 EMACS.JOIN.LINES) (127 EMACS.BACK.DELETE.WORD))) (RPAQ? EMACS.XLIST %' ((22 EMACS.CXCV) (23 EMACS.CXCW) (26 EMACS.CXCZ))) (RPAQ? \BQUOTE.LEVEL 0) (DECLARE%: EVAL@COMPILE (ACCESSFNS EMACSSTREAM ((TEXTOBJ (fetch (STREAM F3) of DATUM)) (WINDOW (fetch (TEXTOBJ SELWINDOW) of (fetch (EMACSSTREAM TEXTOBJ) of DATUM))) (SELECTION (fetch (TEXTOBJ SEL) of (fetch (EMACSSTREAM TEXTOBJ) of DATUM))) (CARETPTR (EMACS.GETCARETPTR DATUM)) (FILEPTR (GETFILEPTR DATUM)) (DIRTY (fetch (TEXTOBJ \DIRTY) of (fetch (EMACSSTREAM TEXTOBJ ) of DATUM))) (BCACHE (EMACS.BCACHE DATUM)) (SCACHE (EMACS.SCACHE DATUM)))) ) (DEFINEQ (EMACS.INIT [LAMBDA NIL (* kbr%: "12-Jul-86 16:54") (* Initializes EMACS.  *) (PROG NIL [SETQ TEDIT.INTERRUPTS '((7 HELP] (SETQ EMACS.READTABLE (COPYREADTABLE FILERDTBL)) (EMACS.INIT.COMMANDS) (EMACS.INIT.SYNTAX) (EMACS.INIT.BACKGROUND) (ADDTOVAR *DEDIT-MENU-COMMANDS* (Emacs DEDITEmacs)) (CHANGECCODE 'NILL 'TTYDISPLAYSTREAM '\TEDIT.COMMAND.LOOP]) (EMACS.INIT.BACKGROUND [LAMBDA NIL (* kbr%: "24-Jul-85 16:36") (* Fix up BackgroundMenu.  *) (PROG NIL (SETQ BackgroundMenuCommands (FOR BUCKET IN BackgroundMenuCommands WHEN (NOT (EQ (CAR BUCKET) 'TEdit)) COLLECT BUCKET)) (ADDTOVAR BackgroundMenuCommands (EMACS '(EMACS) "Opens an Edit Window.")) (SETQ BackgroundMenu NIL) (* BackgroundMenu recreated by  WINDOW package next time user  buttons background.  *) ]) (DEDITEmacs [LAMBDA NIL (* kbr%: "24-Jul-85 16:36") (* Fn to let DEDIT call EMACS on  DEDIT top selection.  *) (PROG (EXPR) (CURSOR T) (SETQ EXPR (CAR (TOPSELECTION))) (SETQ EXPR (READ (EMACS (MKSTRING EXPR) NIL T) EMACS.READTABLE)) (DEDITZAPCAR (TOPSELECTION) EXPR]) (EMACS.INIT.COMMANDS [LAMBDA NIL (* kbr%: "24-Jul-85 16:36") (* Initialize TEDIT.READTABLE.  *) (PROG NIL (SETQ EMACS.COMMANDS (ARRAY 128 'POINTER NIL 0)) (SETQ EMACS.MCOMMANDS (ARRAY 128 'POINTER NIL 0)) (SETQ EMACS.XCOMMANDS (ARRAY 128 'POINTER NIL 0)) (FOR BUCKET IN EMACS.LIST DO (SETA EMACS.COMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR BUCKET IN EMACS.MLIST DO (SETA EMACS.MCOMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR BUCKET IN EMACS.XLIST DO (SETA EMACS.XCOMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR I FROM 0 TO 255 DO (TEDIT.SETFUNCTION I (EMACS.COMMAND I) TEDIT.READTABLE]) (EMACS.COMMAND [LAMBDA (I) (* kbr%: "24-Jul-85 16:36") `(LAMBDA (STREAM) (EMACS.OPERATE ,I STREAM]) (EMACS.OPERATE [LAMBDA (STREAM) (* kbr%: "27-Jul-86 17:26") (* Accept token from user *) (PROG (TEXTOBJ I N FN PTR CH) (TTYDISPLAYSTREAM (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ TEXTOBJ (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) [while (\SYSBUFP) do (* Handle user type-in) (SETQ I (\GETKEY)) (SETFILEPTR STREAM (fetch (EMACSSTREAM CARETPTR) of STREAM)) (SETQ N 1) (while (EQ I (CHARCODE ^U)) do (SETQ N (ITIMES 4 N)) (SETQ I (\GETKEY))) [SELCHARQ I ((ESC ^Z) (SETQ FN (ELT EMACS.MCOMMANDS (\GETKEY)))) (^X (SETQ FN (ELT EMACS.XCOMMANDS (\GETKEY)))) (COND ((ILESSP I 128) (SETQ FN (ELT EMACS.COMMANDS I))) ((ILESSP I 256) (SETQ FN (ELT EMACS.MCOMMANDS (IDIFFERENCE I 128] (COND ((NULL FN) (* Insert char I N times.  *) (* Handle blue pending delete, if  there is one.) (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ) (SETQ PTR (GETFILEPTR STREAM)) (COND ([AND (NOT (ZEROP PTR)) (EQ (\BACKPEEKBIN STREAM) (CHARCODE CR)) (NOT (MEMB I (CHARCODE (SP TAB] (* Start of a def *) (EMACS.FLUSH.CACHE))) [COND ((IEQP N 1) (TEDIT.\INSERT I SEL TEXTOBJ)) (T (SETQ CH (MKSTRING (CHARACTER I))) (TEDIT.INSERT STREAM (ALLOCSTRING N CH] (SETFILEPTR STREAM (IPLUS PTR N))) (T (for J from 1 to N do (APPLY* FN STREAM)) (COND ([AND (ILESSP I 256) (NOT (BITTEST (ELT EMACS.SYNTAX I) (LOGOR EMACS.CR EMACS.SD EMACS.BD] (EMACS.FLUSH.CACHE] (EMACS.SHOWCARET STREAM]) (EMACS.GETKEY [LAMBDA NIL (* kbr%: "24-Jul-85 16:36") (PROG (CODE) (CARET 'OFF) (SETQ CODE (\GETKEY)) (CARET T) (RETURN CODE]) (EMACS [LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* kbr%: "24-Jul-85 16:36") (PROG (PROCESS) (* Get TEXT. *) [COND ((AND (NOT (NULL TEXT)) (LITATOM TEXT)) (SETQ TEXT (OPENFILE TEXT 'INPUT 'OLD] (* Get WINDOW. *) [COND ((NULL WINDOW) (SETQ WINDOW (EMACS.WINDOW DONTSPAWN PROPS] (COND (DONTSPAWN (* Don't spawn a process.  *) (RETURN (EMACS.TEDIT1 TEXT WINDOW T PROPS))) (T (* Spawn a process.  *) (SETQ PROCESS (ADD.PROCESS `(EMACS.PROCESS ',TEXT ',WINDOW ',PROPS) 'EMACS 'NO)) (TTY.PROCESS PROCESS) (RETURN PROCESS]) (EMACS.PROCESS [LAMBDA (TEXT WINDOW PROPS) (* kbr%: "24-Jul-85 16:36") (PROG NIL (WINDOWPROP WINDOW 'PROCESS (THIS.PROCESS)) (RETURN (EMACS.TEDIT1 TEXT WINDOW NIL PROPS]) (EMACS.TEDIT1 [LAMBDA (TEXT WINDOW UNSPAWNED PROPS) (* kbr%: "24-Jul-85 16:36") (PROG (ANSWER) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (RESETSAVE NIL (LIST 'INPUT (INFILE T))) (RESETSAVE NIL (LIST 'OUTPUT (OUTFILE T))) (SETQ ANSWER (\TEDIT1 TEXT WINDOW UNSPAWNED PROPS))) (RETURN ANSWER]) (EMACS.WINDOW [LAMBDA (DONTSPAWN PROPS) (* kbr%: "24-Jul-85 16:36") (PROG (WINDOW) [COND ((AND DONTSPAWN TEDIT.DEFAULT.WINDOW) (SETQ WINDOW TEDIT.DEFAULT.WINDOW)) (T (SETQ WINDOW (TEDIT.CREATEW "Indicate region for EMACS"] (WINDOWPROP WINDOW 'TEDIT.PROPS PROPS) (RETURN WINDOW]) (EMACS.SETFILEPTR [LAMBDA (STREAM PTR) (* kbr%: "24-Jul-85 16:36") (* Patch around bug in TEDIT  SETFILEPTR. *) (PROG NIL (COND ((IGREATERP (GETEOFPTR STREAM) 0) (SETFILEPTR STREAM PTR) (SETFILEPTR STREAM PTR]) (EMACS.GETCARETPTR [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (PROG (SELECTION ANSWER) (SETQ SELECTION (fetch (EMACSSTREAM SELECTION) of STREAM)) (SETQ ANSWER (SELECTQ (fetch (SELECTION POINT) of SELECTION) (LEFT (SUB1 (fetch (SELECTION CH#) of SELECTION))) (RIGHT (fetch (SELECTION CHLIM) of SELECTION)) (SHOULDNT))) (RETURN ANSWER]) (EMACS.SETCARETPTR [LAMBDA (STREAM PTR) (* kbr%: "24-Jul-85 16:36") (* Move caret to new filepos.  *) (PROG (EOF) (SETQ EOF (GETEOFPTR STREAM)) (SETQ PTR (IMIN (IMAX PTR 0) EOF)) (TEDIT.SETSEL STREAM (ADD1 PTR) 0 'LEFT) (EMACS.SETFILEPTR STREAM PTR]) (EMACS.SHOWCARET [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.SETCARETPTR STREAM PTR) (TEDIT.NORMALIZECARET (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) (EMACS.SETFILEPTR STREAM PTR]) (EMACS.BOL [LAMBDA (STREAM PTR) (* kbr%: "24-Jul-85 16:36") (* Beginning of line wrt filepos  PTR. *) (PROG (OLDPTR BOL) (SETQ OLDPTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.BSKIP STREAM EMACS.NONCR) (SETQ BOL (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM OLDPTR) (RETURN BOL]) (EMACS.EOL [LAMBDA (STREAM PTR) (* kbr%: "24-Jul-85 16:36") (* End of line wrt filepos PTR.  *) (PROG (OLDPTR EOL) (SETQ OLDPTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.FSKIP STREAM EMACS.NONCR) (SETQ EOL (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM OLDPTR) (RETURN EOL]) (EMACS.DELETE.BYTES [LAMBDA (STREAM PTR1 PTR2) (* kbr%: "19-Feb-85 15:11") (* Delete between PTR1 & PTR2  inclusive. *) (PROG (PTR LENGTH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ PTR1 (IMAX 0 PTR1)) (SETQ PTR2 (IMIN (GETEOFPTR STREAM) PTR2)) (SETQ LENGTH (IPLUS PTR2 (IMINUS PTR1) 1)) (TEDIT.DELETE STREAM (ADD1 PTR1) LENGTH) (COND ((ILEQ PTR PTR1) (EMACS.SETFILEPTR STREAM PTR)) ((ILEQ PTR PTR2) (EMACS.SETFILEPTR STREAM PTR1)) (T (EMACS.SETFILEPTR STREAM (IDIFFERENCE PTR LENGTH]) (EMACS.BOFP [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (ZEROP (GETFILEPTR STREAM]) (EMACS.EOFP [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (IEQP (GETFILEPTR STREAM) (GETEOFPTR STREAM]) (EMACS.CCHAR [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Caret char. Char being pointed at  by caret. *) (PROG (ANSWER) (SETQ ANSWER (\BIN STREAM)) (\BACKBIN STREAM) (RETURN ANSWER]) (EMACS.PEEKBIN [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (SETQ ANSWER (\BIN STREAM)) (EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER]) (EMACS.FBYTE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:11") (* Forward a char.  *) (COND ((NOT (EMACS.EOFP STREAM)) (\BIN STREAM]) (EMACS.FWORD [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Forward a word.  *) (PROG NIL (EMACS.FSKIP STREAM EMACS.WS) (EMACS.FSKIP STREAM EMACS.NONWS]) (EMACS.BYTEP [LAMBDA (N) (* kbr%: "24-Jul-85 16:38") (AND (SMALLP N) (ILESSP N 256) N]) (EMACS.FSKIP [LAMBDA (STREAM CLASS LIMIT) (* kbr%: "24-Jul-85 16:36") (* Skip chars in CLASS.  *) [COND ((NULL LIMIT) (SETQ LIMIT (GETEOFPTR STREAM] (PROG NIL (while (AND (ILESSP (GETFILEPTR STREAM) LIMIT) (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (EMACS.PEEKBIN STREAM)) 256)) CLASS)) do (\BIN STREAM]) (EMACS.FSKIPTO [LAMBDA (STREAM CLASS) (* kbr%: "24-Jul-85 16:36") (* Skip chars in CLASS.  *) (PROG NIL (WHILE (AND (NOT (EMACS.EOFP STREAM)) (NOT (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BIN STREAM)) 256)) CLASS))) DO (* Continue reading.  *)]) (EMACS.BBYTE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Backward a byte.  *) (COND ((NOT (EMACS.BOFP STREAM)) (\BACKBIN STREAM]) (EMACS.BCHAR [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Backward a char.  *) (PROG NIL (COND ((NOT (EMACS.BOFP STREAM)) (\BACKBIN STREAM]) (EMACS.BPEEKCHAR [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Backwards peek at char.  *) (PROG (PTR BYTE) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BYTE (EMACS.BCHAR STREAM)) (SETFILEPTR STREAM PTR) (RETURN BYTE]) (EMACS.BWORD [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Backward a word.  *) (PROG NIL (EMACS.BSKIP STREAM EMACS.WS) (EMACS.BSKIP STREAM EMACS.NONWS]) (EMACS.BSKIP [LAMBDA (STREAM CLASS LIMIT) (* kbr%: "24-Jul-85 16:36") (* Skip chars in CLASS.  *) (COND ((NULL LIMIT) (SETQ LIMIT 0))) (PROG NIL (while (AND (IGREATERP (GETFILEPTR STREAM) LIMIT) (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BACKPEEKBIN STREAM)) 256)) CLASS)) do (\BACKBIN STREAM]) (EMACS.BSKIPTO [LAMBDA (STREAM CLASS) (* kbr%: "24-Jul-85 16:36") (* Skip chars in CLASS.  *) (PROG NIL (WHILE (AND (NOT (EMACS.BOFP STREAM)) (NOT (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BACKBIN STREAM)) 256)) CLASS))) DO (* Continue reading.  *)]) (EMACS.SET.EOF [LAMBDA (STREAM PTR) (* kbr%: "19-Feb-85 15:12") (* Temporarily reset eof of STREAM.  *) (PROG NIL (replace (STREAM EPAGE) of STREAM with (LRSH PTR 8)) (replace (STREAM EOFFSET) of STREAM with (LOGAND PTR 255)) (replace (TEXTOBJ TEXTLEN) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with PTR]) (EMACS.GOTO.BOL [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go to beginning of line.  *) (PROG NIL (EMACS.BSKIP STREAM EMACS.NONCR]) (EMACS.BACK.BYTE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Go back a byte.  *) (PROG NIL (EMACS.BBYTE STREAM]) (EMACS.FWD.DELETE.BYTE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Delete byte. *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.DELETE.BYTES STREAM PTR PTR]) (EMACS.GOTO.EOL [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go to end of line.  *) (PROG NIL (EMACS.FSKIP STREAM EMACS.NONCR]) (EMACS.FWD.BYTE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Go forward a byte.  *) (PROG NIL (EMACS.FBYTE STREAM]) (EMACS.KILL.LINE [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Delete a line. *) (PROG (PTR EOL) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.FSKIP STREAM EMACS.NONCR) (SETQ EOL (GETFILEPTR STREAM)) (COND ((IGREATERP EOL PTR) (EMACS.DELETE.CHARS STREAM PTR (SUB1 EOL))) ((ILESSP EOL (GETEOFPTR STREAM)) (EMACS.DELETE.CHARS STREAM EOL EOL))) (EMACS.SETFILEPTR STREAM PTR]) (EMACS.DELETE.CHARS [LAMBDA (STREAM PTR1 PTR2) (* kbr%: "18-Jun-86 23:23") (* Delete between PTR1 & PTR2  inclusive. *) (PROG (PTR LENGTH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ PTR1 (IMAX 0 PTR1)) (SETQ PTR2 (IMIN (GETEOFPTR STREAM) PTR2)) (SETQ LENGTH (IPLUS PTR2 (IMINUS PTR1) 1)) (TEDIT.DELETE STREAM (ADD1 PTR1) LENGTH) (COND ((ILEQ PTR PTR1) (SETFILEPTR STREAM PTR)) ((ILEQ PTR PTR2) (SETFILEPTR STREAM PTR1)) (T (SETFILEPTR STREAM (IDIFFERENCE PTR LENGTH]) (EMACS.REDISPLAY [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Redisplay EMACS screen.  *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (REDISPLAYW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETFILEPTR STREAM PTR]) (EMACS.NEXT.LINE [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go down a line.  *) (PROG (PTR BOL EOL NBOL NEOL OFFSET) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* First char on line is at OFFSET =  0.0 *) (SETQ OFFSET (IPLUS PTR (IMINUS BOL))) (SETQ EOL (EMACS.EOL STREAM PTR)) (SETQ NBOL (ADD1 EOL)) (COND ((ILEQ (GETEOFPTR STREAM) NBOL) (EMACS.SETFILEPTR STREAM (GETEOFPTR STREAM))) (T (SETQ NEOL (EMACS.EOL STREAM NBOL)) (SETQ OFFSET (IMIN OFFSET (IDIFFERENCE NEOL NBOL))) (EMACS.SETFILEPTR STREAM (IPLUS NBOL OFFSET]) (EMACS.PREVIOUS.LINE [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go up a line. *) (PROG (PTR BOL PBOL PEOL OFFSET) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* First char on line is at OFFSET =  0.0 *) (SETQ OFFSET (IPLUS PTR (IMINUS BOL))) (SETQ PEOL (SUB1 BOL)) (COND ((IGEQ 0 PEOL) (EMACS.SETFILEPTR STREAM 0)) (T (SETQ PBOL (EMACS.BOL STREAM PEOL)) (SETQ OFFSET (IMIN OFFSET (IDIFFERENCE PEOL PBOL))) (EMACS.SETFILEPTR STREAM (IPLUS PBOL OFFSET]) (EMACS.QUOTE.BYTE [LAMBDA (STREAM) (* kbr%: "18-Jun-86 22:59") (* Quote next byte.  *) (PROG (PTR CH) (* TBW%: Fix use TEDIT's use of  terminal table. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ CH (\GETKEY)) (TEDIT.INSERT STREAM CH (ADD1 PTR)) (EMACS.SETFILEPTR STREAM (ADD1 PTR]) (EMACS.SEARCH [LAMBDA (STREAM) (* kbr%: "18-Jun-86 23:12") (* Case sensitive search, with "*"  and "#" wildcards *) (PROG (PTR TEXTOBJ W OFILE SEL CH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ TEXTOBJ (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) (SETQ W (fetch (EMACSSTREAM WINDOW) of STREAM)) (ERSETQ (RESETLST [RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ) '(AND (\TEDIT.MARKINACTIVE OLDVALUE] (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with 'Find) (SETQ OFILE (WINDOWPROP W 'TEDIT.LAST.FIND.STRING)) [SETQ OFILE (TEDIT.GETINPUT STREAM "Text to find: " OFILE (CHARCODE (EOL LF ESC ^S] [COND (OFILE (WINDOWPROP W 'TEDIT.LAST.FIND.STRING OFILE) (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING OFILE) NIL NIL T))) (COND (CH (* We found the target text.) (* Set up SELECTION to be the found  text) (replace (SELECTION CH#) of SEL with (CAR CH)) (replace (SELECTION CHLIM) of SEL with (CADR CH)) [replace (SELECTION DCH) of SEL with (ADD1 (IDIFFERENCE (CADR CH) (CAR CH] (replace (SELECTION POINT) of SEL with 'RIGHT) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* And never pending a deletion.) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (EMACS.SETFILEPTR STREAM (EMACS.GETCARETPTR STREAM)) (* And get it into the window *) ) (T (FRESHLINE PROMPTWINDOW) (printout PROMPTWINDOW "String '" OFILE "' not found." T) (\SHOWSEL SEL NIL T) (EMACS.SETFILEPTR STREAM PTR] (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with -1))]) (EMACS.TRANSPOSE.BYTES [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Transpose bytes.  *) (PROG (PTR CODE CH) (COND ((OR (EMACS.BOFP STREAM) (EMACS.EOFP STREAM)) (RETURN))) (SETQ PTR (GETFILEPTR STREAM)) (SETQ CODE (\BIN STREAM)) (COND [(NUMBERP CODE) (SETQ CH (MKSTRING (CHARACTER CODE] (T (* IMAGEOBJ *) (SETQ CH CODE))) (EMACS.DELETE.BYTES STREAM PTR PTR) (EMACS.SETFILEPTR STREAM (SUB1 PTR)) (TEDIT.INSERT STREAM CH PTR) (EMACS.SETFILEPTR STREAM (ADD1 PTR]) (EMACS.NEXT.SCREENFULL [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Forward one screenfull.  *) (PROG (WINDOW DELTAX DELTAY) (SETQ WINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ DELTAX 0) [SETQ DELTAY (IDIFFERENCE (WINDOWPROP WINDOW 'HEIGHT) (FONTPROP (DSPFONT NIL WINDOW) 'HEIGHT] (replace (TEXTOBJ EDITOPACTIVE) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with NIL) (\TEDIT.SCROLLFN WINDOW DELTAX DELTAY]) (EMACS.CXCV [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Visit a file. *) (PROG (FILE) (SETQ FILE (TEDIT.GETINPUT (fetch (EMACSSTREAM TEXTOBJ) of STREAM) "File to GET:")) (COND ((NULL FILE) (RETURN))) (COND ((fetch (EMACSSTREAM DIRTY) of STREAM) (EMACS.CXCW STREAM))) (TEDIT.GET (fetch (EMACSSTREAM TEXTOBJ) of STREAM) FILE) (EMACS.SETFILEPTR STREAM 0]) (EMACS.CXCW [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Write buffer out to file.  *) (PROG NIL (TEDIT.PUT (fetch (EMACSSTREAM TEXTOBJ) of STREAM]) (EMACS.CXCZ [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Eval FORM in front of caret in  lisp EXEC process.  *) (PROG (FORM) (SETQ FORM (READ STREAM EMACS.READTABLE)) (PROCESS.EVAL 'EXEC FORM]) (EMACS.FWD.SEXPR [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go forward a sexpr.  *) (PROG NIL (RESETLST (* Accept uncaught BQUOTE commas.  *) (RESETSAVE \BQUOTELEVEL (IQUOTIENT MAX.FIXP 2)) (READ STREAM EMACS.READTABLE))]) (EMACS.BACK.DELETE.BYTE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Delete byte in backwards  direction. *) (* TBW%: Delete selection if there  is a selection. *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.DELETE.BYTES STREAM (SUB1 PTR) (SUB1 PTR]) (EMACS.GOTO.BOD [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go to top of definition.  *) (PROG (CODE) (* Find non-WS immediately preceded  by CR. *) (EMACS.BCHAR STREAM) (DO (COND ((EMACS.BOFP STREAM) (RETURN))) (EMACS.BSKIP STREAM EMACS.NONCR) (COND ((BITTEST (ELT EMACS.SYNTAX (EMACS.CCHAR STREAM)) EMACS.NONWS) (RETURN))) (EMACS.BCHAR STREAM]) (EMACS.BOD [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Determine top of definition.  *) (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* Find lparen preceded by CR.  *) (EMACS.BSKIP STREAM EMACS.CR) (DO (COND ((EMACS.BOFP STREAM) (RETURN))) (EMACS.BSKIP STREAM EMACS.NONCR) (COND ((EMACS.BOFP STREAM) (RETURN))) (COND ((OR (EMACS.BOFP STREAM) (EQ (\PEEKBIN STREAM) (CHARCODE "("))) (RETURN))) (EMACS.BBYTE STREAM)) (SETQ ANSWER (GETFILEPTR STREAM)) (SETFILEPTR STREAM PTR) (RETURN ANSWER]) (EMACS.GOTO.EOD [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go to top of next definition.  *) (PROG (CODE) (* Find non-WS immediately preceded  by CR. *) (EMACS.FCHAR STREAM) (DO (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FSKIP STREAM EMACS.NONCR) (EMACS.FCHAR STREAM) (COND ((BITTEST (ELT EMACS.SYNTAX (EMACS.CCHAR STREAM)) EMACS.NONWS) (RETURN]) (EMACS.EOD [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:12") (* Determine top of next definition.  *) (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* Find two CRs. *) (EMACS.FSKIP STREAM EMACS.CR) [DO (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FSKIP STREAM EMACS.NONCR) (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FBYTE STREAM) (COND ((OR (EMACS.EOFP STREAM) (EQ (\PEEKBIN STREAM) (CHARCODE CR))) (\BACKBIN STREAM) (RETURN] (SETQ ANSWER (GETFILEPTR STREAM)) (SETFILEPTR STREAM PTR) (RETURN ANSWER]) (EMACS.KILL.SEXPR [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Delete expression.  *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (READ STREAM EMACS.READTABLE) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (EMACS.SETFILEPTR STREAM PTR1]) (EMACS.GOTO.BOF [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go to beginning of file.  *) (PROG NIL (EMACS.SETFILEPTR STREAM 0]) (EMACS.GOTO.EOF [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Go to end of file.  *) (PROG NIL (EMACS.SETFILEPTR STREAM (GETEOFPTR STREAM]) (EMACS.BACK.WORD [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Backward a word.  *) (PROG NIL (EMACS.BWORD STREAM]) (EMACS.FWD.DELETE.WORD [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Delete word. *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (EMACS.FSKIP STREAM EMACS.WS) (EMACS.FSKIP STREAM EMACS.NONWS) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (EMACS.SETFILEPTR STREAM PTR1]) (EMACS.EDIT [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* DEDIT expression.  *) (PROG (EXPR PTR1 PTR2) (SKIPSEPRS STREAM) (SETQ PTR1 (GETFILEPTR STREAM)) (SETQ EXPR (READ STREAM EMACS.READTABLE)) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (SETQ EXPR (EDITE EXPR)) (PRINTDEF EXPR NIL NIL NIL NIL STREAM]) (EMACS.FWD.WORD [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Forward a word.  *) (PROG NIL (EMACS.FWORD STREAM]) (EMACS.GRIND [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Grind expression.  *) (PROG (EXPR PTR1 PTR2) (SKIPSEPRS STREAM) (SETQ PTR1 (GETFILEPTR STREAM)) (SETQ EXPR (READ STREAM EMACS.READTABLE)) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (PRINTDEF EXPR NIL NIL NIL NIL STREAM]) (EMACS.SNARF [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Snarf expression from DEDIT  window. *) (PROG (EXPR) (SETQ EXPR (CAR (TOPSELECTION))) (PRINTDEF EXPR NIL NIL NIL NIL STREAM]) (EMACS.MT [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Transpose words.  *) (PROG (PTR BPTR1 BPTR2 FPTR1 FPTR2) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.BSKIP STREAM EMACS.WS) (SETQ BPTR2 (GETFILEPTR STREAM)) (EMACS.BWORD) (SETQ BPTR1 (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.FSKIP STREAM EMACS.WS) (SETQ FPTR1 (GETFILEPTR STREAM)) (EMACS.FWORD STREAM) (SETQ FPTR2 (GETFILEPTR STREAM)) (* How do I move? *) ]) (EMACS.PREVIOUS.SCREENFULL [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Backwards a screenfull.  *) (PROG (WINDOW DELTAX DELTAY) (SETQ WINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ DELTAX 0) [SETQ DELTAY (IDIFFERENCE (FONTPROP (DSPFONT NIL WINDOW) 'HEIGHT) (WINDOWPROP WINDOW 'HEIGHT] (replace (TEXTOBJ EDITOPACTIVE) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with NIL) (\TEDIT.SCROLLFN WINDOW DELTAX DELTAY]) (EMACS.JOIN.LINES [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Move current line up *) (PROG (PTR BOL EOL PBOL PEOL PTR1 PTR2) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (SETQ EOL (EMACS.EOL STREAM PTR)) (COND ((ZEROP BOL) (RETURN))) (SETQ PEOL (SUB1 BOL)) (SETQ PBOL (EMACS.BOL STREAM PEOL)) (EMACS.SETFILEPTR STREAM BOL) (EMACS.BSKIP STREAM EMACS.WS) (SETQ PTR1 (IMAX (GETFILEPTR STREAM) PBOL)) (EMACS.SETFILEPTR STREAM BOL) (EMACS.FSKIP STREAM EMACS.WS) (SETQ PTR2 (IMIN (GETFILEPTR STREAM) (ADD1 EOL))) (EMACS.SETFILEPTR STREAM PTR1) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (\BOUT STREAM (CHARCODE SP)) (EMACS.SETFILEPTR STREAM (ADD1 PTR1]) (EMACS.BACK.DELETE.WORD [LAMBDA (STREAM) (* kbr%: "24-Jul-85 16:36") (* Delete backward a word.  *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (EMACS.BWORD STREAM) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR2 (SUB1 PTR1]) (NEW.TEDIT.SELECT.LINE.SCANNER [LAMBDA (X Y TEXTOBJ LINE.LIST REGION WORDSELFLG SELOPERATION WINDOW) (* kbr%: "24-Jul-85 16:49") (PROG (SELECTION PTR) (SETQ SELECTION (OLD.TEDIT.SELECT.LINE.SCANNER X Y TEXTOBJ LINE.LIST REGION WORDSELFLG SELOPERATION WINDOW)) [COND ((EQ (TYPENAME SELECTION) 'SELECTION) (replace (SELECTION POINT) of SELECTION with 'LEFT) (EMACS.SETFILEPTR (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (SUB1 (fetch (SELECTION CH#) of SELECTION] (EMACS.FLUSH.CACHE) (RETURN SELECTION]) ) (* BALANCE *) (PUTPROPS ACCESSFNS EMACS.TAB 2) (PUTPROPS DATATYPE EMACS.TAB 2) (PUTPROPS DEFEXPR EMACS.TAB 2) (PUTPROPS DEFFEXPR EMACS.TAB 2) (PUTPROPS DEFVAR EMACS.TAB 2) (PUTPROPS DO EMACS.TAB 1) (PUTPROPS FOR EMACS.TAB 1) (PUTPROPS LAMBDA EMACS.TAB 2) (PUTPROPS PROG EMACS.TAB 2) (PUTPROPS RECORD EMACS.TAB 2) (PUTPROPS SELECT EMACS.TAB 2) (PUTPROPS SELECTQ EMACS.TAB 2) (PUTPROPS UNTIL EMACS.TAB 1) (PUTPROPS WHILE EMACS.TAB 1) (RPAQ? EMACS.DELIMS NIL) (RPAQ? EMACS.SDELIMS NIL) (RPAQ? EMACS.LDELIMS NIL) (RPAQ? EMACS.RDELIMS NIL) (RPAQ? EMACS.SCACHE NIL) (RPAQ? EMACS.BCACHE NIL) (RPAQ? EMACS.SYNTAX NIL) (RPAQ? EMACS.CR 1) (RPAQ? EMACS.WS 2) (RPAQ? EMACS.SD 4) (RPAQ? EMACS.NONCR 8) (RPAQ? EMACS.NONWS 16) (RPAQ? EMACS.NONSD 32) (RPAQ? EMACS.BQ 64) (RPAQ? EMACS.ALPHA 128) (RPAQ? EMACS.BD 256) (RPAQ? EMACS.SPACE 512) (DEFINEQ (EMACS.DELIMS [LAMBDA (LCHARCODE RCHARCODE) (* kbr%: "19-Feb-85 15:13") (* Make LCHARCODE & RCHARCODE into delimiters.  If LCHARCODE = RCHARCODE, then string style.  Otherwise paren style. *) (PROG (BUCKET) (SETQ BUCKET (CONS LCHARCODE RCHARCODE)) (COND ((MEMBER BUCKET EMACS.DELIMS) (* Already there. *) (RETURN))) (PUSH EMACS.DELIMS BUCKET) (COND ((IEQP LCHARCODE RCHARCODE) (SETSYNTAX LCHARCODE 'STRINGDELIM EMACS.READTABLE) (SETA EMACS.SYNTAX LCHARCODE (LOGOR EMACS.NONWS EMACS.NONCR EMACS.SD)) [SETA EMACS.COMMANDS LCHARCODE (EMACS.SDELIM.COMMAND (MKSTRING (CHARACTER LCHARCODE ] (PUSH EMACS.SDELIMS LCHARCODE)) (T (SETSYNTAX LCHARCODE 'LEFTPAREN EMACS.READTABLE) (SETSYNTAX RCHARCODE 'RIGHTPAREN EMACS.READTABLE) (FOR I IN (LIST LCHARCODE RCHARCODE) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONCR EMACS.NONWS EMACS.NONSD EMACS.BD))) [SETA EMACS.COMMANDS LCHARCODE (EMACS.LDELIM.COMMAND (MKSTRING (CHARACTER LCHARCODE] [SETA EMACS.COMMANDS RCHARCODE (EMACS.RDELIM.COMMAND (MKSTRING (CHARACTER RCHARCODE] (PUSH EMACS.LDELIMS LCHARCODE) (PUSH EMACS.RDELIMS RCHARCODE]) (EMACS.CR [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM (CHARACTER (CHARCODE CR))) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((NOT (EQ (EMACS.SCACHE STREAM) 'OUTSIDE)) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETCARETPTR STREAM EMACS.SCACHE) (DISMISS 1000) (EMACS.SETCARETPTR STREAM (ADD1 PTR)) (SETQ EMACS.SCACHE 'OUTSIDE) (SETQ EMACS.BCACHE NIL]) (EMACS.RPAREN [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM ")") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) 'OUTSIDE) (EMACS.CLOSE.BALANCE STREAM]) (EMACS.RBRACKET [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM "]") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) 'OUTSIDE) (EMACS.CLOSE.BALANCE STREAM]) (EMACS.RBRACE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM "}") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) 'OUTSIDE) (EMACS.CLOSE.BALANCE STREAM]) (EMACS.RANGLE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM ">") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) 'OUTSIDE) (EMACS.CLOSE.BALANCE STREAM]) (EMACS.SDELIM.COMMAND [LAMBDA (SDELIM) (* ; "Edited 19-Feb-2021 11:21 by rmk:") (* kbr%: "19-Feb-85 15:14") (* Return sdelim fn to be inserted  in EMACS.COMMANDS.  SDELIM = 1 letter string.  *) `(LAMBDA (STREAM) (EMACS.SDELIM ,SDELIM STREAM]) (EMACS.LDELIM.COMMAND [LAMBDA (LDELIM) (* ; "Edited 19-Feb-2021 11:20 by rmk:") (* kbr%: "19-Feb-85 15:14") (* Return LDELIM fn to be inserted  in EMACS.COMMANDS.  LDELIM = 1 letter string.  *) `(LAMBDA (STREAM) (EMACS.LDELIM ,LDELIM STREAM]) (EMACS.RDELIM.COMMAND [LAMBDA (RDELIM) (* ; "Edited 19-Feb-2021 11:20 by rmk:") (* kbr%: "19-Feb-85 15:14") (* Return RDELIM fn to be inserted  in EMACS.COMMANDS.  RDELIM = 1 letter string.  *) `(LAMBDA (STREAM) (EMACS.RDELIM ,RDELIM STREAM]) (EMACS.SDELIM [LAMBDA (SDELIM STREAM) (* kbr%: "19-Feb-85 15:14") (* Insert string delimiter SDELIM &  update caches. SDELIM = 1 letter  string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM SDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) 'OUTSIDE) (EMACS.OPEN.STRING STREAM)) (T (EMACS.CLOSE.STRING STREAM]) (EMACS.LDELIM [LAMBDA (LDELIM STREAM) (* kbr%: "19-Feb-85 15:14") (* Insert LDELIM & update caches.  LDELIM = 1 letter string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM LDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) 'OUTSIDE) (EMACS.OPEN.BALANCE STREAM]) (EMACS.RDELIM [LAMBDA (RDELIM STREAM) (* kbr%: "19-Feb-85 15:14") (* Insert RDELIM & update caches.  RDELIM = 1 letter string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM RDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) 'OUTSIDE) (EMACS.CLOSE.BALANCE STREAM]) (EMACS.OPEN.STRING [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (LPTR) (* We should be 1 char after left  delim. *) (SETQ LPTR (SUB1 (GETFILEPTR STREAM))) (SETQ EMACS.SCACHE LPTR]) (EMACS.CLOSE.STRING [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (LPTR RPTR LDELIM RDELIM MATCHED) (* We should be 1 char after right  delim. *) (SETQ EMACS.SCACHE 'OUTSIDE) (SETQ RPTR (SUB1 (GETFILEPTR STREAM))) (EMACS.SETFILEPTR STREAM RPTR) (SETQ RDELIM (\PEEKBIN STREAM)) (EMACS.BSKIP STREAM EMACS.NONSD) (EMACS.BBYTE STREAM) (SETQ LPTR (GETFILEPTR STREAM)) (SETQ LDELIM (\PEEKBIN STREAM)) (SETQ MATCHED (IEQP LDELIM RDELIM)) (COND (MATCHED (EMACS.SETCARETPTR STREAM LPTR) (DISMISS 200)) (T (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETCARETPTR STREAM LPTR) (DISMISS 1000))) (EMACS.SETCARETPTR STREAM (ADD1 RPTR)) (EMACS.SETFILEPTR STREAM (ADD1 RPTR]) (EMACS.OPEN.BALANCE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (LPTR) (* We should be 1 char after left  delim. *) (SETQ LPTR (SUB1 (GETFILEPTR STREAM))) (COND ((NUMBERP EMACS.BCACHE) (* We were at top level.  *) (SETQ EMACS.BCACHE (LIST LPTR))) (T (push EMACS.BCACHE LPTR]) (EMACS.CLOSE.BALANCE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (PTR LPTR RPTR LDELIM RDELIM BALANCED) (* LPTR & RPTR point at balancing  delims *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ RPTR (SUB1 PTR)) (EMACS.SETFILEPTR STREAM RPTR) (SETQ RDELIM (\PEEKBIN STREAM)) (EMACS.BCACHE STREAM) (SETQ BALANCED (NOT (NUMBERP EMACS.BCACHE))) (COND (BALANCED (SETQ LPTR (CAR EMACS.BCACHE)) (EMACS.SETFILEPTR STREAM LPTR) (SETQ LDELIM (\PEEKBIN STREAM)) (EMACS.SETCARETPTR STREAM LPTR) (COND ((IEQP (CDR (ASSOC LDELIM EMACS.DELIMS)) RDELIM) (* Correct match *) (DISMISS 200)) (T (* Flash incorrect match.  *) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (DISMISS 1000))) (pop EMACS.BCACHE)) (T (* Flash beginning of non-list def.  *) (EMACS.SETCARETPTR STREAM EMACS.BCACHE) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (DISMISS 1000))) (EMACS.SETCARETPTR STREAM PTR) (EMACS.SETFILEPTR STREAM PTR]) (EMACS.FLUSH.CACHE [LAMBDA NIL (* kbr%: "19-Feb-85 15:14") (* Lose cached info about string &  paren balancing. *) (PROG NIL (* Hopefully we can change things so that not all commands flush all of cache.  *) (SETQ EMACS.SCACHE NIL) (SETQ EMACS.BCACHE NIL]) (EMACS.SCACHE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (* Return or OUTSIDE,  computing if necessary.  *) (PROG (PTR ANSWER) (COND (EMACS.SCACHE (RETURN EMACS.SCACHE))) (* Recompute. *) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM (EMACS.BOL STREAM PTR)) (SETQ ANSWER 'OUTSIDE) (while (ILESSP (GETFILEPTR STREAM) PTR) do (* Find opening. *) (EMACS.FSKIP STREAM EMACS.NONSD PTR) (EMACS.FBYTE STREAM) (COND ((IGEQ (GETFILEPTR STREAM) PTR) (RETURN))) (SETQ ANSWER (GETFILEPTR STREAM)) (* Find closing. *) (EMACS.FSKIP STREAM EMACS.NONSD PTR) (EMACS.FBYTE STREAM) (COND ((IGEQ (GETFILEPTR STREAM) PTR) (RETURN))) (SETQ ANSWER 'OUTSIDE)) (* Store ANSWER, restore fileptr, &  return *) (SETQ EMACS.SCACHE ANSWER) (EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER]) (EMACS.BCACHE [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (* Return ( |...|  ) or OUTSIDE *) (PROG (PTR SCACHE ANSWER) (COND (EMACS.BCACHE (RETURN EMACS.BCACHE))) (* Recompute. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ SCACHE (EMACS.SCACHE STREAM)) [COND ((NOT (EQ SCACHE 'OUTSIDE)) (* Move off string.  *) (EMACS.SETFILEPTR STREAM SCACHE) (COND ((OR (EMACS.BOFP STREAM) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* A string def! *) (SETQ ANSWER SCACHE) (GO EXIT] [COND ((NULL (EMACS.SAFE.BACK.SEXPRS STREAM)) (* Unsuccessful read = unbalanced  parens. Treat as if top level.  *) (SETQ ANSWER (GETFILEPTR STREAM))) ((OR (ZEROP (GETFILEPTR STREAM)) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* Top level. *) (SETQ ANSWER (GETFILEPTR STREAM))) (T (* Opening delim present.  *) (SETQ ANSWER (LIST (SUB1 (GETFILEPTR STREAM] EXIT (EMACS.SETFILEPTR STREAM PTR) (SETQ EMACS.BCACHE ANSWER) (RETURN ANSWER]) (EMACS.SAFE.BACK.SEXPRS [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (* Backwards read sexprs up to but not including opening delim.  Return T if successful backwards read. Otherwise NIL & leave fileptr near  failure point. *) (PROG (ANSWER) [DO (EMACS.BACK.SKIPSEPRS STREAM) (COND ([OR (ZEROP (GETFILEPTR STREAM)) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR)) (AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM] (* Up against delimiter.  *) (SETQ ANSWER T) (RETURN)) ((NULL (NLSETQ (EMACS.BACK.SEXPR STREAM))) (* Error reading backwards.  *) (FLASHWINDOW STREAM) (RETURN] (RETURN ANSWER]) (EMACS.SAFE.BACK.SEXPR [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (* Return T if successful backwards read.  Otherwise NIL & leave fileptr near failure point.  *) (PROG NIL (COND ((NULL (NLSETQ (EMACS.BACK.SEXPR STREAM))) (* Error reading backwards.  *) (FLASHWINDOW STREAM) (RETURN NIL))) (RETURN T]) (EMACS.BACK.SEXPR [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (PROG (RDELIM LDELIM) (EMACS.BACK.SKIPSEPRS STREAM) (COND ((EMACS.BOFP STREAM) (ERROR!)) ((EMACS.BACK.ESCAPEDP STREAM) (* Atom *) (EMACS.BACK.WORD STREAM) (RETURN))) (SETQ RDELIM (\BACKPEEKBIN STREAM)) [SETQ LDELIM (for BUCKET in EMACS.DELIMS when (IEQP (CDR BUCKET) RDELIM) do (RETURN (CAR BUCKET] (COND ((NULL LDELIM) (* Atom *) (EMACS.BACK.WORD STREAM)) ((IEQP LDELIM RDELIM) (* String delimiters *) (\BACKBIN STREAM) (WHILE (AND (NOT (EMACS.BOFP STREAM)) (OR (NOT (IEQP (\BACKPEEKBIN STREAM) LDELIM)) (EMACS.BACK.ESCAPEDP STREAM))) DO (\BACKBIN STREAM)) (COND ((EMACS.BOFP STREAM) (ERROR!))) (\BACKBIN STREAM)) (T (* Left Right delimters *) (\BACKBIN STREAM) [do (EMACS.BACK.SKIPSEPRS STREAM) (COND ((EMACS.BOFP STREAM) (ERROR!)) ((AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM))) (RETURN))) (EMACS.BACK.SEXPR STREAM) (COND ((OR (EMACS.BOFP STREAM) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* At top of definition in middle of  read. *) (ERROR!] (\BACKBIN STREAM) (EMACS.BSKIP STREAM EMACS.BQ]) (EMACS.BACK.SKIPSEPRS [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (* Backwards SKIPSEPRS.  *) (PROG (SA CH SNX) (SETQ SA (fetch (READTABLEP READSA) of EMACS.READTABLE)) (COND ((EMACS.BOFP STREAM) (RETURN))) (SETQ CH (\BACKPEEKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((NOT (EQ SNX SEPRCHAR.RC)) (RETURN))) (\BACKBIN STREAM) (do (COND ((EMACS.BOFP STREAM) (RETURN))) (SETQ CH (\BACKPEEKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((EQ SNX SEPRCHAR.RC) (\BACKBIN STREAM)) ((EQ SNX ESCAPE.RC) (\BIN STREAM) (COND ((NOT (EMACS.BACK.ESCAPEDP STREAM)) (\BACKBIN STREAM))) (RETURN)) (T (RETURN]) (EMACS.BACK.ESCAPEDP [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (* Is the previous byte escaped? *) (PROG (PTR SA CH SNX ANSWER) (* T if previous byte preceded by  odd number of %%'s.  *) (SETQ PTR (GETFILEPTR STREAM)) (COND ((ILEQ PTR 1) (RETURN NIL))) (SETQ SA (fetch (READTABLEP READSA) of EMACS.READTABLE)) (\BACKBIN STREAM) [do (SETQ CH (\BACKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((EQ SNX ESCAPE.RC) (SETQ ANSWER (NOT ANSWER))) (T (RETURN))) (COND ((EMACS.BOFP STREAM) (RETURN] (SETFILEPTR STREAM PTR) (RETURN ANSWER]) (EMACS.TAB [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (* Lisp indent. *) (PROG (PTR BOL EOL CODE INDENT OFFSET TABFLG) (* INDENT = how much we want to indent.  OFFSET = how many chars to nonws. TABFLG = any tabs present at beginning of  line. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ INDENT (EMACS.TAB.INDENT STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* Calc OFFSET. *) (SETQ EOL (EMACS.EOL STREAM PTR)) (EMACS.SETFILEPTR STREAM BOL) (SETQ OFFSET 0) (for I from BOL to (SUB1 EOL) do (SETQ CODE (\BIN STREAM)) (COND ((EQUAL CODE (CHARCODE TAB)) (SETQ TABFLG T))) (COND ((NOT (BITTEST (ELT EMACS.SYNTAX (OR (NUMBERP CODE) 256)) EMACS.WS)) (RETURN))) (SETQ OFFSET (ADD1 OFFSET))) (* Insert and/or delete whitespace.  *) (COND [TABFLG (EMACS.DELETE.BYTES STREAM BOL (IPLUS BOL OFFSET -1)) (COND ((NOT (ZEROP INDENT)) (TEDIT.INSERT STREAM (ALLOCSTRING INDENT " ") (ADD1 BOL] ((IEQP OFFSET INDENT) (* Do nothing. *) ) ((IGREATERP OFFSET INDENT) (EMACS.DELETE.BYTES STREAM BOL (IPLUS BOL (IDIFFERENCE OFFSET INDENT) -1))) ((ILESSP OFFSET INDENT) (TEDIT.INSERT STREAM (ALLOCSTRING (IDIFFERENCE INDENT OFFSET) " ") (ADD1 BOL))) (T (SHOULDNT))) (* Reposition fileptr.  *) (COND ((ILEQ PTR (IPLUS BOL OFFSET)) (EMACS.SETFILEPTR STREAM (IPLUS BOL INDENT))) (T (EMACS.SETFILEPTR STREAM (IPLUS PTR (IDIFFERENCE INDENT OFFSET]) (EMACS.TAB.INDENT [LAMBDA (STREAM) (* kbr%: "19-Feb-85 15:14") (* Amount to indent for Lisp indent.  *) (PROG (PTR BOD SISTER1PTR SISTER2PTR LDELIMFLG SISTER1 SISTERPTR OFFSET BOL ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* SETQ BOD (EMACS.BOD STREAM PTR)) (SETQ BOD 0) (EMACS.SETFILEPTR STREAM (EMACS.BOL STREAM PTR)) (EMACS.BSKIP STREAM EMACS.WS BOD) (* Get SISTER1PTR, SISTER2PTR, &  LDELIMFLG *) (do (EMACS.BSKIP STREAM EMACS.SPACE) (COND ((ILEQ (GETFILEPTR STREAM) BOD) (RETURN))) (COND ((AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM))) (SETQ LDELIMFLG T) (RETURN))) (EMACS.SAFE.BACK.SEXPR STREAM) (SETQ SISTER2PTR SISTER1PTR) (SETQ SISTER1PTR (GETFILEPTR STREAM))) (* Get SISTER1. *) [COND (SISTER1PTR (EMACS.SETFILEPTR STREAM SISTER1PTR) (SETQ SISTER1 (RATOM STREAM] (* Get SISTERPTR & OFFSET.  *) (SETQ SISTERPTR (OR SISTER1PTR (GETFILEPTR STREAM))) [COND ((AND SISTER1 (LITATOM SISTER1)) (SETQ OFFSET (GETPROP SISTER1 'EMACS.TAB] (COND (OFFSET (SETQ OFFSET (SUB1 OFFSET))) ((NULL SISTER1) (SETQ OFFSET 1)) ((NULL LDELIMFLG) (SETQ OFFSET 0)) ((NULL SISTER2PTR) (SETQ OFFSET 0)) (T (SETQ SISTERPTR SISTER2PTR) (SETQ OFFSET 0))) (* Get ANSWER. *) (SETQ BOL (EMACS.BOL STREAM SISTERPTR)) (EMACS.SETFILEPTR STREAM BOL) (SETQ ANSWER OFFSET) [for I from BOL to (SUB1 SISTERPTR) do (COND ((IEQP (\BIN STREAM) (CHARCODE TAB)) (SETQ ANSWER (IPLUS ANSWER 8))) (T (SETQ ANSWER (ADD1 ANSWER] EXIT (EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER]) (EMACS.INIT.SYNTAX [LAMBDA NIL (* kbr%: "19-Feb-85 15:14") (PROG NIL (* "Character" 256 is used to handle  IMAGEOBJs. *) (SETQ EMACS.SYNTAX (ARRAY 257 'WORD 0 0)) (FOR I FROM 0 TO 256 DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONCR EMACS.NONWS EMACS.NONSD EMACS.ALPHA ))) (FOR I IN (CHARCODE (TAB LF SP)) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.WS EMACS.NONCR EMACS.NONSD EMACS.SPACE))) (SETA EMACS.SYNTAX (CHARCODE CR) (LOGOR EMACS.WS EMACS.CR EMACS.NONSD)) (FOR I IN '(39 44 64 96) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONWS EMACS.NONCR EMACS.NONSD EMACS.BQ EMACS.ALPHA))) (SETQ EMACS.DELIMS NIL) (SETQ EMACS.SDELIMS NIL) (SETQ EMACS.LDELIMS NIL) (SETQ EMACS.RDELIMS NIL) (EMACS.DELIMS (CHARCODE "(") (CHARCODE ")")) (EMACS.DELIMS (CHARCODE "[") (CHARCODE "]")) (EMACS.DELIMS (CHARCODE "{") (CHARCODE "}")) (EMACS.DELIMS 34 34]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (EMACS.INIT) (MOVD? %'TEDIT.SELECT.LINE.SCANNER %' OLD.TEDIT.SELECT.LINE.SCANNER) (MOVD %'NEW.TEDIT.SELECT.LINE.SCANNER %' TEDIT.SELECT.LINE.SCANNER) (MOVD %'EMACS %'TEDIT) ) (PUTPROPS EMACS COPYRIGHT ("Xerox Corporation" 1985 1986 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10504 55835 (EMACS.INIT 10514 . 11136) (EMACS.INIT.BACKGROUND 11138 . 12168) ( DEDITEmacs 12170 . 12810) (EMACS.INIT.COMMANDS 12812 . 13932) (EMACS.COMMAND 13934 . 14105) ( EMACS.OPERATE 14107 . 17725) (EMACS.GETKEY 17727 . 17954) (EMACS 17956 . 19057) (EMACS.PROCESS 19059 . 19298) (EMACS.TEDIT1 19300 . 19707) (EMACS.WINDOW 19709 . 20104) (EMACS.SETFILEPTR 20106 . 20568) ( EMACS.GETCARETPTR 20570 . 21105) (EMACS.SETCARETPTR 21107 . 21640) (EMACS.SHOWCARET 21642 . 21983) ( EMACS.BOL 21985 . 22532) (EMACS.EOL 22534 . 23074) (EMACS.DELETE.BYTES 23076 . 23942) (EMACS.BOFP 23944 . 24084) (EMACS.EOFP 24086 . 24254) (EMACS.CCHAR 24256 . 24656) (EMACS.PEEKBIN 24658 . 24942) ( EMACS.FBYTE 24944 . 25274) (EMACS.FWORD 25276 . 25641) (EMACS.BYTEP 25643 . 25809) (EMACS.FSKIP 25811 . 26481) (EMACS.FSKIPTO 26483 . 27135) (EMACS.BBYTE 27137 . 27472) (EMACS.BCHAR 27474 . 27841) ( EMACS.BPEEKCHAR 27843 . 28282) (EMACS.BWORD 28284 . 28650) (EMACS.BSKIP 28652 . 29310) (EMACS.BSKIPTO 29312 . 29968) (EMACS.SET.EOF 29970 . 30542) (EMACS.GOTO.BOL 30544 . 30877) (EMACS.BACK.BYTE 30879 . 31192) (EMACS.FWD.DELETE.BYTE 31194 . 31505) (EMACS.GOTO.EOL 31507 . 31834) (EMACS.FWD.BYTE 31836 . 32151) (EMACS.KILL.LINE 32153 . 32760) (EMACS.DELETE.CHARS 32762 . 33598) (EMACS.REDISPLAY 33600 . 34043) (EMACS.NEXT.LINE 34045 . 35028) (EMACS.PREVIOUS.LINE 35030 . 35846) (EMACS.QUOTE.BYTE 35848 . 36461) (EMACS.SEARCH 36463 . 39929) (EMACS.TRANSPOSE.BYTES 39931 . 40827) (EMACS.NEXT.SCREENFULL 40829 . 41585) (EMACS.CXCV 41587 . 42245) (EMACS.CXCW 42247 . 42599) (EMACS.CXCZ 42601 . 43063) ( EMACS.FWD.SEXPR 43065 . 43620) (EMACS.BACK.DELETE.BYTE 43622 . 44234) (EMACS.GOTO.BOD 44236 . 45087) ( EMACS.BOD 45089 . 46190) (EMACS.GOTO.EOD 46192 . 47038) (EMACS.EOD 47040 . 48104) (EMACS.KILL.SEXPR 48106 . 48624) (EMACS.GOTO.BOF 48626 . 48954) (EMACS.GOTO.EOF 48956 . 49294) (EMACS.BACK.WORD 49296 . 49610) (EMACS.FWD.DELETE.WORD 49612 . 50117) (EMACS.EDIT 50119 . 50715) (EMACS.FWD.WORD 50717 . 51029) (EMACS.GRIND 51031 . 51593) (EMACS.SNARF 51595 . 51985) (EMACS.MT 51987 . 52744) ( EMACS.PREVIOUS.SCREENFULL 52746 . 53512) (EMACS.JOIN.LINES 53514 . 54590) (EMACS.BACK.DELETE.WORD 54592 . 55070) (NEW.TEDIT.SELECT.LINE.SCANNER 55072 . 55833)) (56879 86487 (EMACS.DELIMS 56889 . 58630 ) (EMACS.CR 58632 . 59303) (EMACS.RPAREN 59305 . 59695) (EMACS.RBRACKET 59697 . 60089) (EMACS.RBRACE 60091 . 60481) (EMACS.RANGLE 60483 . 60873) (EMACS.SDELIM.COMMAND 60875 . 61500) (EMACS.LDELIM.COMMAND 61502 . 62127) (EMACS.RDELIM.COMMAND 62129 . 62754) (EMACS.SDELIM 62756 . 63556) (EMACS.LDELIM 63558 . 64228) (EMACS.RDELIM 64230 . 64901) (EMACS.OPEN.STRING 64903 . 65276) (EMACS.CLOSE.STRING 65278 . 66331) (EMACS.OPEN.BALANCE 66333 . 66936) (EMACS.CLOSE.BALANCE 66938 . 68685) (EMACS.FLUSH.CACHE 68687 . 69177) (EMACS.SCACHE 69179 . 71172) (EMACS.BCACHE 71174 . 73054) (EMACS.SAFE.BACK.SEXPRS 73056 . 74344) (EMACS.SAFE.BACK.SEXPR 74346 . 74872) (EMACS.BACK.SEXPR 74874 . 77224) (EMACS.BACK.SKIPSEPRS 77226 . 78450) (EMACS.BACK.ESCAPEDP 78452 . 79535) (EMACS.TAB 79537 . 81988) (EMACS.TAB.INDENT 81990 . 84821) (EMACS.INIT.SYNTAX 84823 . 86485))))) STOP \ No newline at end of file diff --git a/lispusers/EMACS.LCOM b/lispusers/EMACS.LCOM index 451dc12ea44bcdc34c791643845cfef6e3f2509a..94431df2dd0dfe9bbcd48d511396a95bb83c802c 100644 GIT binary patch delta 3249 zcmb6bYiv{J726>SA(xN`2@ZLDF$uAg*!U4Au>)>y?CZqMwVnDp1iCQl*cW2q7mmZD z6LZF!5J)^I-=J_)5%OcA;w5L zMRbJunnxHuzGHMs%ueN92P2t8B<14M(MZCT6k`eTn9XE&9f;?QGUZCdr!v!2*v0u- zw_xgX7|@Et$Y!$W%4{ZgOv{`jzA}c=e#fV2U*{N11Nu_g>@zenlN9TUY0YMMM zJDo_7yl`wPJ)I+#p8rK|GMRKF7Rh0}y48G(&1tvbU-x{+UUkYZK4kt&PDz;F?jDDk zL?Bng@2H%G+eJTDA@TL%qewg|{#b*=O6e;|46i>xcM4^fH%O5MSU*PupVJ9@nc6z1 zv)#>eY+!W6=naPaLOX_RmbMF*m||7Eq%uNmB*Y0^SO{ZJlM!N-4P4(auSPp;xs5K( z)|!$rU%(R_BTo2s`7$~cHy%g$;l{rqyi@Te!UbZ0?^T{bOjq?AgdbP^5#dtxdkEj$ zv=`yp8hWbt_fJRxkD!!v#vKeb1q|~+c z?s8`UtIqPoqR3+rs|Ah?xrc~S`d-;keMcMB;X0O|=yWM<@Gw{ny`5N(LblU_Stu+T zOK38#nI0g#tF48r+j|(roSD!*gXUNblogdhrFqY@2mkW6grAsiqt&EEOT$^$O5n$q zeu}PG>~v|iw&6A{;e>S$VsBYj5H8zU_{jE|L=S`2{(X#c*&d=%F7*=_u38U)o*yFh zuxA+I&fc#gq#dz;x*9T#MR32jY?W-a<5x)i$?-^%8j$dQ2=^@__DP?J#`oC2C|W^%s!Hvr*Ls`OD$qc%NUuZ^z`=T6$?0NDaKce|=&8<#B4@*7z;B zI$kAV_hh>AIDTwpYuTsWC?%OEdc4AtVK`UZRji=DEbeIHC9Vm-l72Se zkxMLz%Nvrof>QC&7m3RolDLARc!}%?&(aiGPlIoYYyt1Yy9(ADy}wq94}OZp-yR#m zM9jpB)lV@?;L3ghH$L4j&~&{Nr&ny*-dR|RA4ih~-@$iPk6Xzicc#+YL&>eQ{>h{V zHQvY&4JH+SpX{K_0#BQ_(2>fko^)@I{F#G?!76wsUCKDQP$(E8CfVqR>5k`e(_EtT zwGHkkNwIPx{+W?3i}ujX4UaEaj}mOKs#f}Z+lk)IKkc(L+l(jd%$8{&KV6FG?DQZ_ z<8KdRpB3&L`6gzhF#hUibot8h6Y6|B>FXnmZX}Y6PU6Enag2m;m>8CZ2coAFhXEf* zk`)h4$Fm~79Ugq8BB>Zqdk zCWk8-cxf~k=1e-qK=hL5yiQ1yc#b5}k=RrxnZS_&sjL`DB#x0-TAWI?<;anA_Ml1k zSVb2`+hj6AA8s-sk|%@7k$7&BaJxr>p|D_Lc^)+w9K+l^8{+5-Pe&?2K7j#^(Py5( z2l@5}`64I{Es%hZ$8F_$_~C__P2if@qH2Yk7maZ5bPZgdaYFZ{O)3WdG2@2$OIwQ> znkoV}E=7tMhmAnPJX=HbvRyyUd12DpM)Z0MVc_U|KL{r(;LbcX@R#`)plP8Iv7HNE zXgb-1nCqkqojq7+Lwxb1_gm^(MAWAO<+8nzP|(c@0-D-)Dp(=&grVS=8;==A?%St! zZIA~UlXqYbzO@W&J-z2KYhWxG@*r#W^kA*5>mBo$@Q!j=7e)M|(<7CNg#foZY~pc{ zMU@xN3@IuSSHSU<3wTF)9`~-C8LE@b4F(35tl(z?P+BHcrz`fpD zc=hb%BARU2an9R_BQusSq-f%(j62AanGF2k9M>otk+(1rgHOpapgHfWMWwMJEcL1_ z$wTx!2UpHFV=nI?wsDpw-84G@hh}w%!K@qpAYq@(dcbvo7Gm!OCw%upC%l#14DVg2 zS$zV51`6}(P0%)1jiP;X^{{)c9_yByGZryeZiu{Ar^e;&xovcLg>5WiunCZ@g+I@g zw6?ZMXF*BnP8sM=9{UA8$a>^H1;@o1Rcqnq#hWTL&7ANSZp?2-wD4e|Yb`bV#7WaS iM(+>q@=(v{OQX1|K${9%aR-a9^_LOpVjCE2b>_eG>%xQp delta 8085 zcmbtZYj9h~bp}A{;n0Kt5`2LYwWKT&q(m6^;z59t6<)kVh#&yn3lM}wSr3vG=ujjj zihA0EL~Z@Z*tO$rQ@6DzX;P(4Gp;4U>MN7db|+)Y6F<^)GM*-xX3|NVX?{d$JN48} z>VCWT1;|PqPdLN9XV30E=j`5dzH@f*&O^4JJZGzTlBskeCMTqPB2M~9WJsA?9*P8r zFESDkN5nuM@$}6somie6BmQBSmXK4*gL~2`C09@qva**^v8dshnOKA)aJLAU`?6#9oAXvan`;07hm0fy?MOszPGeCW}CY5#`unVue@vVh+!hdjIn?V*3t_zi1MwY=`D)+WBBH1YUIioQP{pvN|hVCdNm|IvVXPc|Jv=VwjF zt>~1RpRx1V8EGOxlvEGK@9J>(^bE$*2`N*^4JEVkgfd9j2C?C4z`mZnxO-EV4U;D~ zJ;5IDZ1S_mX2%u`jX2&yJG7;X-sPMH^{DelXqQ|59PNv#E}HFiP^tAH^j>X!6YbNk zx6z(#`wrTP_Csj5xHr>R+F>)bbtq_;3%&GgM*-C99SO9V?hHNJ=>hfW&IsDCcZcYE zoqqu8$*#xHZgI1@EAA<@-*A5lZKnGS+OK!NiuTE_UG(oap8_?s%67Zlm* zp~0TJKruU4dYF_`o61v zgd7n_Y>f79Yp4Ic?Xi!x)%2yi{`S^49^Sr#ZS?cod)eckwkPqZx_9iivFC4j?y)lV z<$)h;<{vc&|B(|)BCq5TJtRl`>L>o2ZLPZ$9C>xJ!NNTQ%?pTT}l%{ zoB#CAEzO$1uqxr@o&9X`Pj`RjJ(T72I%K^ck%uxeQ)=lf%@E@Ijn!(Jqi=L-sE`Uaa1bL#+uhLR5@mu;TIGnq7W4 zza~U9>>`2?sObENpGe7kLOxJP<&znLq^G|;9MI<=tJTg4hK)G^!y5mv!SwUZP?t2I zxrH~DotTg^ac?@C%}G9=+b5v)iLCLfF2i7kgEvCD0`QI(CMHS@x`$#?J~qbSTQqbe z0Rw8TQ^r!TKdvNDY~)kf45kINp;$Iog1&L3c93lv%aIe=NuY}P5?eUq$HB{2>W0|T z*btNF#YcaOmEw_MYE+S9Fa6+Y+wH(i!Bl`OmPrWS0DTV!0d{$pmTHdrzC7FGks#wY{ z$6CD+SFKIOmTR-+nU=MJrmsh}uGlWunc1V8qjC$T8kJ;fbjopyu&b8KMb`_JhD%p1 z&z5IgYm@xt*IbtSZ$5R^@~9@cPhWzr>6U(jL25+*A6s?M7rfsnz0A9>+hEbhh?5(q@dG;?F-ZUG@grj@a5 zk#_)UM#oMr zAF4??LDLigJCnmFL=9G}LBJ8hcoo`on){WyE0wxkVL8t*2%c$n0_OUV>U2Q@^H(ki zPVmbzkePts8CqeeCZNHX^i-*XRbO4DZS1kP6e#MaHTc!Svo}Nq%-ec@T6QQ~HNis}QN=#PE51y5DQ(Jo>foLp@ZaPd0vIKqGM7+aEH#)UKdpblNAo6^RB&XPKWIX%Pz%sx6|1; z&c|C?osM-y`)f7_6!aJE_j74i`iic}o6puu+Q{C$`hE_RUT;_{+7}v&Et(Pbh4m)A z&hd27UTi75T^rY0H(G*t>ssgSb*l=>u&q2>1IJ=Wq`eKU3M*}lA_qPuqA;6QN=mel z%n=b@G@UEtquBFgY6=VnjLIT;o9q2wJ$+A=$ z$|jTOAkrY010wY_G}qgJLQC-Ja9JaY!Kt1G5aH9Xhq(|(J_gW*TpTAaFT5!MPeL#n zv*A6{MG1vtR@N4VkPsn5L)|uH0}~p=Ai$CNJWf|_sA|o~7Z|o_BNddVCguu0Gs5w@ z9^rlyK>+!`POz(yXxtDC7BaeQN#&~d} zoSd4_76wM}R-D1%@UL4pSggDdD()!mD!bkDJbpox-9?Xk#^bzccRDte56)JmXYVU| zITqZo9BwJ@P{}>l8;icfuHv9R(yo)X!=1$)93#{r?HGC3eOvBkU7)YJ!|8AwVOUWV zfio@HJ}#uarB$24!u`s($|$>pke|i*q#5V(+~?IpFh5}3k{0!Iq_GchUj#BU zv%>9!qu#u;!D4eRuOIzK<{5vi-wRA#=~Ov?G&;rI_yeM4SeatrQbZ*T0?AKGRN0`cIc*~oc*Y4Bxt8({q)y2)u z-X?lNbXOX_l(iqm5#f=n-HK<{ZaZvW%Q|?RaS3YLyYhPr@9{U+t~`o64OD3HlroW0 z6a;sWAQPz{1OSOmMh0RZlYd|pIf36u1QV0kCuAMenY!!H!GjD=6lqG?JXwMZGwN>V#b;Gxt{CU?~NFG%Xi0890QOmn+OnqzRqo*CM8Y z6=plWq8SgY6x9q6P$^EsEJF|rtPe;R0C68=;*g}r9j<(IvZl%o@krjoZ-vavgq_f} z>-RKR6+x)?5&Zn1{yu>7Q))sXJ=M>~*0DS87gOzYNp7lsEji7u-d;?-NdIN5RipkY z<>b^iwZ1&w#qat(ECi&CQcTDy*mJ4Or8NWK&A8pQSe*_Fchynu0|&Sp@`m@>Ef)%j z=z#*#BSZ7FG!c!XkdF}6SVfhK%T=7WfN98575#JJ_XbvWs}s|FqJI6OgGHT<>XhHu z#>xkb)CAWWd0QLh54TaB@+)neL!4SZ@-ZUlelpkoR4#`**#o)twp!jsdO^nT5Y;zig#ZaT`qhX!m94#x2^i+xOw)d zI|0QvXf+*ubE?}$dgzx*JJ|%BU+}2@yi~Cox9F((v}&%SbvQyiv2+iPK3SP~RsIVH zcYXwI?mKj^@zdu@WW9Dp|I#$Sz5n;=zq9LSe4~iOO@E!j?;PsIDt~e4&W82HtQ?2+ z>K(X?9+uY8g@bosK~>k$eQaZ=kKrb~nxFX$cB%TKx&LF2AC@oK=#hoHtGv-t>D!A=ObI`bZ^VU7GnJOQ=~o{3Y`Z>liqGsP9snSQ4?Q?UhnFLGV|lrQKC+zI zq{Wzyg7k;WS*ONh1-*Jwpox={_GT?^lhG0antu6Y$zVnKmQcs3eI44n$zoi)N%E@G z7f z>QB#Zr7xWw0rkIUchR37Z=?5|>+G#vg;HagxvV1x+vtUJF8ai|&3N}K=Qh(<&kfl~ zKb6kA*Y`J*Y&uRqb-H^4@!;+md-LX{t@NjtHg^$EGiUU3{~-Om1{=U1y?p+YaI~SS va^W#+_4^lBt<}i~1M93@Vq?E9ui2D`p`Tsq-JnUL-M>A$VPJs$0NnilMaaP~ From 53c173a94392461a2dfa7cec4f480dbdcbfa4889 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Fri, 19 Feb 2021 14:38:24 -0800 Subject: [PATCH 09/31] TWODINSPECTOR: fixed error in 2D layout, synchronized scrolling of values and indexes --- sources/TWODINSPECTOR | 100 ++----------------------------------- sources/TWODINSPECTOR.LCOM | Bin 0 -> 55515 bytes 2 files changed, 5 insertions(+), 95 deletions(-) create mode 100644 sources/TWODINSPECTOR.LCOM diff --git a/sources/TWODINSPECTOR b/sources/TWODINSPECTOR index 79095a83..4554c3d0 100644 --- a/sources/TWODINSPECTOR +++ b/sources/TWODINSPECTOR @@ -1,4 +1,4 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Aug-2020 11:22:30"  {DSK}kaplan>Local>medley3.5>lispcore>sources>TWODINSPECTOR.;2 111972 changes to%: (FNS ONEDINSPECT.PROPWIDTH ONEDINSPECT.ARRANGEWINDOWS RIGHTW.REPAINTFN) previous date%: "31-Dec-93 12:04:36" {DSK}kaplan>Local>medley3.5>lispcore>sources>TWODINSPECTOR.;1) (* ; " Copyright (c) 1985, 1900, 1987, 1990, 1992, 1993, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TWODINSPECTORCOMS) (RPAQQ TWODINSPECTORCOMS ( (* ;; "Substrate for two-dimensional inspectors. Used in inspecting arrays.") (COMS (* ;; "Added by yabu.fx, for SUNLOADUP without DWIM. They compute load time constants, and must come first in the file.") (FNS \CREATE.TWODINSPECTOR.TITLEMENU \CREATE.TWODINSPECTOR.SETMENU \CREATE.TWODINSPECTOR.INSPECTMENU)) (* ;; "Oned-inspector ") (FNS ONEDINSPECTW.CREATE GET-ONED-DISPLAYW ONEDINSPECT.ARRANGEWINDOWS ONEDINSPECT.REPAINTFN ONEDINSPECT.PRINTELEMENT ONEDINSPECT.RESHAPEFN ONEDINSPECT.MAKEREGIONS ONEDINSPECT.BUTTONEVENTFN ONEDINSPECT.COPYBUTTONFN ONEDINSPECT.SCROLLFN ONEDINSPECT.CLOSEFN ONEDINSPECT.REDISPLAY ONEDINSPECT.REPLACE ONEDINSPECT.SELECTITEM ONEDINSPECT.SELECTPROP ONEDINSPECT.ADJUSTSELECTION ONEDINSPECT.PROPWIDTH ONEDINSPECT.VALUEWIDTH ONEDINSPECT.DEFAULT.TITLECOMMANDFN ONEDINSPECT.DEFAULT.VALUECOMMANDFN ONEDINSPECT.SETELT) (* ;; "Twod-inspector") (FNS TWODINSPECTW.CREATE GET-TWOD-DISPLAYW GET-CORNERW TWODINSPECT.ARRANGEWINDOWS TWODINSPECT.REPAINTFN TWODINSPECT.PRINTELEMENT TWODINSPECT.RESHAPEFN TWODINSPECT.MAKEREGIONS TWODINSPECT.BUTTONEVENTFN TWODINSPECT.COPYBUTTONFN TWODINSPECT.DOWINDOWCOMFN TWODINSPECT.SCROLLFN TWODINSPECT.CLOSEFN TWODINSPECT.REDISPLAY TWODINSPECT.REPLACE TWODINSPECT.SELECTITEM TWODINSPECT.SELECTROWPROP TWODINSPECT.SELECTCOLUMNPROP TWODINSPECT.ADJUSTSELECTION TWODINSPECT.DEFAULT.TITLECOMMANDFN TWODINSPECT.DEFAULT.VALUECOMMANDFN TWODINSPECT.SETELT TWODINSPECT.ROWPROPWIDTH TWODINSPECT.COLUMNWIDTHS TWODINSPECT.COLUMNWIDTH TWODINSPECT.TOTALWIDTH) (* ;; "Right window fns") (FNS GET-RIGHTW RIGHTW.REPAINTFN RIGHTW.RESHAPEFN RIGHTW.BUTTONEVENTFN RIGHTW.ADJUSTSELECTION ) (* ;; "Top window fns") (FNS GET-TOPW TOPW.REPAINTFN TOPW.RESHAPEFN TOPW.ADJUSTSELECTION TOPW.BUTTONEVENTFN) (* ;; "Title window fns") (FNS GET-TITLEW TITLEW.REPAINTFN TITLEW.BUTTONEVENTFN) (* ;; "Utilites ") (FNS ONED.TRACKCURSOR TWOD.TRACKCURSOR INSPECT.INVERTSELECTION INSPECT.INVERTREGION INSPECT.FLIPSELECTION) (INITVARS INSPECTORFONT) (GLOBALVARS INSPECTORFONT) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS INSPECT.SELECTION ONED.SELECTION TWOD.SELECTION)) (INITRECORDS ONED.SELECTION TWOD.SELECTION) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))) (* ;; "Substrate for two-dimensional inspectors. Used in inspecting arrays.") (* ;; "Added by yabu.fx, for SUNLOADUP without DWIM. They compute load time constants, and must come first in the file." ) (DEFINEQ (\CREATE.TWODINSPECTOR.TITLEMENU [LAMBDA NIL (create MENU ITEMS _ '(("Refetch" 'REFETCH "Refetch the datum") ("IT _ Datum" 'IT "Bind IT to the inspected datum"]) (\CREATE.TWODINSPECTOR.SETMENU [LAMBDA NIL (create MENU ITEMS _ '(("IT _ Selection" 'IT "Bind IT to the value of the selected entry") ("Set" 'SET "Set the selected entry"]) (\CREATE.TWODINSPECTOR.INSPECTMENU [LAMBDA NIL (create MENU ITEMS _ '(("Inspect" 'INSPECT "Inspect the value of the selected entry") ("IT _ Selection" 'IT "Bind IT to the value of the selected entry") ("Set" 'SET "Set the selected entry"]) ) (* ;; "Oned-inspector ") (DEFINEQ (ONEDINSPECTW.CREATE [LAMBDA (DATUM PROPS FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLE TITLECOMMANDFN WHERE TOPRIGHT) (* ; "Edited 6-Apr-87 17:03 by jop") (* ;;  "If where is a window, it may be the result of a previous call, so try to reuse all windows") (PROG ((PROFILE (MAKE-INSPECTOR-PROFILE)) [FONT (OR INSPECTORFONT (DEFAULTFONT 'DISPLAY] [TITLEFONT (OR (DSPFONT NIL WindowTitleDisplayStream) '(HELVETICA 8 MRR] DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT WINDOWGROUP) (WITH-INSPECTOR-ENV PROFILE (if (LITATOM PROPS) then (SETQ PROPS (APPLY* PROPS DATUM))) (* ;  "DISPLAYWINDOW is the central and main window of the group") (SETQ DISPLAYWINDOW (GET-ONED-DISPLAYW WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLECOMMANDFN PROPS PROFILE FONT)) (* ;  "RIGHTWINDOW records the ROWPROPS") (SETQ RIGHTWINDOW (GET-RIGHTW DISPLAYWINDOW FONT)) (* ;  "TITLEWINDOW will only hold a title") (SETQ TITLEWINDOW (GET-TITLEW DISPLAYWINDOW TITLE TITLEFONT DATUM)) (* ; "Put up the window group") [if (NOT (POSITIONP TOPRIGHT)) then (LET ((REGION (if (WINDOWP WHERE) then (WINDOWPROP WHERE 'REGION) elseif (REGIONP WHERE) then WHERE))) (if REGION then (SETQ GLEFT (fetch (REGION LEFT) of REGION)) (SETQ GBOTTOM (fetch (REGION BOTTOM) of REGION)) (SETQ GWIDTH (fetch (REGION WIDTH) of REGION)) (SETQ GHEIGHT (fetch (REGION HEIGHT) of REGION)) elseif (POSITIONP WHERE) then (SETQ GLEFT (fetch (POSITION XCOORD) of WHERE)) (SETQ GBOTTOM (fetch (POSITION YCOORD) of WHERE] (SETQ WINDOWGROUP (ONEDINSPECT.ARRANGEWINDOWS DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT TOPRIGHT)) (* ;; "Display the group") (ONEDINSPECT.RESHAPEFN DISPLAYWINDOW) (RIGHTW.RESHAPEFN RIGHTWINDOW) (TITLEW.REPAINTFN TITLEWINDOW) (* ;; "then establish reshapefns for windows in group") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION ONEDINSPECT.RESHAPEFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION RIGHTW.RESHAPEFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION TITLEW.REPAINTFN))) (* ;; "finally return the group") (RETURN WINDOWGROUP]) (GET-ONED-DISPLAYW [LAMBDA (WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLECOMMANDFN PROPS PROFILE FONT) (* ; "Edited 6-Apr-87 14:57 by jop") (LET [(DISPLAYWINDOW (if (WINDOWP WHERE) then WHERE else (CREATEW (CREATEREGION 0 0 100 100) NIL 2 T] (WINDOWPROP DISPLAYWINDOW 'REPAINTFN (FUNCTION ONEDINSPECT.REPAINTFN)) (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP DISPLAYWINDOW 'SCROLLFN (FUNCTION ONEDINSPECT.SCROLLFN)) (WINDOWPROP DISPLAYWINDOW 'BUTTONEVENTFN (FUNCTION ONEDINSPECT.BUTTONEVENTFN)) (WINDOWPROP DISPLAYWINDOW 'COPYBUTTONEVENTFN (FUNCTION ONEDINSPECT.COPYBUTTONFN)) (WINDOWPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION ONEDINSPECT.CLOSEFN)) (DSPRIGHTMARGIN MAX.SMALLP DISPLAYWINDOW) (DSPFONT FONT DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW 'DATUM DATUM) (WINDOWPROP DISPLAYWINDOW 'FETCHFN FETCHFN) (WINDOWPROP DISPLAYWINDOW 'STOREFN STOREFN) (WINDOWPROP DISPLAYWINDOW 'VALUECOMMANDFN (OR VALUECOMMANDFN (FUNCTION ONEDINSPECT.DEFAULT.VALUECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPCOMMANDFN PROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'TITLECOMMANDFN (OR TITLECOMMANDFN (FUNCTION ONEDINSPECT.DEFAULT.TITLECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPS PROPS) (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'VALUEWIDTH (ONEDINSPECT.VALUEWIDTH DATUM PROPS FETCHFN FONT)) (WINDOWPROP DISPLAYWINDOW 'VALUESPACE " ") (WINDOWPROP DISPLAYWINDOW 'PROFILE PROFILE) DISPLAYWINDOW]) (ONEDINSPECT.ARRANGEWINDOWS [LAMBDA (DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW TOTALLEFT TOTALBOTTOM TOTALWIDTH TOTALHEIGHT TOPRIGHT) (* ; "Edited 11-Aug-2020 11:21 by rmk:") (* ; "Edited 6-Apr-87 15:08 by jop") (* ;; "RMK: Save the ROWPROPWIDTH for future right-adjusting of the right (props) window") (* ;; "REGION should be the total available area") (PROG ((ROWPROPS (WINDOWPROP DISPLAYWINDOW 'ROWPROPS)) (ROWPROPSPACE (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE)) (VALUEWIDTH (WINDOWPROP DISPLAYWINDOW 'VALUEWIDTH)) (VALUESPACE (WINDOWPROP DISPLAYWINDOW 'VALUESPACE)) TOTALRIGHT TOTALTOP DWHEIGHT DWWIDTH TITLEHEIGHT RWWIDTH DWLEFT DWBOTTOM ROWPROPWIDTH) [SETQ TITLEHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEWINDOW 'HEIGHT) NIL (WINDOWPROP TITLEWINDOW 'BORDER] (SETQ ROWPROPWIDTH (ONEDINSPECT.PROPWIDTH (WINDOWPROP DISPLAYWINDOW 'ROWPROPS) DISPLAYWINDOW)) [SETQ RWWIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH ROWPROPSPACE RIGHTWINDOW) ROWPROPWIDTH) (WINDOWPROP RIGHTWINDOW 'BORDER] (if (NULL TOTALHEIGHT) then [SETQ DWHEIGHT (IMIN 500 (HEIGHTIFWINDOW (ITIMES (FONTPROP DISPLAYWINDOW 'HEIGHT) (LENGTH ROWPROPS)) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER] (SETQ TOTALHEIGHT (IPLUS TITLEHEIGHT DWHEIGHT)) else (SETQ DWHEIGHT (IDIFFERENCE TOTALHEIGHT TITLEHEIGHT))) (if (NULL TOTALWIDTH) then [SETQ DWWIDTH (IMIN 200 (WIDTHIFWINDOW (IPLUS VALUEWIDTH (STRINGWIDTH VALUESPACE DISPLAYWINDOW) ) (WINDOWPROP DISPLAYWINDOW 'BORDER] (SETQ TOTALWIDTH (IPLUS RWWIDTH DWWIDTH)) else (SETQ DWWIDTH (IDIFFERENCE TOTALWIDTH RWWIDTH))) [if (POSITIONP TOPRIGHT) then (SETQ TOTALRIGHT (fetch (POSITION XCOORD) of TOPRIGHT)) (SETQ TOTALTOP (fetch (POSITION YCOORD) of TOPRIGHT)) elseif (AND TOTALLEFT TOTALBOTTOM) then (SETQ TOTALRIGHT (IPLUS TOTALLEFT (SUB1 TOTALWIDTH))) (SETQ TOTALTOP (IPLUS TOTALBOTTOM (SUB1 TOTALHEIGHT))) else (LET ((REGION (GETBOXREGION TOTALWIDTH TOTALHEIGHT NIL NIL NIL "Position Inspector window"))) (SETQ TOTALTOP (fetch (REGION TOP) of REGION)) (SETQ TOTALRIGHT (fetch (REGION RIGHT) of REGION] [SETQ DWLEFT (DIFFERENCE TOTALRIGHT (SUB1 (PLUS DWWIDTH RWWIDTH] (if (ILESSP DWLEFT 0) then (SETQ DWLEFT 0) (SETQ DWWIDTH (DIFFERENCE (ADD1 TOTALRIGHT) RWWIDTH))) [SETQ DWBOTTOM (DIFFERENCE TOTALTOP (SUB1 (PLUS DWHEIGHT TITLEHEIGHT] (if (LESSP DWBOTTOM 0) then (SETQ DWBOTTOM 0) (SETQ DWHEIGHT (DIFFERENCE (ADD1 TOTALTOP) TITLEHEIGHT))) (* ;; "put up the window group") (WINDOWPROP DISPLAYWINDOW 'MINSIZE (CONS 0 0)) (SHAPEW DISPLAYWINDOW (CREATEREGION DWLEFT DWBOTTOM DWWIDTH DWHEIGHT)) (* ;  "Need to set the Minsize BEFORE reshaping else we catch the default minsize") (WINDOWPROP RIGHTWINDOW 'MINSIZE (CONS RWWIDTH 0)) (WINDOWPROP RIGHTWINDOW 'MAXSIZE (CONS RWWIDTH MAX.SMALLP)) (WINDOWPROP RIGHTWINDOW 'ROWPROPWIDTH ROWPROPWIDTH) (SHAPEW RIGHTWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) of (WINDOWPROP DISPLAYWINDOW 'REGION] DWBOTTOM RWWIDTH DWHEIGHT)) (ATTACHWINDOW RIGHTWINDOW DISPLAYWINDOW 'RIGHT) (WINDOWPROP TITLEWINDOW 'MINSIZE (CONS 0 TITLEHEIGHT)) (WINDOWPROP TITLEWINDOW 'MAXSIZE (CONS MAX.SMALLP TITLEHEIGHT)) (SHAPEW TITLEWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) (WINDOWPROP DISPLAYWINDOW 'REGION] TOTALWIDTH TITLEHEIGHT)) (ATTACHWINDOW TITLEWINDOW DISPLAYWINDOW 'TOP) (RETURN DISPLAYWINDOW]) (ONEDINSPECT.REPAINTFN +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Feb-2021 14:31:33"  {DSK}kaplan>Local>medley3.5>git-medley>sources>TWODINSPECTOR.;6 113157 changes to%: (FNS TWODINSPECT.ARRANGEWINDOWS RIGHTW.REPAINTFN TWODINSPECT.SCROLLFN GET-RIGHTW ONEDINSPECT.SCROLLFN) previous date%: "11-Aug-2020 11:22:30" {DSK}kaplan>Local>medley3.5>git-medley>sources>TWODINSPECTOR.;2) (* ; " Copyright (c) 1985, 1900, 1987, 1990, 1992, 1993, 2020, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT TWODINSPECTORCOMS) (RPAQQ TWODINSPECTORCOMS ( (* ;; "Substrate for two-dimensional inspectors. Used in inspecting arrays.") (COMS (* ;; "Added by yabu.fx, for SUNLOADUP without DWIM. They compute load time constants, and must come first in the file.") (FNS \CREATE.TWODINSPECTOR.TITLEMENU \CREATE.TWODINSPECTOR.SETMENU \CREATE.TWODINSPECTOR.INSPECTMENU)) (* ;; "Oned-inspector ") (FNS ONEDINSPECTW.CREATE GET-ONED-DISPLAYW ONEDINSPECT.ARRANGEWINDOWS ONEDINSPECT.REPAINTFN ONEDINSPECT.PRINTELEMENT ONEDINSPECT.RESHAPEFN ONEDINSPECT.MAKEREGIONS ONEDINSPECT.BUTTONEVENTFN ONEDINSPECT.COPYBUTTONFN ONEDINSPECT.SCROLLFN ONEDINSPECT.CLOSEFN ONEDINSPECT.REDISPLAY ONEDINSPECT.REPLACE ONEDINSPECT.SELECTITEM ONEDINSPECT.SELECTPROP ONEDINSPECT.ADJUSTSELECTION ONEDINSPECT.PROPWIDTH ONEDINSPECT.VALUEWIDTH ONEDINSPECT.DEFAULT.TITLECOMMANDFN ONEDINSPECT.DEFAULT.VALUECOMMANDFN ONEDINSPECT.SETELT) (* ;; "Twod-inspector") (FNS TWODINSPECTW.CREATE GET-TWOD-DISPLAYW GET-CORNERW TWODINSPECT.ARRANGEWINDOWS TWODINSPECT.REPAINTFN TWODINSPECT.PRINTELEMENT TWODINSPECT.RESHAPEFN TWODINSPECT.MAKEREGIONS TWODINSPECT.BUTTONEVENTFN TWODINSPECT.COPYBUTTONFN TWODINSPECT.DOWINDOWCOMFN TWODINSPECT.SCROLLFN TWODINSPECT.CLOSEFN TWODINSPECT.REDISPLAY TWODINSPECT.REPLACE TWODINSPECT.SELECTITEM TWODINSPECT.SELECTROWPROP TWODINSPECT.SELECTCOLUMNPROP TWODINSPECT.ADJUSTSELECTION TWODINSPECT.DEFAULT.TITLECOMMANDFN TWODINSPECT.DEFAULT.VALUECOMMANDFN TWODINSPECT.SETELT TWODINSPECT.ROWPROPWIDTH TWODINSPECT.COLUMNWIDTHS TWODINSPECT.COLUMNWIDTH TWODINSPECT.TOTALWIDTH) (* ;; "Right window fns") (FNS GET-RIGHTW RIGHTW.REPAINTFN RIGHTW.RESHAPEFN RIGHTW.BUTTONEVENTFN RIGHTW.ADJUSTSELECTION ) (* ;; "Top window fns") (FNS GET-TOPW TOPW.REPAINTFN TOPW.RESHAPEFN TOPW.ADJUSTSELECTION TOPW.BUTTONEVENTFN) (* ;; "Title window fns") (FNS GET-TITLEW TITLEW.REPAINTFN TITLEW.BUTTONEVENTFN) (* ;; "Utilites ") (FNS ONED.TRACKCURSOR TWOD.TRACKCURSOR INSPECT.INVERTSELECTION INSPECT.INVERTREGION INSPECT.FLIPSELECTION) (INITVARS INSPECTORFONT) (GLOBALVARS INSPECTORFONT) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS INSPECT.SELECTION ONED.SELECTION TWOD.SELECTION)) (INITRECORDS ONED.SELECTION TWOD.SELECTION) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))) (* ;; "Substrate for two-dimensional inspectors. Used in inspecting arrays.") (* ;; "Added by yabu.fx, for SUNLOADUP without DWIM. They compute load time constants, and must come first in the file." ) (DEFINEQ (\CREATE.TWODINSPECTOR.TITLEMENU [LAMBDA NIL (create MENU ITEMS _ '(("Refetch" 'REFETCH "Refetch the datum") ("IT _ Datum" 'IT "Bind IT to the inspected datum"]) (\CREATE.TWODINSPECTOR.SETMENU [LAMBDA NIL (create MENU ITEMS _ '(("IT _ Selection" 'IT "Bind IT to the value of the selected entry") ("Set" 'SET "Set the selected entry"]) (\CREATE.TWODINSPECTOR.INSPECTMENU [LAMBDA NIL (create MENU ITEMS _ '(("Inspect" 'INSPECT "Inspect the value of the selected entry") ("IT _ Selection" 'IT "Bind IT to the value of the selected entry") ("Set" 'SET "Set the selected entry"]) ) (* ;; "Oned-inspector ") (DEFINEQ (ONEDINSPECTW.CREATE [LAMBDA (DATUM PROPS FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLE TITLECOMMANDFN WHERE TOPRIGHT) (* ; "Edited 6-Apr-87 17:03 by jop") (* ;;  "If where is a window, it may be the result of a previous call, so try to reuse all windows") (PROG ((PROFILE (MAKE-INSPECTOR-PROFILE)) [FONT (OR INSPECTORFONT (DEFAULTFONT 'DISPLAY] [TITLEFONT (OR (DSPFONT NIL WindowTitleDisplayStream) '(HELVETICA 8 MRR] DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT WINDOWGROUP) (WITH-INSPECTOR-ENV PROFILE (if (LITATOM PROPS) then (SETQ PROPS (APPLY* PROPS DATUM))) (* ;  "DISPLAYWINDOW is the central and main window of the group") (SETQ DISPLAYWINDOW (GET-ONED-DISPLAYW WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLECOMMANDFN PROPS PROFILE FONT)) (* ;  "RIGHTWINDOW records the ROWPROPS") (SETQ RIGHTWINDOW (GET-RIGHTW DISPLAYWINDOW FONT)) (* ;  "TITLEWINDOW will only hold a title") (SETQ TITLEWINDOW (GET-TITLEW DISPLAYWINDOW TITLE TITLEFONT DATUM)) (* ; "Put up the window group") [if (NOT (POSITIONP TOPRIGHT)) then (LET ((REGION (if (WINDOWP WHERE) then (WINDOWPROP WHERE 'REGION) elseif (REGIONP WHERE) then WHERE))) (if REGION then (SETQ GLEFT (fetch (REGION LEFT) of REGION)) (SETQ GBOTTOM (fetch (REGION BOTTOM) of REGION)) (SETQ GWIDTH (fetch (REGION WIDTH) of REGION)) (SETQ GHEIGHT (fetch (REGION HEIGHT) of REGION)) elseif (POSITIONP WHERE) then (SETQ GLEFT (fetch (POSITION XCOORD) of WHERE)) (SETQ GBOTTOM (fetch (POSITION YCOORD) of WHERE] (SETQ WINDOWGROUP (ONEDINSPECT.ARRANGEWINDOWS DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT TOPRIGHT)) (* ;; "Display the group") (ONEDINSPECT.RESHAPEFN DISPLAYWINDOW) (RIGHTW.RESHAPEFN RIGHTWINDOW) (TITLEW.REPAINTFN TITLEWINDOW) (* ;; "then establish reshapefns for windows in group") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION ONEDINSPECT.RESHAPEFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION RIGHTW.RESHAPEFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION TITLEW.REPAINTFN))) (* ;; "finally return the group") (RETURN WINDOWGROUP]) (GET-ONED-DISPLAYW [LAMBDA (WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLECOMMANDFN PROPS PROFILE FONT) (* ; "Edited 6-Apr-87 14:57 by jop") (LET [(DISPLAYWINDOW (if (WINDOWP WHERE) then WHERE else (CREATEW (CREATEREGION 0 0 100 100) NIL 2 T] (WINDOWPROP DISPLAYWINDOW 'REPAINTFN (FUNCTION ONEDINSPECT.REPAINTFN)) (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP DISPLAYWINDOW 'SCROLLFN (FUNCTION ONEDINSPECT.SCROLLFN)) (WINDOWPROP DISPLAYWINDOW 'BUTTONEVENTFN (FUNCTION ONEDINSPECT.BUTTONEVENTFN)) (WINDOWPROP DISPLAYWINDOW 'COPYBUTTONEVENTFN (FUNCTION ONEDINSPECT.COPYBUTTONFN)) (WINDOWPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION ONEDINSPECT.CLOSEFN)) (DSPRIGHTMARGIN MAX.SMALLP DISPLAYWINDOW) (DSPFONT FONT DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW 'DATUM DATUM) (WINDOWPROP DISPLAYWINDOW 'FETCHFN FETCHFN) (WINDOWPROP DISPLAYWINDOW 'STOREFN STOREFN) (WINDOWPROP DISPLAYWINDOW 'VALUECOMMANDFN (OR VALUECOMMANDFN (FUNCTION ONEDINSPECT.DEFAULT.VALUECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPCOMMANDFN PROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'TITLECOMMANDFN (OR TITLECOMMANDFN (FUNCTION ONEDINSPECT.DEFAULT.TITLECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPS PROPS) (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'VALUEWIDTH (ONEDINSPECT.VALUEWIDTH DATUM PROPS FETCHFN FONT)) (WINDOWPROP DISPLAYWINDOW 'VALUESPACE " ") (WINDOWPROP DISPLAYWINDOW 'PROFILE PROFILE) DISPLAYWINDOW]) (ONEDINSPECT.ARRANGEWINDOWS [LAMBDA (DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW TOTALLEFT TOTALBOTTOM TOTALWIDTH TOTALHEIGHT TOPRIGHT) (* ; "Edited 11-Aug-2020 11:21 by rmk:") (* ; "Edited 6-Apr-87 15:08 by jop") (* ;; "RMK: Save the ROWPROPWIDTH for future right-adjusting of the right (props) window") (* ;; "REGION should be the total available area") (PROG ((ROWPROPS (WINDOWPROP DISPLAYWINDOW 'ROWPROPS)) (ROWPROPSPACE (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE)) (VALUEWIDTH (WINDOWPROP DISPLAYWINDOW 'VALUEWIDTH)) (VALUESPACE (WINDOWPROP DISPLAYWINDOW 'VALUESPACE)) TOTALRIGHT TOTALTOP DWHEIGHT DWWIDTH TITLEHEIGHT RWWIDTH DWLEFT DWBOTTOM ROWPROPWIDTH) [SETQ TITLEHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEWINDOW 'HEIGHT) NIL (WINDOWPROP TITLEWINDOW 'BORDER] (SETQ ROWPROPWIDTH (ONEDINSPECT.PROPWIDTH (WINDOWPROP DISPLAYWINDOW 'ROWPROPS) DISPLAYWINDOW)) [SETQ RWWIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH ROWPROPSPACE RIGHTWINDOW) ROWPROPWIDTH) (WINDOWPROP RIGHTWINDOW 'BORDER] (if (NULL TOTALHEIGHT) then [SETQ DWHEIGHT (IMIN 500 (HEIGHTIFWINDOW (ITIMES (FONTPROP DISPLAYWINDOW 'HEIGHT) (LENGTH ROWPROPS)) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER] (SETQ TOTALHEIGHT (IPLUS TITLEHEIGHT DWHEIGHT)) else (SETQ DWHEIGHT (IDIFFERENCE TOTALHEIGHT TITLEHEIGHT))) (if (NULL TOTALWIDTH) then [SETQ DWWIDTH (IMIN 200 (WIDTHIFWINDOW (IPLUS VALUEWIDTH (STRINGWIDTH VALUESPACE DISPLAYWINDOW) ) (WINDOWPROP DISPLAYWINDOW 'BORDER] (SETQ TOTALWIDTH (IPLUS RWWIDTH DWWIDTH)) else (SETQ DWWIDTH (IDIFFERENCE TOTALWIDTH RWWIDTH))) [if (POSITIONP TOPRIGHT) then (SETQ TOTALRIGHT (fetch (POSITION XCOORD) of TOPRIGHT)) (SETQ TOTALTOP (fetch (POSITION YCOORD) of TOPRIGHT)) elseif (AND TOTALLEFT TOTALBOTTOM) then (SETQ TOTALRIGHT (IPLUS TOTALLEFT (SUB1 TOTALWIDTH))) (SETQ TOTALTOP (IPLUS TOTALBOTTOM (SUB1 TOTALHEIGHT))) else (LET ((REGION (GETBOXREGION TOTALWIDTH TOTALHEIGHT NIL NIL NIL "Position Inspector window"))) (SETQ TOTALTOP (fetch (REGION TOP) of REGION)) (SETQ TOTALRIGHT (fetch (REGION RIGHT) of REGION] [SETQ DWLEFT (DIFFERENCE TOTALRIGHT (SUB1 (PLUS DWWIDTH RWWIDTH] (if (ILESSP DWLEFT 0) then (SETQ DWLEFT 0) (SETQ DWWIDTH (DIFFERENCE (ADD1 TOTALRIGHT) RWWIDTH))) [SETQ DWBOTTOM (DIFFERENCE TOTALTOP (SUB1 (PLUS DWHEIGHT TITLEHEIGHT] (if (LESSP DWBOTTOM 0) then (SETQ DWBOTTOM 0) (SETQ DWHEIGHT (DIFFERENCE (ADD1 TOTALTOP) TITLEHEIGHT))) (* ;; "put up the window group") (WINDOWPROP DISPLAYWINDOW 'MINSIZE (CONS 0 0)) (SHAPEW DISPLAYWINDOW (CREATEREGION DWLEFT DWBOTTOM DWWIDTH DWHEIGHT)) (* ;  "Need to set the Minsize BEFORE reshaping else we catch the default minsize") (WINDOWPROP RIGHTWINDOW 'MINSIZE (CONS RWWIDTH 0)) (WINDOWPROP RIGHTWINDOW 'MAXSIZE (CONS RWWIDTH MAX.SMALLP)) (WINDOWPROP RIGHTWINDOW 'ROWPROPWIDTH ROWPROPWIDTH) (SHAPEW RIGHTWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) of (WINDOWPROP DISPLAYWINDOW 'REGION] DWBOTTOM RWWIDTH DWHEIGHT)) (ATTACHWINDOW RIGHTWINDOW DISPLAYWINDOW 'RIGHT) (WINDOWPROP TITLEWINDOW 'MINSIZE (CONS 0 TITLEHEIGHT)) (WINDOWPROP TITLEWINDOW 'MAXSIZE (CONS MAX.SMALLP TITLEHEIGHT)) (SHAPEW TITLEWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) (WINDOWPROP DISPLAYWINDOW 'REGION] TOTALWIDTH TITLEHEIGHT)) (ATTACHWINDOW TITLEWINDOW DISPLAYWINDOW 'TOP) (RETURN DISPLAYWINDOW]) (ONEDINSPECT.REPAINTFN [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 19-Apr-90 10:41 by mitani") (if (NULL WINDOWREGION) then (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW))) @@ -23,7 +23,7 @@ do (ONEDINSPECT.PRINTELEMENT (APPLY* FETCHFN DATUM (CAR PROP)) VMARK DESCENT WINDOW] - (INSPECT.INVERTSELECTION WINDOW]) (ONEDINSPECT.PRINTELEMENT [LAMBDA (ELT BOTTOM SUB1DESCENT WINDOW) (* ; "Edited 19-Apr-90 10:42 by mitani") (MOVETO 0 (IPLUS BOTTOM SUB1DESCENT) WINDOW) (PRIN2 ELT WINDOW]) (ONEDINSPECT.RESHAPEFN [LAMBDA (WINDOW) (* jop%: " 6-Oct-85 18:34") (CLEARW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (ONEDINSPECT.MAKEREGIONS WINDOW) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (ONEDINSPECT.REPAINTFN WINDOW]) (ONEDINSPECT.MAKEREGIONS [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:01 by jop") (* ;; "Sets up windowprops and activeregions") (PROG ((ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VALUEWIDTH (WINDOWPROP WINDOW 'VALUEWIDTH)) (VALUESPACE (WINDOWPROP WINDOW 'VALUESPACE)) (WINDOWHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (LF (DSPLINEFEED NIL WINDOW)) VERTMARKS) (if (NULL VALUEWIDTH) then (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (SETQ VALUEWIDTH (ONEDINSPECT.VALUEWIDTH (WINDOWPROP WINDOW 'DATUM) ROWPROPS (WINDOWPROP WINDOW 'FETCHFN) WINDOW)) (WINDOWPROP WINDOW 'VALUEWIDTH VALUEWIDTH))) (* ; "VERTMARKS mark endpoints") (SETQ VERTMARKS (for I from 1 to (LENGTH ROWPROPS) as MARK from (IPLUS WINDOWHEIGHT LF) by LF collect MARK)) (WINDOWPROP WINDOW 'VERTMARKS VERTMARKS) [WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (IPLUS VALUEWIDTH (STRINGWIDTH VALUESPACE WINDOW)) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS] (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'WIDTH) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS]) (ONEDINSPECT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:03 by jop") (TOTOPW WINDOW) (LET [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) 0 NIL (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) P] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (LET [(SELECTEDPROP (CAR (fetch (ONED.SELECTION PROP) of SELECTION))) (DATUM (WINDOWPROP WINDOW 'DATUM] (CL:FUNCALL (WINDOWPROP WINDOW 'VALUECOMMANDFN) (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) DATUM SELECTEDPROP) SELECTEDPROP DATUM WINDOW]) (ONEDINSPECT.COPYBUTTONFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:09 by jop") (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TOTOPW WINDOW) (bind SELECTION while (.COPYKEYDOWNP.) do (BLOCK) (SETQ SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) 0 NIL 2 [FUNCTION (LAMBDA (P W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) P] (FUNCTION INSPECT.FLIPSELECTION))) finally (if SELECTION then (INSPECT.FLIPSELECTION (fetch (ONED.SELECTION ELTLEFT) of SELECTION) (fetch (ONED.SELECTION ELTBOTTOM) of SELECTION) (fetch (ONED.SELECTION ELTWIDTH) of SELECTION) 2 WINDOW) (BKSYSBUF.GENERAL (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) (CAR (fetch (ONED.SELECTION PROP) of SELECTION]) (ONEDINSPECT.SCROLLFN [LAMBDA (WINDOW DX DY FLG) (* jop%: " 1-Oct-85 22:41") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (OR (NOT (EQP 0 DY)) (FLOATP DY)) then (APPLY* (WINDOWPROP RIGHTWINDOW 'SCROLLFN) RIGHTWINDOW 0 DY FLG)) (SCROLLBYREPAINTFN WINDOW DX DY FLG]) (ONEDINSPECT.CLOSEFN [LAMBDA (WINDOW) (* jop%: " 4-Oct-85 17:52") (DETACHALLWINDOWS WINDOW) (WINDOWPROP WINDOW 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'SELECTION NIL]) (ONEDINSPECT.REDISPLAY [LAMBDA (WINDOW ELTPROPS) (* ; "Edited 8-Apr-87 17:00 by jop") (* ;; "ELTPROPS may be a single entries, a list, or NIL. If NIL than the whole inspector is refetched and redisplayed") (if (AND ELTPROPS (NLISTP ELTPROPS)) then (SETQ ELTPROPS (LIST ELTPROPS))) (PROG ((FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (DATUM (WINDOWPROP WINDOW 'DATUM)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VALUEWIDTH (WINDOWPROP WINDOW 'VALUEWIDTH)) (SELECTION (WINDOWPROP WINDOW 'SELECTION)) ELTS ELTBOTTOMS) (SETQ ELTS (for PROP in ELTPROPS collect (APPLY* FETCHFN DATUM PROP))) [SETQ ELTBOTTOMS (for ELTPROP in ELTPROPS collect (for VMARK in VERTMARKS as PROP in ROWPROPS thereis (EQUAL PROP ELTPROP] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (AND ELTS (for ELTWIDTH in (for ELT in ELTS collect (STRINGWIDTH ELT WINDOW T) ) never (IGREATERP ELTWIDTH VALUEWIDTH))) then (INSPECT.INVERTSELECTION WINDOW) (bind (FHEIGHT _ (FONTPROP WINDOW 'HEIGHT)) (FDESCENT _ (FONTPROP WINDOW 'DESCENT)) for ELT in ELTS as BOTTOM in ELTBOTTOMS do (BITBLT NIL NIL NIL WINDOW 0 BOTTOM VALUEWIDTH FHEIGHT 'TEXTURE 'REPLACE WHITESHADE) (ONEDINSPECT.PRINTELEMENT ELT BOTTOM FDESCENT WINDOW)) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (INSPECT.INVERTSELECTION WINDOW) else (* ; "Recompute the whole picture") (WINDOWPROP WINDOW 'VALUEWIDTH NIL) (ONEDINSPECT.MAKEREGIONS WINDOW) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (DSPRESET WINDOW) (ONEDINSPECT.REPAINTFN WINDOW) (DSPRESET (WINDOWPROP WINDOW 'RIGHTWINDOW)) (RIGHTW.REPAINTFN (WINDOWPROP WINDOW 'RIGHTWINDOW]) (ONEDINSPECT.REPLACE [LAMBDA (WINDOW PROP NEWVALUE) (* jop%: " 2-Oct-85 00:06") (PROG [(DATUM (WINDOWPROP WINDOW 'DATUM)) (STOREFN (WINDOWPROP WINDOW 'STOREFN] (APPLY* STOREFN NEWVALUE DATUM PROP) (ONEDINSPECT.REDISPLAY WINDOW PROP]) (ONEDINSPECT.SELECTITEM [LAMBDA (WINDOW PROP) (* ; "Edited 6-Apr-87 11:36 by jop") (if (WINDOWPROP WINDOW 'SELECTION) then (INSPECT.INVERTSELECTION WINDOW)) (if PROP then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDPROP SELECTEDELTBOTTOM SELECTEDELTWIDTH) (SETQ SELECTEDPROP (for PRP on ROWPROPS thereis (EQUAL (CAR PRP) PROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as PRP on ROWPROPS thereis (EQ PRP SELECTEDPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM PROP) WINDOW T))) (INSPECT.INVERTREGION 0 SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) WINDOW) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ 0 ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP]) (ONEDINSPECT.SELECTPROP [LAMBDA (WINDOW PROP) (* ; "Edited 6-Apr-87 11:37 by jop") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (WINDOWPROP RIGHTWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION RIGHTWINDOW)) (PROG ((ROWPROPSPACE (WINDOWPROP WINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) SELECTEDPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDPROP (for PRP on ROWPROPS thereis (EQUAL (CAR PRP) PROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as PRP on ROWPROPS thereis (EQ PRP SELECTEDPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) RIGHTWINDOW) (WINDOWPROP RIGHTWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP]) (ONEDINSPECT.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:34 by jop") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (SELPROP (fetch (ONED.SELECTION PROP) of SELECTION))) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ (for VMARK in VERTMARKS as PROP on ROWPROPS thereis (EQ PROP SELPROP)) ELTWIDTH _ (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM (CAR SELPROP)) WINDOW T)) ELTLEFT _ 0 PROP _ SELPROP]) (ONEDINSPECT.PROPWIDTH [LAMBDA (PROPS FONT) (* ; "Edited 11-Aug-2020 11:04 by rmk:") (* ; "Edited 5-Apr-87 16:18 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (* ;; "RMK: Added more SPACE: wasn't wide enough for large indexes") (for PROP in PROPS largest (STRINGWIDTH PROP FONT T) finally (RETURN (IPLUS (CHARWIDTH (CHARCODE SPACE) T) $$EXTREME]) (ONEDINSPECT.VALUEWIDTH [LAMBDA (DATUM PROPS FETCHFN FONT) (* ; "Edited 5-Apr-87 16:20 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (for PROP in PROPS largest (STRINGWIDTH (APPLY* FETCHFN DATUM PROP) FONT T) finally (RETURN $$EXTREME]) (ONEDINSPECT.DEFAULT.TITLECOMMANDFN [LAMBDA (WINDOW) (* ; "Edited 20-Jul-90 20:47 by yabu") (if (MOUSESTATE MIDDLE) then (PROG [(TITLEMENU (CONSTANT (\CREATE.TWODINSPECTOR.TITLEMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Refetch%" 'REFETCH %"Refetch the datum%") (%"IT _ Datum%" 'IT %"Bind IT to the inspected datum%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (DATUM (WINDOWPROP WINDOW 'DATUM] (SELECTQ (MENU TITLEMENU) (REFETCH (ONEDINSPECT.REDISPLAY WINDOW)) (IT (SETQ IT DATUM) (PROMPTPRINT "IT bound to " DATUM)) NIL]) (ONEDINSPECT.DEFAULT.VALUECOMMANDFN [LAMBDA (VALUE PROP DATUM WINDOW) (* ; "Edited 20-Jul-90 20:51 by yabu") (PROG ((SETMENU (CONSTANT (\CREATE.TWODINSPECTOR.SETMENU))) (* ; "Original was (create MENU ITEMS _ '((%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (INSPECTMENU (CONSTANT (\CREATE.TWODINSPECTOR.INSPECTMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Inspect%" 'INSPECT %"Inspect the value of the selected entry%") (%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (SELECTQ (if (OR (NULL VALUE) (NUMBERP VALUE)) then (MENU SETMENU) else (MENU INSPECTMENU)) (INSPECT (INSPECT VALUE)) (IT (SETQ IT VALUE) (PROMPTPRINT "IT bound to " IT)) (SET (ONEDINSPECT.SETELT PROP WINDOW)) NIL]) (ONEDINSPECT.SETELT + (INSPECT.INVERTSELECTION WINDOW]) (ONEDINSPECT.PRINTELEMENT [LAMBDA (ELT BOTTOM SUB1DESCENT WINDOW) (* ; "Edited 19-Apr-90 10:42 by mitani") (MOVETO 0 (IPLUS BOTTOM SUB1DESCENT) WINDOW) (PRIN2 ELT WINDOW]) (ONEDINSPECT.RESHAPEFN [LAMBDA (WINDOW) (* jop%: " 6-Oct-85 18:34") (CLEARW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (ONEDINSPECT.MAKEREGIONS WINDOW) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (ONEDINSPECT.REPAINTFN WINDOW]) (ONEDINSPECT.MAKEREGIONS [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:01 by jop") (* ;; "Sets up windowprops and activeregions") (PROG ((ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VALUEWIDTH (WINDOWPROP WINDOW 'VALUEWIDTH)) (VALUESPACE (WINDOWPROP WINDOW 'VALUESPACE)) (WINDOWHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (LF (DSPLINEFEED NIL WINDOW)) VERTMARKS) (if (NULL VALUEWIDTH) then (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (SETQ VALUEWIDTH (ONEDINSPECT.VALUEWIDTH (WINDOWPROP WINDOW 'DATUM) ROWPROPS (WINDOWPROP WINDOW 'FETCHFN) WINDOW)) (WINDOWPROP WINDOW 'VALUEWIDTH VALUEWIDTH))) (* ; "VERTMARKS mark endpoints") (SETQ VERTMARKS (for I from 1 to (LENGTH ROWPROPS) as MARK from (IPLUS WINDOWHEIGHT LF) by LF collect MARK)) (WINDOWPROP WINDOW 'VERTMARKS VERTMARKS) [WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (IPLUS VALUEWIDTH (STRINGWIDTH VALUESPACE WINDOW)) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS] (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'WIDTH) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS]) (ONEDINSPECT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:03 by jop") (TOTOPW WINDOW) (LET [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) 0 NIL (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) P] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (LET [(SELECTEDPROP (CAR (fetch (ONED.SELECTION PROP) of SELECTION))) (DATUM (WINDOWPROP WINDOW 'DATUM] (CL:FUNCALL (WINDOWPROP WINDOW 'VALUECOMMANDFN) (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) DATUM SELECTEDPROP) SELECTEDPROP DATUM WINDOW]) (ONEDINSPECT.COPYBUTTONFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:09 by jop") (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TOTOPW WINDOW) (bind SELECTION while (.COPYKEYDOWNP.) do (BLOCK) (SETQ SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) 0 NIL 2 [FUNCTION (LAMBDA (P W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) P] (FUNCTION INSPECT.FLIPSELECTION))) finally (if SELECTION then (INSPECT.FLIPSELECTION (fetch (ONED.SELECTION ELTLEFT) of SELECTION) (fetch (ONED.SELECTION ELTBOTTOM) of SELECTION) (fetch (ONED.SELECTION ELTWIDTH) of SELECTION) 2 WINDOW) (BKSYSBUF.GENERAL (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) (CAR (fetch (ONED.SELECTION PROP) of SELECTION]) (ONEDINSPECT.SCROLLFN [LAMBDA (WINDOW DX DY FLG) (* ; "Edited 19-Feb-2021 12:09 by rmk:") (* jop%: " 1-Oct-85 22:41") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (OR (NOT (EQP 0 DY)) (FLOATP DY)) then (APPLY* (OR (WINDOWPROP RIGHTWINDOW 'SCROLLFN) (FUNCTION SCROLLBYREPAINTFN)) RIGHTWINDOW 0 DY FLG)) (SCROLLBYREPAINTFN WINDOW DX DY FLG]) (ONEDINSPECT.CLOSEFN [LAMBDA (WINDOW) (* jop%: " 4-Oct-85 17:52") (DETACHALLWINDOWS WINDOW) (WINDOWPROP WINDOW 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'SELECTION NIL]) (ONEDINSPECT.REDISPLAY [LAMBDA (WINDOW ELTPROPS) (* ; "Edited 8-Apr-87 17:00 by jop") (* ;; "ELTPROPS may be a single entries, a list, or NIL. If NIL than the whole inspector is refetched and redisplayed") (if (AND ELTPROPS (NLISTP ELTPROPS)) then (SETQ ELTPROPS (LIST ELTPROPS))) (PROG ((FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (DATUM (WINDOWPROP WINDOW 'DATUM)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VALUEWIDTH (WINDOWPROP WINDOW 'VALUEWIDTH)) (SELECTION (WINDOWPROP WINDOW 'SELECTION)) ELTS ELTBOTTOMS) (SETQ ELTS (for PROP in ELTPROPS collect (APPLY* FETCHFN DATUM PROP))) [SETQ ELTBOTTOMS (for ELTPROP in ELTPROPS collect (for VMARK in VERTMARKS as PROP in ROWPROPS thereis (EQUAL PROP ELTPROP] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (AND ELTS (for ELTWIDTH in (for ELT in ELTS collect (STRINGWIDTH ELT WINDOW T) ) never (IGREATERP ELTWIDTH VALUEWIDTH))) then (INSPECT.INVERTSELECTION WINDOW) (bind (FHEIGHT _ (FONTPROP WINDOW 'HEIGHT)) (FDESCENT _ (FONTPROP WINDOW 'DESCENT)) for ELT in ELTS as BOTTOM in ELTBOTTOMS do (BITBLT NIL NIL NIL WINDOW 0 BOTTOM VALUEWIDTH FHEIGHT 'TEXTURE 'REPLACE WHITESHADE) (ONEDINSPECT.PRINTELEMENT ELT BOTTOM FDESCENT WINDOW)) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (INSPECT.INVERTSELECTION WINDOW) else (* ; "Recompute the whole picture") (WINDOWPROP WINDOW 'VALUEWIDTH NIL) (ONEDINSPECT.MAKEREGIONS WINDOW) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (DSPRESET WINDOW) (ONEDINSPECT.REPAINTFN WINDOW) (DSPRESET (WINDOWPROP WINDOW 'RIGHTWINDOW)) (RIGHTW.REPAINTFN (WINDOWPROP WINDOW 'RIGHTWINDOW]) (ONEDINSPECT.REPLACE [LAMBDA (WINDOW PROP NEWVALUE) (* jop%: " 2-Oct-85 00:06") (PROG [(DATUM (WINDOWPROP WINDOW 'DATUM)) (STOREFN (WINDOWPROP WINDOW 'STOREFN] (APPLY* STOREFN NEWVALUE DATUM PROP) (ONEDINSPECT.REDISPLAY WINDOW PROP]) (ONEDINSPECT.SELECTITEM [LAMBDA (WINDOW PROP) (* ; "Edited 6-Apr-87 11:36 by jop") (if (WINDOWPROP WINDOW 'SELECTION) then (INSPECT.INVERTSELECTION WINDOW)) (if PROP then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDPROP SELECTEDELTBOTTOM SELECTEDELTWIDTH) (SETQ SELECTEDPROP (for PRP on ROWPROPS thereis (EQUAL (CAR PRP) PROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as PRP on ROWPROPS thereis (EQ PRP SELECTEDPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM PROP) WINDOW T))) (INSPECT.INVERTREGION 0 SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) WINDOW) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ 0 ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP]) (ONEDINSPECT.SELECTPROP [LAMBDA (WINDOW PROP) (* ; "Edited 6-Apr-87 11:37 by jop") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (WINDOWPROP RIGHTWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION RIGHTWINDOW)) (PROG ((ROWPROPSPACE (WINDOWPROP WINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) SELECTEDPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDPROP (for PRP on ROWPROPS thereis (EQUAL (CAR PRP) PROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as PRP on ROWPROPS thereis (EQ PRP SELECTEDPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) RIGHTWINDOW) (WINDOWPROP RIGHTWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP]) (ONEDINSPECT.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:34 by jop") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (SELPROP (fetch (ONED.SELECTION PROP) of SELECTION))) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ (for VMARK in VERTMARKS as PROP on ROWPROPS thereis (EQ PROP SELPROP)) ELTWIDTH _ (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM (CAR SELPROP)) WINDOW T)) ELTLEFT _ 0 PROP _ SELPROP]) (ONEDINSPECT.PROPWIDTH [LAMBDA (PROPS FONT) (* ; "Edited 11-Aug-2020 11:04 by rmk:") (* ; "Edited 5-Apr-87 16:18 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (* ;; "RMK: Added more SPACE: wasn't wide enough for large indexes") (for PROP in PROPS largest (STRINGWIDTH PROP FONT T) finally (RETURN (IPLUS (CHARWIDTH (CHARCODE SPACE) T) $$EXTREME]) (ONEDINSPECT.VALUEWIDTH [LAMBDA (DATUM PROPS FETCHFN FONT) (* ; "Edited 5-Apr-87 16:20 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (for PROP in PROPS largest (STRINGWIDTH (APPLY* FETCHFN DATUM PROP) FONT T) finally (RETURN $$EXTREME]) (ONEDINSPECT.DEFAULT.TITLECOMMANDFN [LAMBDA (WINDOW) (* ; "Edited 20-Jul-90 20:47 by yabu") (if (MOUSESTATE MIDDLE) then (PROG [(TITLEMENU (CONSTANT (\CREATE.TWODINSPECTOR.TITLEMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Refetch%" 'REFETCH %"Refetch the datum%") (%"IT _ Datum%" 'IT %"Bind IT to the inspected datum%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (DATUM (WINDOWPROP WINDOW 'DATUM] (SELECTQ (MENU TITLEMENU) (REFETCH (ONEDINSPECT.REDISPLAY WINDOW)) (IT (SETQ IT DATUM) (PROMPTPRINT "IT bound to " DATUM)) NIL]) (ONEDINSPECT.DEFAULT.VALUECOMMANDFN [LAMBDA (VALUE PROP DATUM WINDOW) (* ; "Edited 20-Jul-90 20:51 by yabu") (PROG ((SETMENU (CONSTANT (\CREATE.TWODINSPECTOR.SETMENU))) (* ; "Original was (create MENU ITEMS _ '((%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (INSPECTMENU (CONSTANT (\CREATE.TWODINSPECTOR.INSPECTMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Inspect%" 'INSPECT %"Inspect the value of the selected entry%") (%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (SELECTQ (if (OR (NULL VALUE) (NUMBERP VALUE)) then (MENU SETMENU) else (MENU INSPECTMENU)) (INSPECT (INSPECT VALUE)) (IT (SETQ IT VALUE) (PROMPTPRINT "IT bound to " IT)) (SET (ONEDINSPECT.SETELT PROP WINDOW)) NIL]) (ONEDINSPECT.SETELT [LAMBDA (PROP WINDOW) (* ; "Edited 5-Apr-87 16:29 by jop") (PROG ((PRTWINDOW (GETPROMPTWINDOW WINDOW (if (ILESSP (fetch (REGION WIDTH) of (WINDOWREGION WINDOW)) @@ -46,97 +46,7 @@  "clear tty buffer because it sometimes has stuff left.") (CLEARBUF T T))) (REMOVEPROMPTWINDOW WINDOW) - (ONEDINSPECT.REPLACE WINDOW PROP NEWVALUE]) ) (* ;; "Twod-inspector") (DEFINEQ (TWODINSPECTW.CREATE [LAMBDA (DATUM ROWPROPS COLUMNPROPS FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLE TITLECOMMANDFN WHERE TOPRIGHT) (* ; "Edited 6-Apr-87 17:03 by jop") (* ;;  "If where is a window, it may be the result of a previous call, so try to reuse all windows") (PROG ((PROFILE (MAKE-INSPECTOR-PROFILE)) [FONT (OR INSPECTORFONT (DEFAULTFONT 'DISPLAY] [TITLEFONT (OR (DSPFONT NIL WindowTitleDisplayStream) '(HELVETICA 8 MRR] DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT WINDOWGROUP) (if (LITATOM ROWPROPS) then (SETQ ROWPROPS (APPLY* ROWPROPS DATUM))) (if (LITATOM COLUMNPROPS) then (SETQ COLUMNPROPS (APPLY* COLUMNPROPS DATUM))) (WITH-INSPECTOR-ENV PROFILE (* ;  "DISPLAYWINDOW is the central and main window of the group") (SETQ DISPLAYWINDOW (GET-TWOD-DISPLAYW WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLECOMMANDFN ROWPROPS COLUMNPROPS PROFILE FONT)) (* ;  "TOPWINDOW simply records the COLUMNPROPS") (SETQ TOPWINDOW (GET-TOPW DISPLAYWINDOW FONT)) (* ;  "RIGHTWINDOW records the ROWPROPS") (SETQ RIGHTWINDOW (GET-RIGHTW DISPLAYWINDOW FONT)) (* ;  "CORNERWINDOW is just a place holder") (SETQ CORNERWINDOW (GET-CORNERW DISPLAYWINDOW FONT)) (* ;  "TITLEWINDOW will only hold a title") (SETQ TITLEWINDOW (GET-TITLEW DISPLAYWINDOW TITLE TITLEFONT DATUM)) (* ; "Put up the window group") [if (NOT (POSITIONP TOPRIGHT)) then (LET ((REGION (if (WINDOWP WHERE) then (WINDOWPROP WHERE 'REGION) elseif (REGIONP WHERE) then WHERE))) (if REGION then (SETQ GLEFT (fetch (REGION LEFT) of REGION)) (SETQ GBOTTOM (fetch (REGION BOTTOM) of REGION)) (SETQ GWIDTH (fetch (REGION WIDTH) of REGION)) (SETQ GHEIGHT (fetch (REGION HEIGHT) of REGION)) elseif (POSITIONP WHERE) then (SETQ GLEFT (fetch (POSITION XCOORD) of WHERE)) (SETQ GBOTTOM (fetch (POSITION YCOORD) of WHERE] (SETQ WINDOWGROUP (TWODINSPECT.ARRANGEWINDOWS DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT TOPRIGHT)) (* ;; " Display the group") (TWODINSPECT.RESHAPEFN DISPLAYWINDOW) (TOPW.RESHAPEFN TOPWINDOW) (RIGHTW.RESHAPEFN RIGHTWINDOW) (TITLEW.REPAINTFN TITLEWINDOW) (* ;; "then establish reshapefns on the windows of the window group") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION TWODINSPECT.RESHAPEFN)) (WINDOWPROP TOPWINDOW 'RESHAPEFN (FUNCTION TOPW.RESHAPEFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION RIGHTW.RESHAPEFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION TITLEW.REPAINTFN))) (* ;; "finally return the group") (RETURN WINDOWGROUP]) (GET-TWOD-DISPLAYW [LAMBDA (WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLECOMMANDFN ROWPROPS COLUMNPROPS PROFILE FONT) (* ; "Edited 6-Apr-87 14:51 by jop") (LET [(DISPLAYWINDOW (if (WINDOWP WHERE) then WHERE else (CREATEW (CREATEREGION 0 0 100 100) NIL 2 T] (WINDOWPROP DISPLAYWINDOW 'REPAINTFN (FUNCTION TWODINSPECT.REPAINTFN)) (* ;  "Smash the reshapefn because we don't want to rely on shapew to repaint the windows") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP DISPLAYWINDOW 'SCROLLFN (FUNCTION TWODINSPECT.SCROLLFN)) (WINDOWPROP DISPLAYWINDOW 'BUTTONEVENTFN (FUNCTION TWODINSPECT.BUTTONEVENTFN)) (WINDOWPROP DISPLAYWINDOW 'COPYBUTTONEVENTFN (FUNCTION TWODINSPECT.COPYBUTTONFN)) (WINDOWPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION TWODINSPECT.CLOSEFN)) (DSPRIGHTMARGIN MAX.SMALLP DISPLAYWINDOW) (DSPFONT FONT DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW 'DATUM DATUM) (WINDOWPROP DISPLAYWINDOW 'FETCHFN FETCHFN) (WINDOWPROP DISPLAYWINDOW 'STOREFN STOREFN) (WINDOWPROP DISPLAYWINDOW 'VALUECOMMANDFN (OR VALUECOMMANDFN (FUNCTION TWODINSPECT.DEFAULT.VALUECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPCOMMANDFN ROWPROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPCOMMANDFN COLUMNPROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'TITLECOMMANDFN (OR TITLECOMMANDFN (FUNCTION TWODINSPECT.DEFAULT.TITLECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPS ROWPROPS) (WINDOWPROP DISPLAYWINDOW 'ROWPROPWIDTH (TWODINSPECT.ROWPROPWIDTH ROWPROPS FONT)) (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPS COLUMNPROPS) (WINDOWPROP DISPLAYWINDOW 'COLUMNWIDTHS (TWODINSPECT.COLUMNWIDTHS DATUM ROWPROPS COLUMNPROPS FETCHFN FONT)) (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'PROFILE PROFILE) DISPLAYWINDOW]) (GET-CORNERW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 6-Apr-87 14:52 by jop") (LET [(CORNERWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'CORNERWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (DSPFONT FONT CORNERWINDOW) (WINDOWPROP CORNERWINDOW 'REPAINTFN (FUNCTION CLEARW)) (WINDOWPROP CORNERWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP CORNERWINDOW 'BUTTONEVENTFN NIL) (WINDOWPROP DISPLAYWINDOW 'CORNERWINDOW CORNERWINDOW) CORNERWINDOW]) (TWODINSPECT.ARRANGEWINDOWS - [LAMBDA (DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW TOTALLEFT TOTALBOTTOM - TOTALWIDTH TOTALHEIGHT TOPRIGHT) (* ; "Edited 6-Apr-87 15:10 by jop") - - (* ;; "REGION should be the total available area") - - (PROG ((ROWPROPS (WINDOWPROP DISPLAYWINDOW 'ROWPROPS)) - (COLUMNPROPS (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPS)) - (ROWPROPSPACE (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE)) - (COLUMNWIDTHS (WINDOWPROP DISPLAYWINDOW 'COLUMNWIDTHS)) - (COLUMNPROPSPACE (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPSPACE)) - TOTALRIGHT TOTALTOP DWHEIGHT DWWIDTH TITLEHEIGHT TWHEIGHT RWWIDTH DWLEFT DWBOTTOM) - [SETQ TITLEHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEWINDOW 'HEIGHT) - NIL - (WINDOWPROP TITLEWINDOW 'BORDER] - [SETQ TWHEIGHT (HEIGHTIFWINDOW (FONTPROP TOPWINDOW 'HEIGHT) - NIL - (WINDOWPROP TOPWINDOW 'BORDER] - [SETQ RWWIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH ROWPROPSPACE RIGHTWINDOW) - (TWODINSPECT.ROWPROPWIDTH ROWPROPS RIGHTWINDOW)) - (WINDOWPROP RIGHTWINDOW 'BORDER] - [if (NULL TOTALHEIGHT) - then [SETQ DWHEIGHT (IMIN 500 (HEIGHTIFWINDOW (ITIMES (FONTPROP DISPLAYWINDOW - 'HEIGHT) - (LENGTH ROWPROPS)) - NIL - (WINDOWPROP DISPLAYWINDOW 'BORDER] - (SETQ TOTALHEIGHT (IPLUS TITLEHEIGHT TWHEIGHT DWHEIGHT)) - else (SETQ DWHEIGHT (IDIFFERENCE TOTALHEIGHT (IPLUS TWHEIGHT TITLEHEIGHT] - (if (NULL TOTALWIDTH) - then [SETQ DWWIDTH (IMIN 400 (WIDTHIFWINDOW (TWODINSPECT.TOTALWIDTH - COLUMNWIDTHS COLUMNPROPSPACE - (DSPFONT DISPLAYWINDOW)) - (WINDOWPROP DISPLAYWINDOW 'BORDER] - (SETQ TOTALWIDTH (IPLUS RWWIDTH DWWIDTH)) - else (SETQ DWWIDTH (IDIFFERENCE TOTALWIDTH RWWIDTH))) - [if (POSITIONP TOPRIGHT) - then (SETQ TOTALRIGHT (fetch (POSITION XCOORD) of TOPRIGHT)) - (SETQ TOTALTOP (fetch (POSITION YCOORD) of TOPRIGHT)) - elseif (AND TOTALLEFT TOTALBOTTOM) - then (SETQ TOTALRIGHT (IPLUS TOTALLEFT (SUB1 TOTALWIDTH))) - (SETQ TOTALTOP (IPLUS TOTALBOTTOM (SUB1 TOTALHEIGHT))) - else (LET ((REGION (GETBOXREGION TOTALWIDTH TOTALHEIGHT NIL NIL NIL - "Position Inspector window"))) - (SETQ TOTALTOP (fetch (REGION TOP) of REGION)) - (SETQ TOTALRIGHT (fetch (REGION RIGHT) of REGION] - [SETQ DWLEFT (DIFFERENCE TOTALRIGHT (SUB1 (PLUS DWWIDTH RWWIDTH] - (if (ILESSP DWLEFT 0) - then (SETQ DWLEFT 0) - (SETQ DWWIDTH (DIFFERENCE (ADD1 TOTALRIGHT) - RWWIDTH))) - [SETQ DWBOTTOM (DIFFERENCE TOTALTOP (SUB1 (PLUS DWHEIGHT TWHEIGHT TITLEHEIGHT] - [if (LESSP DWBOTTOM 0) - then (SETQ DWBOTTOM 0) - (SETQ DWHEIGHT (DIFFERENCE (ADD1 TOTALTOP) - (PLUS TWHEIGHT TITLEHEIGHT] - - (* ;; "put up the window group") - - (WINDOWPROP DISPLAYWINDOW 'MINSIZE (CONS 0 0)) - (SHAPEW DISPLAYWINDOW (CREATEREGION DWLEFT DWBOTTOM DWWIDTH DWHEIGHT)) - (* ; - "Need to set the Minsize BEFORE reshaping else we catch the default minsize") - (WINDOWPROP TOPWINDOW 'MINSIZE (CONS 0 TWHEIGHT)) - (WINDOWPROP TOPWINDOW 'MAXSIZE (CONS MAX.SMALLP TWHEIGHT)) - (SHAPEW TOPWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) - of (WINDOWPROP DISPLAYWINDOW - 'REGION] - DWWIDTH TWHEIGHT)) - (ATTACHWINDOW TOPWINDOW DISPLAYWINDOW 'TOP) - (WINDOWPROP RIGHTWINDOW 'MINSIZE (CONS RWWIDTH 0)) - (WINDOWPROP RIGHTWINDOW 'MAXSIZE (CONS RWWIDTH MAX.SMALLP)) - (SHAPEW RIGHTWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) - of (WINDOWPROP DISPLAYWINDOW 'REGION] - DWBOTTOM RWWIDTH DWHEIGHT)) - (WINDOWPROP CORNERWINDOW 'MINSIZE (CONS RWWIDTH TWHEIGHT)) - (WINDOWPROP CORNERWINDOW 'MAXSIZE (CONS RWWIDTH TWHEIGHT)) - (SHAPEW CORNERWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) - of (WINDOWPROP DISPLAYWINDOW 'REGION] - [ADD1 (fetch (REGION TOP) of (WINDOWPROP DISPLAYWINDOW - 'REGION] - RWWIDTH TWHEIGHT)) - (ATTACHWINDOW CORNERWINDOW RIGHTWINDOW 'TOP) - (ATTACHWINDOW RIGHTWINDOW DISPLAYWINDOW 'RIGHT) - (WINDOWPROP TITLEWINDOW 'MINSIZE (CONS 0 TITLEHEIGHT)) - (WINDOWPROP TITLEWINDOW 'MAXSIZE (CONS MAX.SMALLP TITLEHEIGHT)) - (SHAPEW TITLEWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) - (WINDOWPROP TOPWINDOW 'REGION] - TOTALWIDTH TITLEHEIGHT)) - (ATTACHWINDOW TITLEWINDOW DISPLAYWINDOW 'TOP) - (RETURN DISPLAYWINDOW]) (TWODINSPECT.REPAINTFN + (ONEDINSPECT.REPLACE WINDOW PROP NEWVALUE]) ) (* ;; "Twod-inspector") (DEFINEQ (TWODINSPECTW.CREATE [LAMBDA (DATUM ROWPROPS COLUMNPROPS FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLE TITLECOMMANDFN WHERE TOPRIGHT) (* ; "Edited 6-Apr-87 17:03 by jop") (* ;;  "If where is a window, it may be the result of a previous call, so try to reuse all windows") (PROG ((PROFILE (MAKE-INSPECTOR-PROFILE)) [FONT (OR INSPECTORFONT (DEFAULTFONT 'DISPLAY] [TITLEFONT (OR (DSPFONT NIL WindowTitleDisplayStream) '(HELVETICA 8 MRR] DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT WINDOWGROUP) (if (LITATOM ROWPROPS) then (SETQ ROWPROPS (APPLY* ROWPROPS DATUM))) (if (LITATOM COLUMNPROPS) then (SETQ COLUMNPROPS (APPLY* COLUMNPROPS DATUM))) (WITH-INSPECTOR-ENV PROFILE (* ;  "DISPLAYWINDOW is the central and main window of the group") (SETQ DISPLAYWINDOW (GET-TWOD-DISPLAYW WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLECOMMANDFN ROWPROPS COLUMNPROPS PROFILE FONT)) (* ;  "TOPWINDOW simply records the COLUMNPROPS") (SETQ TOPWINDOW (GET-TOPW DISPLAYWINDOW FONT)) (* ;  "RIGHTWINDOW records the ROWPROPS") (SETQ RIGHTWINDOW (GET-RIGHTW DISPLAYWINDOW FONT)) (* ;  "CORNERWINDOW is just a place holder") (SETQ CORNERWINDOW (GET-CORNERW DISPLAYWINDOW FONT)) (* ;  "TITLEWINDOW will only hold a title") (SETQ TITLEWINDOW (GET-TITLEW DISPLAYWINDOW TITLE TITLEFONT DATUM)) (* ; "Put up the window group") [if (NOT (POSITIONP TOPRIGHT)) then (LET ((REGION (if (WINDOWP WHERE) then (WINDOWPROP WHERE 'REGION) elseif (REGIONP WHERE) then WHERE))) (if REGION then (SETQ GLEFT (fetch (REGION LEFT) of REGION)) (SETQ GBOTTOM (fetch (REGION BOTTOM) of REGION)) (SETQ GWIDTH (fetch (REGION WIDTH) of REGION)) (SETQ GHEIGHT (fetch (REGION HEIGHT) of REGION)) elseif (POSITIONP WHERE) then (SETQ GLEFT (fetch (POSITION XCOORD) of WHERE)) (SETQ GBOTTOM (fetch (POSITION YCOORD) of WHERE] (SETQ WINDOWGROUP (TWODINSPECT.ARRANGEWINDOWS DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT TOPRIGHT)) (* ;; " Display the group") (TWODINSPECT.RESHAPEFN DISPLAYWINDOW) (TOPW.RESHAPEFN TOPWINDOW) (RIGHTW.RESHAPEFN RIGHTWINDOW) (TITLEW.REPAINTFN TITLEWINDOW) (* ;; "then establish reshapefns on the windows of the window group") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION TWODINSPECT.RESHAPEFN)) (WINDOWPROP TOPWINDOW 'RESHAPEFN (FUNCTION TOPW.RESHAPEFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION RIGHTW.RESHAPEFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION TITLEW.REPAINTFN))) (* ;; "finally return the group") (RETURN WINDOWGROUP]) (GET-TWOD-DISPLAYW [LAMBDA (WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLECOMMANDFN ROWPROPS COLUMNPROPS PROFILE FONT) (* ; "Edited 6-Apr-87 14:51 by jop") (LET [(DISPLAYWINDOW (if (WINDOWP WHERE) then WHERE else (CREATEW (CREATEREGION 0 0 100 100) NIL 2 T] (WINDOWPROP DISPLAYWINDOW 'REPAINTFN (FUNCTION TWODINSPECT.REPAINTFN)) (* ;  "Smash the reshapefn because we don't want to rely on shapew to repaint the windows") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP DISPLAYWINDOW 'SCROLLFN (FUNCTION TWODINSPECT.SCROLLFN)) (WINDOWPROP DISPLAYWINDOW 'BUTTONEVENTFN (FUNCTION TWODINSPECT.BUTTONEVENTFN)) (WINDOWPROP DISPLAYWINDOW 'COPYBUTTONEVENTFN (FUNCTION TWODINSPECT.COPYBUTTONFN)) (WINDOWPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION TWODINSPECT.CLOSEFN)) (DSPRIGHTMARGIN MAX.SMALLP DISPLAYWINDOW) (DSPFONT FONT DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW 'DATUM DATUM) (WINDOWPROP DISPLAYWINDOW 'FETCHFN FETCHFN) (WINDOWPROP DISPLAYWINDOW 'STOREFN STOREFN) (WINDOWPROP DISPLAYWINDOW 'VALUECOMMANDFN (OR VALUECOMMANDFN (FUNCTION TWODINSPECT.DEFAULT.VALUECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPCOMMANDFN ROWPROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPCOMMANDFN COLUMNPROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'TITLECOMMANDFN (OR TITLECOMMANDFN (FUNCTION TWODINSPECT.DEFAULT.TITLECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPS ROWPROPS) (WINDOWPROP DISPLAYWINDOW 'ROWPROPWIDTH (TWODINSPECT.ROWPROPWIDTH ROWPROPS FONT)) (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPS COLUMNPROPS) (WINDOWPROP DISPLAYWINDOW 'COLUMNWIDTHS (TWODINSPECT.COLUMNWIDTHS DATUM ROWPROPS COLUMNPROPS FETCHFN FONT)) (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'PROFILE PROFILE) DISPLAYWINDOW]) (GET-CORNERW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 6-Apr-87 14:52 by jop") (LET [(CORNERWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'CORNERWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (DSPFONT FONT CORNERWINDOW) (WINDOWPROP CORNERWINDOW 'REPAINTFN (FUNCTION CLEARW)) (WINDOWPROP CORNERWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP CORNERWINDOW 'BUTTONEVENTFN NIL) (WINDOWPROP DISPLAYWINDOW 'CORNERWINDOW CORNERWINDOW) CORNERWINDOW]) (TWODINSPECT.ARRANGEWINDOWS [LAMBDA (DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW TOTALLEFT TOTALBOTTOM TOTALWIDTH TOTALHEIGHT TOPRIGHT) (* ; "Edited 19-Feb-2021 14:29 by rmk:") (* ; "Edited 6-Apr-87 15:10 by jop") (* ;; "REGION should be the total available area") (PROG ((ROWPROPS (WINDOWPROP DISPLAYWINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPS)) (ROWPROPSPACE (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE)) (COLUMNWIDTHS (WINDOWPROP DISPLAYWINDOW 'COLUMNWIDTHS)) (COLUMNPROPSPACE (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPSPACE)) TOTALRIGHT TOTALTOP DWHEIGHT DWWIDTH TITLEHEIGHT TWHEIGHT RWWIDTH DWLEFT DWBOTTOM ROWPROPWIDTH) [SETQ TITLEHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEWINDOW 'HEIGHT) NIL (WINDOWPROP TITLEWINDOW 'BORDER] (SETQ ROWPROPWIDTH (TWODINSPECT.ROWPROPWIDTH ROWPROPS RIGHTWINDOW)) [SETQ TWHEIGHT (HEIGHTIFWINDOW (FONTPROP TOPWINDOW 'HEIGHT) NIL (WINDOWPROP TOPWINDOW 'BORDER] [SETQ RWWIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH ROWPROPSPACE RIGHTWINDOW) ROWPROPWIDTH) (WINDOWPROP RIGHTWINDOW 'BORDER] [if (NULL TOTALHEIGHT) then [SETQ DWHEIGHT (IMIN 500 (HEIGHTIFWINDOW (ITIMES (FONTPROP DISPLAYWINDOW 'HEIGHT) (LENGTH ROWPROPS)) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER] (SETQ TOTALHEIGHT (IPLUS TITLEHEIGHT TWHEIGHT DWHEIGHT)) else (SETQ DWHEIGHT (IDIFFERENCE TOTALHEIGHT (IPLUS TWHEIGHT TITLEHEIGHT] (if (NULL TOTALWIDTH) then [SETQ DWWIDTH (IMIN 400 (WIDTHIFWINDOW (TWODINSPECT.TOTALWIDTH COLUMNWIDTHS COLUMNPROPSPACE (DSPFONT DISPLAYWINDOW)) (WINDOWPROP DISPLAYWINDOW 'BORDER] (SETQ TOTALWIDTH (IPLUS RWWIDTH DWWIDTH)) else (SETQ DWWIDTH (IDIFFERENCE TOTALWIDTH RWWIDTH))) [if (POSITIONP TOPRIGHT) then (SETQ TOTALRIGHT (fetch (POSITION XCOORD) of TOPRIGHT)) (SETQ TOTALTOP (fetch (POSITION YCOORD) of TOPRIGHT)) elseif (AND TOTALLEFT TOTALBOTTOM) then (SETQ TOTALRIGHT (IPLUS TOTALLEFT (SUB1 TOTALWIDTH))) (SETQ TOTALTOP (IPLUS TOTALBOTTOM (SUB1 TOTALHEIGHT))) else (LET ((REGION (GETBOXREGION TOTALWIDTH TOTALHEIGHT NIL NIL NIL "Position Inspector window"))) (SETQ TOTALTOP (fetch (REGION TOP) of REGION)) (SETQ TOTALRIGHT (fetch (REGION RIGHT) of REGION] [SETQ DWLEFT (DIFFERENCE TOTALRIGHT (SUB1 (PLUS DWWIDTH RWWIDTH] (if (ILESSP DWLEFT 0) then (SETQ DWLEFT 0) (SETQ DWWIDTH (DIFFERENCE (ADD1 TOTALRIGHT) RWWIDTH))) [SETQ DWBOTTOM (DIFFERENCE TOTALTOP (SUB1 (PLUS DWHEIGHT TWHEIGHT TITLEHEIGHT] [if (LESSP DWBOTTOM 0) then (SETQ DWBOTTOM 0) (SETQ DWHEIGHT (DIFFERENCE (ADD1 TOTALTOP) (PLUS TWHEIGHT TITLEHEIGHT] (* ;; "put up the window group") (WINDOWPROP DISPLAYWINDOW 'MINSIZE (CONS 0 0)) (SHAPEW DISPLAYWINDOW (CREATEREGION DWLEFT DWBOTTOM DWWIDTH DWHEIGHT)) (* ;  "Need to set the Minsize BEFORE reshaping else we catch the default minsize") (WINDOWPROP TOPWINDOW 'MINSIZE (CONS 0 TWHEIGHT)) (WINDOWPROP TOPWINDOW 'MAXSIZE (CONS MAX.SMALLP TWHEIGHT)) (SHAPEW TOPWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) of (WINDOWPROP DISPLAYWINDOW 'REGION] DWWIDTH TWHEIGHT)) (ATTACHWINDOW TOPWINDOW DISPLAYWINDOW 'TOP) (WINDOWPROP RIGHTWINDOW 'MINSIZE (CONS RWWIDTH 0)) (WINDOWPROP RIGHTWINDOW 'MAXSIZE (CONS RWWIDTH MAX.SMALLP)) (WINDOWPROP RIGHTWINDOW 'ROWPROPWIDTH ROWPROPWIDTH) (SHAPEW RIGHTWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) of (WINDOWPROP DISPLAYWINDOW 'REGION] DWBOTTOM RWWIDTH DWHEIGHT)) (WINDOWPROP CORNERWINDOW 'MINSIZE (CONS RWWIDTH TWHEIGHT)) (WINDOWPROP CORNERWINDOW 'MAXSIZE (CONS RWWIDTH TWHEIGHT)) (SHAPEW CORNERWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) of (WINDOWPROP DISPLAYWINDOW 'REGION] [ADD1 (fetch (REGION TOP) of (WINDOWPROP DISPLAYWINDOW 'REGION] RWWIDTH TWHEIGHT)) (ATTACHWINDOW CORNERWINDOW RIGHTWINDOW 'TOP) (ATTACHWINDOW RIGHTWINDOW DISPLAYWINDOW 'RIGHT) (WINDOWPROP TITLEWINDOW 'MINSIZE (CONS 0 TITLEHEIGHT)) (WINDOWPROP TITLEWINDOW 'MAXSIZE (CONS MAX.SMALLP TITLEHEIGHT)) (SHAPEW TITLEWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) (WINDOWPROP TOPWINDOW 'REGION] TOTALWIDTH TITLEHEIGHT)) (ATTACHWINDOW TITLEWINDOW DISPLAYWINDOW 'TOP) (RETURN DISPLAYWINDOW]) (TWODINSPECT.REPAINTFN [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 6-Apr-87 11:12 by jop") (if (NULL WINDOWREGION) then (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW))) @@ -178,7 +88,7 @@ COLUMNPROP )) HMARK VMARK FDESCENT WINDOW] - (INSPECT.INVERTSELECTION WINDOW]) (TWODINSPECT.PRINTELEMENT [LAMBDA (ELT RIGHT BOTTOM FDESCENT WINDOW) (* ; "Edited 5-Apr-87 15:17 by jop") (MOVETO (ADD1 (DIFFERENCE RIGHT (STRINGWIDTH ELT WINDOW T))) (IPLUS BOTTOM FDESCENT) WINDOW) (PRIN2 ELT WINDOW]) (TWODINSPECT.RESHAPEFN [LAMBDA (WINDOW) (* jop%: " 6-Oct-85 18:33") (CLEARW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (TWODINSPECT.MAKEREGIONS WINDOW) (TWODINSPECT.ADJUSTSELECTION WINDOW) (TWODINSPECT.REPAINTFN WINDOW]) (TWODINSPECT.MAKEREGIONS [LAMBDA (WINDOW) (* ; "Edited 5-Apr-87 16:31 by jop") (* ;; "Sets up windowprops and activeregions") (PROG ((ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (COLUMNWIDTHS (WINDOWPROP WINDOW 'COLUMNWIDTHS)) (SPACE (STRINGWIDTH (WINDOWPROP WINDOW 'COLUMNPROPSPACE) WINDOW)) (WINDOWHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (LF (DSPLINEFEED NIL WINDOW)) VERTMARKS HORZMARKS) (if (NULL COLUMNWIDTHS) then (SETQ COLUMNWIDTHS (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TWODINSPECT.COLUMNWIDTHS (WINDOWPROP WINDOW 'DATUM) ROWPROPS COLUMNPROPS (WINDOWPROP WINDOW 'FETCHFN) WINDOW))) (WINDOWPROP WINDOW 'COLUMNWIDTHS COLUMNWIDTHS)) (* ;  "VERTMARKS and HORZMARKS mark endpoints") (SETQ VERTMARKS (for I from 1 to (LENGTH ROWPROPS) as MARK from (IPLUS WINDOWHEIGHT LF) by LF collect MARK)) [SETQ HORZMARKS (bind (MARK _ -1) for I from 1 to (LENGTH COLUMNPROPS) as COLUMNWIDTH in COLUMNWIDTHS collect (SETQ MARK (IPLUS MARK SPACE COLUMNWIDTH] (WINDOWPROP WINDOW 'VERTMARKS VERTMARKS) (WINDOWPROP WINDOW 'HORZMARKS HORZMARKS) [WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (CAR (LAST HORZMARKS)) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS] [WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'EXTENT (CREATEREGION 0 0 (CAR (LAST HORZMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'HEIGHT] (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'WIDTH) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS]) (TWODINSPECT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:28 by jop") (TOTOPW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (TWOD.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) (WINDOWPROP WINDOW 'COLUMNPROPS) (WINDOWPROP WINDOW 'HORZMARKS) (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (RP CP W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) RP CP] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (LET [(DATUM (WINDOWPROP WINDOW 'DATUM)) (SELECTEDROWPROP (CAR (fetch (TWOD.SELECTION ROWPROP) of SELECTION))) (SELECTEDCOLUMNPROP (CAR (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION] (CL:FUNCALL (WINDOWPROP WINDOW 'VALUECOMMANDFN) (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) DATUM SELECTEDROWPROP SELECTEDCOLUMNPROP) SELECTEDROWPROP SELECTEDCOLUMNPROP DATUM WINDOW]) (TWODINSPECT.COPYBUTTONFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:32 by jop") (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TOTOPW WINDOW) (bind SELECTION while (.COPYKEYDOWNP.) do (BLOCK) (SETQ SELECTION (TWOD.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) (WINDOWPROP WINDOW 'COLUMNPROPS) (WINDOWPROP WINDOW 'HORZMARKS) 2 [FUNCTION (LAMBDA (RP CP W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) RP CP] (FUNCTION INSPECT.FLIPSELECTION))) finally (if SELECTION then (INSPECT.FLIPSELECTION (fetch (TWOD.SELECTION ELTLEFT) of SELECTION) (fetch (TWOD.SELECTION ELTBOTTOM) of SELECTION) (fetch (TWOD.SELECTION ELTWIDTH) of SELECTION) 2 WINDOW) (BKSYSBUF.GENERAL (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) (CAR (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (CAR (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION]) (TWODINSPECT.DOWINDOWCOMFN [LAMBDA (TWODWINDOW) (* ; "Edited 6-Apr-87 12:05 by jop") (* ;; "Pass on the usual comms, except for SHAPEW") (PROG (COM) (SETQ COM (MENU WindowMenu)) (SELECTQ COM (NIL NIL) (SHAPEW [SHAPEW TWODWINDOW (GETREGION NIL NIL NIL (FUNCTION ICMLARRAY.GETREGIONFN) (CONS TWODWINDOW 'CLOSED]) ((MOVEW CLOSEW SHRINKW BURYW) (APPLY* COM (MAINWINDOW TWODWINDOW))) (APPLY* COM TWODWINDOW]) (TWODINSPECT.SCROLLFN [LAMBDA (WINDOW DX DY FLG) (* jop%: "18-Jul-85 13:50") (PROG [(TOPWINDOW (WINDOWPROP WINDOW 'TOPWINDOW)) (RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (OR (NOT (EQP 0 DX)) (FLOATP DX)) then (APPLY* (WINDOWPROP TOPWINDOW 'SCROLLFN) TOPWINDOW DX 0 FLG)) (if (OR (NOT (EQP 0 DY)) (FLOATP DY)) then (APPLY* (WINDOWPROP RIGHTWINDOW 'SCROLLFN) RIGHTWINDOW 0 DY FLG)) (SCROLLBYREPAINTFN WINDOW DX DY FLG]) (TWODINSPECT.CLOSEFN [LAMBDA (WINDOW) (* jop%: " 4-Oct-85 17:51") (DETACHALLWINDOWS (WINDOWPROP WINDOW 'RIGHTWINDOW)) (DETACHALLWINDOWS WINDOW) (WINDOWPROP WINDOW 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'SELECTION NIL]) (TWODINSPECT.REDISPLAY [LAMBDA (WINDOW ELTROWPROPS ELTCOLUMNPROPS) (* ; "Edited 8-Apr-87 17:00 by jop") (* ;; "ELTROWPROPS and ELTCOLUMNPROPS may be single entries, lists, or NIL. If NIL than the whole inspector is refetched and redisplayed") (if (AND ELTROWPROPS (NLISTP ELTROWPROPS)) then (SETQ ELTROWPROPS (LIST ELTROWPROPS))) (if (AND ELTCOLUMNPROPS (NLISTP ELTCOLUMNPROPS)) then (SETQ ELTCOLUMNPROPS (LIST ELTCOLUMNPROPS))) (PROG ((FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (DATUM (WINDOWPROP WINDOW 'DATUM)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (COLUMNWIDTHS (WINDOWPROP WINDOW 'COLUMNWIDTHS)) (SELECTION (WINDOWPROP WINDOW 'SELECTION)) ELTCOLUMNWIDTHS ELTS ELTRIGHTS ELTBOTTOMS) [SETQ ELTS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (APPLY* FETCHFN DATUM RPROP CPROP] [SETQ ELTCOLUMNWIDTHS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for COLWIDTH in COLUMNWIDTHS as COLPROP in COLUMNPROPS thereis (EQUAL COLPROP CPROP] [SETQ ELTRIGHTS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for HMARK in HORZMARKS as COLPROP in COLUMNPROPS thereis (EQUAL COLPROP CPROP] [SETQ ELTBOTTOMS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for VMARK in VERTMARKS as ROWPROP in ROWPROPS thereis (EQUAL ROWPROP RPROP] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (AND ELTS (for ELT in ELTS as COLUMNWIDTH in ELTCOLUMNWIDTHS never (IGREATERP (STRINGWIDTH ELT WINDOW T) COLUMNWIDTH))) then (INSPECT.INVERTSELECTION WINDOW) (bind (FHEIGHT _ (FONTPROP WINDOW 'HEIGHT)) (FDESCENT _ (FONTPROP WINDOW 'DESCENT)) for ELT in ELTS as RIGHT in ELTRIGHTS as BOTTOM in ELTBOTTOMS as COLUMNWIDTH in ELTCOLUMNWIDTHS do (BITBLT NIL NIL NIL WINDOW (IDIFFERENCE (ADD1 RIGHT) COLUMNWIDTH) BOTTOM COLUMNWIDTH FHEIGHT 'TEXTURE 'REPLACE WHITESHADE) (TWODINSPECT.PRINTELEMENT ELT RIGHT BOTTOM FDESCENT WINDOW)) (TWODINSPECT.ADJUSTSELECTION WINDOW) (INSPECT.INVERTSELECTION WINDOW) else (* ; "Recompute the whole picture") (WINDOWPROP WINDOW 'COLUMNWIDTHS NIL) (TWODINSPECT.MAKEREGIONS WINDOW) (TWODINSPECT.ADJUSTSELECTION WINDOW) (DSPRESET WINDOW) (TWODINSPECT.REPAINTFN WINDOW) (DSPRESET (WINDOWPROP WINDOW 'TOPWINDOW)) (TOPW.REPAINTFN (WINDOWPROP WINDOW 'TOPWINDOW)) (DSPRESET (WINDOWPROP WINDOW 'RIGHTWINDOW)) (RIGHTW.REPAINTFN (WINDOWPROP WINDOW 'RIGHTWINDOW]) (TWODINSPECT.REPLACE [LAMBDA (WINDOW ROWPROP COLUMNPROP NEWVALUE) (* jop%: "30-Sep-85 20:44") (PROG [(DATUM (WINDOWPROP WINDOW 'DATUM)) (STOREFN (WINDOWPROP WINDOW 'STOREFN] (APPLY* STOREFN NEWVALUE DATUM ROWPROP COLUMNPROP) (TWODINSPECT.REDISPLAY WINDOW ROWPROP COLUMNPROP]) (TWODINSPECT.SELECTITEM [LAMBDA (WINDOW ROWPROP COLUMNPROP) (* ; "Edited 6-Apr-87 12:05 by jop") (if (WINDOWPROP WINDOW 'SELECTION) then (INSPECT.INVERTSELECTION WINDOW)) (if (AND ROWPROP COLUMNPROP) then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDROWPROP SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDROWPROP (for RPROP on ROWPROPS thereis (EQUAL (CAR RPROP) ROWPROP))) (SETQ SELECTEDCOLUMNPROP (for CPROP on COLUMNPROPS thereis (EQUAL (CAR CPROP) COLUMNPROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as RPROP on ROWPROPS thereis (EQ RPROP SELECTEDROWPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM ROWPROP COLUMNPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as CPROP on COLUMNPROPS thereis (EQ CPROP SELECTEDCOLUMNPROP))) SELECTEDELTWIDTH)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) WINDOW) (WINDOWPROP WINDOW 'SELECTION (create TWOD.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM ROWPROP _ SELECTEDROWPROP COLUMNPROP _ SELECTEDCOLUMNPROP]) (TWODINSPECT.SELECTROWPROP [LAMBDA (WINDOW ROWPROP) (* ; "Edited 6-Apr-87 12:07 by jop") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (WINDOWPROP RIGHTWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION RIGHTWINDOW)) (PROG ((ROWPROPSPACE (WINDOWPROP WINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) SELECTEDROWPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDROWPROP (for RPROP on ROWPROPS thereis (EQUAL (CAR RPROP) ROWPROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as RPROP on ROWPROPS thereis (EQ RPROP SELECTEDROWPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDROWPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) RIGHTWINDOW) (WINDOWPROP RIGHTWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDROWPROP]) (TWODINSPECT.SELECTCOLUMNPROP [LAMBDA (WINDOW COLUMNPROP) (* ; "Edited 6-Apr-87 12:08 by jop") (PROG [(TOPWINDOW (WINDOWPROP WINDOW 'TOPWINDOW] (if (WINDOWPROP TOPWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION TOPWINDOW)) (PROG ((COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDCOLUMNPROP (for CPROP on COLUMNPROPS thereis (EQUAL (CAR CPROP) COLUMNPROP))) (SETQ SELECTEDELTBOTTOM 0) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDCOLUMNPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as CPROP on COLUMNPROPS thereis (EQ CPROP SELECTEDCOLUMNPROP) )) SELECTEDELTWIDTH)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) TOPWINDOW) (WINDOWPROP TOPWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDCOLUMNPROP]) (TWODINSPECT.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 12:06 by jop") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) (SELROWPROP (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (SELCOLPROP (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM (for VMARK in VERTMARKS as ROWPROP on ROWPROPS thereis (EQ ROWPROP SELROWPROP))) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM (CAR SELROWPROP ) (CAR SELCOLPROP)) WINDOW T))) (SETQ SELLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as COLPROP on COLUMNPROPS thereis (EQ COLPROP SELCOLPROP))) SELWIDTH)) (WINDOWPROP WINDOW 'SELECTION (create TWOD.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT ROWPROP _ SELROWPROP COLUMNPROP _ SELCOLPROP]) (TWODINSPECT.DEFAULT.TITLECOMMANDFN [LAMBDA (WINDOW) (* ; "Edited 20-Jul-90 20:54 by yabu") (if (MOUSESTATE MIDDLE) then (PROG [(TITLEMENU (CONSTANT (\CREATE.TWODINSPECTOR.TITLEMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Refetch%" 'REFETCH %"Refetch the datum%") (%"IT _ Datum%" 'IT %"Bind IT to the inspected datum%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (DATUM (WINDOWPROP WINDOW 'DATUM] (SELECTQ (MENU TITLEMENU) (REFETCH (TWODINSPECT.REDISPLAY WINDOW)) (IT (SETQ IT DATUM) (PROMPTPRINT "IT bound to " DATUM)) NIL]) (TWODINSPECT.DEFAULT.VALUECOMMANDFN [LAMBDA (VALUE ROWPROP COLUMNPROP DATUM WINDOW) (* ; "Edited 20-Jul-90 21:03 by yabu") (PROG ((SETMENU (CONSTANT (\CREATE.TWODINSPECTOR.SETMENU))) (* ; "Original was (create MENU ITEMS _ '((%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (INSPECTMENU (CONSTANT (\CREATE.TWODINSPECTOR.INSPECTMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Inspect%" 'INSPECT %"Inspect the value of the selected entry%") (%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  " Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (SELECTQ (if (OR (NULL VALUE) (NUMBERP VALUE)) then (MENU SETMENU) else (MENU INSPECTMENU)) (INSPECT (INSPECT VALUE)) (IT (SETQ IT VALUE) (PROMPTPRINT "IT bound to " IT)) (SET (TWODINSPECT.SETELT ROWPROP COLUMNPROP WINDOW)) NIL]) (TWODINSPECT.SETELT [LAMBDA (ROWPROP COLUMNPROP WINDOW) (* ; "Edited 5-Apr-87 16:41 by jop") (PROG ((PRTWINDOW (GETPROMPTWINDOW WINDOW)) (NEWVALUE (APPLY* (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) ROWPROP COLUMNPROP))) (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM PRTWINDOW)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (CLEARBUF T T) (printout T "Eval> ") (SETQ NEWVALUE (CL:FUNCALL XCL:*EVAL-FUNCTION* (LISPXREAD T T))) (* ;  "clear tty buffer because it sometimes has stuff left.") (CLEARBUF T T))) (REMOVEPROMPTWINDOW WINDOW) (TWODINSPECT.REPLACE WINDOW ROWPROP COLUMNPROP NEWVALUE]) (TWODINSPECT.ROWPROPWIDTH [LAMBDA (ROWPROPS FONT) (* ; "Edited 5-Apr-87 16:33 by jop") (for ROWPROP in ROWPROPS largest (STRINGWIDTH ROWPROP FONT T) finally (RETURN $$EXTREME]) (TWODINSPECT.COLUMNWIDTHS [LAMBDA (DATUM ROWPROPS COLUMNPROPS FETCHFN FONT) (* ; "Edited 5-Apr-87 15:38 by jop") (* ;; "Computes the MIN fieldwidth for the jth column of SLICE") (for COLUMNPROP in COLUMNPROPS collect (TWODINSPECT.COLUMNWIDTH DATUM ROWPROPS COLUMNPROP FETCHFN FONT]) (TWODINSPECT.COLUMNWIDTH [LAMBDA (DATUM ROWPROPS COLUMNPROP FETCHFN FONT) (* ; "Edited 5-Apr-87 16:29 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (IMAX (STRINGWIDTH COLUMNPROP FONT T) (for ROWPROP in ROWPROPS largest (STRINGWIDTH (APPLY* FETCHFN DATUM ROWPROP COLUMNPROP) FONT T) finally (RETURN $$EXTREME]) (TWODINSPECT.TOTALWIDTH [LAMBDA (COLUMNWIDTHS SPACE FONT) (* jop%: "25-Sep-85 13:21") (IPLUS (ITIMES (LENGTH COLUMNWIDTHS) (STRINGWIDTH SPACE FONT)) (for COLUMN in COLUMNWIDTHS sum COLUMN]) ) (* ;; "Right window fns") (DEFINEQ (GET-RIGHTW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 6-Apr-87 12:14 by jop") (LET [(RIGHTWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'RIGHTWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (WINDOWPROP RIGHTWINDOW 'REPAINTFN (FUNCTION RIGHTW.REPAINTFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP RIGHTWINDOW 'BUTTONEVENTFN (FUNCTION RIGHTW.BUTTONEVENTFN)) (WINDOWPROP RIGHTWINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (WINDOWPROP RIGHTWINDOW 'NOSCROLLBARS T) (DSPFONT FONT RIGHTWINDOW) (WINDOWPROP DISPLAYWINDOW 'RIGHTWINDOW RIGHTWINDOW) RIGHTWINDOW]) (RIGHTW.REPAINTFN [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 11-Aug-2020 11:20 by rmk:") (* ; "Edited 22-May-92 17:37 by jds") (* ;; "RMK: Right justify the PROP in its window (assuming its a numeric index)") (* ;;  "REPAINT the right-hand window of a two-d inspector. This window contains the element indices.") [COND ((NULL WINDOWREGION) (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW] (LET [(DISPLAYW (MAINWINDOW WINDOW)) (TOP (fetch (REGION TOP) of WINDOWREGION)) (BOTTOM (fetch (REGION BOTTOM) of WINDOWREGION)) (ROWPROPWIDTH (WINDOWPROP WINDOW 'ROWPROPWIDTH] (LET ((VERTMARKS (WINDOWPROP DISPLAYW 'VERTMARKS)) (ROWPROPS (WINDOWPROP DISPLAYW 'ROWPROPS)) (SPACE (STRINGWIDTH (WINDOWPROP DISPLAYW 'ROWPROPSPACE) WINDOW)) STARTROWPROPS LASTROWPROP STARTVERTMARKS) (for ROWPROP on ROWPROPS as MARK on VERTMARKS until (ILESSP (CAR MARK) TOP) finally (SETQ STARTROWPROPS ROWPROP) (SETQ STARTVERTMARKS MARK)) (for ROWPROP on STARTROWPROPS as MARK in STARTVERTMARKS until (ILESSP MARK BOTTOM) finally (SETQ LASTROWPROP ROWPROP)) [COND (STARTROWPROPS (WITH-INSPECTOR-ENV (WINDOWPROP DISPLAYW 'PROFILE) (bind [FDESCENT _ (SUB1 (FONTPROP WINDOW 'DESCENT] for ROWPROP on STARTROWPROPS as VERTMARK in STARTVERTMARKS repeatuntil (EQ ROWPROP LASTROWPROP) do (MOVETO (- ROWPROPWIDTH (STRINGWIDTH (CAR ROWPROP) WINDOW)) (IPLUS VERTMARK FDESCENT) WINDOW) (PRIN2 (CAR ROWPROP) WINDOW] (INSPECT.INVERTSELECTION WINDOW]) (RIGHTW.RESHAPEFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 10:37 by jop") (CLEARW WINDOW) (RIGHTW.ADJUSTSELECTION WINDOW) (RIGHTW.REPAINTFN WINDOW]) (RIGHTW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:48 by jop") (TOTOPW WINDOW) (LET* [(SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW)) (ROWPROPCOMMANDFN (WINDOWPROP MAINWINDOW 'ROWPROPCOMMANDFN] (if ROWPROPCOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP MAINWINDOW 'ROWPROPS) (WINDOWPROP MAINWINDOW 'VERTMARKS) (STRINGWIDTH (WINDOWPROP MAINWINDOW 'ROWPROPSPACE) WINDOW) NIL (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) P] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (CL:FUNCALL ROWPROPCOMMANDFN (CAR (fetch (ONED.SELECTION PROP) of SELECTION )) (WINDOWPROP MAINWINDOW 'DATUM) MAINWINDOW]) (RIGHTW.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 10:31 by jop") (PROG ((SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW))) (if SELECTION then (PROG ((ROWPROPSPACE (WINDOWPROP MAINWINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP MAINWINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP MAINWINDOW 'VERTMARKS)) (SELROWPROP (fetch (ONED.SELECTION PROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM (for VMARK in VERTMARKS as ROWPROP on ROWPROPS thereis (EQ ROWPROP SELROWPROP))) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (STRINGWIDTH (CAR SELROWPROP) WINDOW T))) (SETQ SELLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT PROP _ SELROWPROP smashing SELECTION]) ) (* ;; "Top window fns") (DEFINEQ (GET-TOPW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 6-Apr-87 14:43 by jop") (LET [(TOPWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'TOPWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (WINDOWPROP TOPWINDOW 'REPAINTFN (FUNCTION TOPW.REPAINTFN)) (WINDOWPROP TOPWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP TOPWINDOW 'BUTTONEVENTFN (FUNCTION TOPW.BUTTONEVENTFN)) (WINDOWPROP TOPWINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (DSPRIGHTMARGIN MAX.SMALLP TOPWINDOW) (* ;  "TOPWINDOW will scroll under program control") (WINDOWPROP TOPWINDOW 'NOSCROLLBARS T) (DSPFONT FONT TOPWINDOW) (WINDOWPROP DISPLAYWINDOW 'TOPWINDOW TOPWINDOW) TOPWINDOW]) (TOPW.REPAINTFN + (INSPECT.INVERTSELECTION WINDOW]) (TWODINSPECT.PRINTELEMENT [LAMBDA (ELT RIGHT BOTTOM FDESCENT WINDOW) (* ; "Edited 5-Apr-87 15:17 by jop") (MOVETO (ADD1 (DIFFERENCE RIGHT (STRINGWIDTH ELT WINDOW T))) (IPLUS BOTTOM FDESCENT) WINDOW) (PRIN2 ELT WINDOW]) (TWODINSPECT.RESHAPEFN [LAMBDA (WINDOW) (* jop%: " 6-Oct-85 18:33") (CLEARW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (TWODINSPECT.MAKEREGIONS WINDOW) (TWODINSPECT.ADJUSTSELECTION WINDOW) (TWODINSPECT.REPAINTFN WINDOW]) (TWODINSPECT.MAKEREGIONS [LAMBDA (WINDOW) (* ; "Edited 5-Apr-87 16:31 by jop") (* ;; "Sets up windowprops and activeregions") (PROG ((ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (COLUMNWIDTHS (WINDOWPROP WINDOW 'COLUMNWIDTHS)) (SPACE (STRINGWIDTH (WINDOWPROP WINDOW 'COLUMNPROPSPACE) WINDOW)) (WINDOWHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (LF (DSPLINEFEED NIL WINDOW)) VERTMARKS HORZMARKS) (if (NULL COLUMNWIDTHS) then (SETQ COLUMNWIDTHS (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TWODINSPECT.COLUMNWIDTHS (WINDOWPROP WINDOW 'DATUM) ROWPROPS COLUMNPROPS (WINDOWPROP WINDOW 'FETCHFN) WINDOW))) (WINDOWPROP WINDOW 'COLUMNWIDTHS COLUMNWIDTHS)) (* ;  "VERTMARKS and HORZMARKS mark endpoints") (SETQ VERTMARKS (for I from 1 to (LENGTH ROWPROPS) as MARK from (IPLUS WINDOWHEIGHT LF) by LF collect MARK)) [SETQ HORZMARKS (bind (MARK _ -1) for I from 1 to (LENGTH COLUMNPROPS) as COLUMNWIDTH in COLUMNWIDTHS collect (SETQ MARK (IPLUS MARK SPACE COLUMNWIDTH] (WINDOWPROP WINDOW 'VERTMARKS VERTMARKS) (WINDOWPROP WINDOW 'HORZMARKS HORZMARKS) [WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (CAR (LAST HORZMARKS)) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS] [WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'EXTENT (CREATEREGION 0 0 (CAR (LAST HORZMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'HEIGHT] (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'WIDTH) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS]) (TWODINSPECT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:28 by jop") (TOTOPW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (TWOD.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) (WINDOWPROP WINDOW 'COLUMNPROPS) (WINDOWPROP WINDOW 'HORZMARKS) (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (RP CP W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) RP CP] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (LET [(DATUM (WINDOWPROP WINDOW 'DATUM)) (SELECTEDROWPROP (CAR (fetch (TWOD.SELECTION ROWPROP) of SELECTION))) (SELECTEDCOLUMNPROP (CAR (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION] (CL:FUNCALL (WINDOWPROP WINDOW 'VALUECOMMANDFN) (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) DATUM SELECTEDROWPROP SELECTEDCOLUMNPROP) SELECTEDROWPROP SELECTEDCOLUMNPROP DATUM WINDOW]) (TWODINSPECT.COPYBUTTONFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:32 by jop") (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TOTOPW WINDOW) (bind SELECTION while (.COPYKEYDOWNP.) do (BLOCK) (SETQ SELECTION (TWOD.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) (WINDOWPROP WINDOW 'COLUMNPROPS) (WINDOWPROP WINDOW 'HORZMARKS) 2 [FUNCTION (LAMBDA (RP CP W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) RP CP] (FUNCTION INSPECT.FLIPSELECTION))) finally (if SELECTION then (INSPECT.FLIPSELECTION (fetch (TWOD.SELECTION ELTLEFT) of SELECTION) (fetch (TWOD.SELECTION ELTBOTTOM) of SELECTION) (fetch (TWOD.SELECTION ELTWIDTH) of SELECTION) 2 WINDOW) (BKSYSBUF.GENERAL (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) (CAR (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (CAR (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION]) (TWODINSPECT.DOWINDOWCOMFN [LAMBDA (TWODWINDOW) (* ; "Edited 6-Apr-87 12:05 by jop") (* ;; "Pass on the usual comms, except for SHAPEW") (PROG (COM) (SETQ COM (MENU WindowMenu)) (SELECTQ COM (NIL NIL) (SHAPEW [SHAPEW TWODWINDOW (GETREGION NIL NIL NIL (FUNCTION ICMLARRAY.GETREGIONFN) (CONS TWODWINDOW 'CLOSED]) ((MOVEW CLOSEW SHRINKW BURYW) (APPLY* COM (MAINWINDOW TWODWINDOW))) (APPLY* COM TWODWINDOW]) (TWODINSPECT.SCROLLFN [LAMBDA (WINDOW DX DY FLG) (* ; "Edited 19-Feb-2021 13:38 by rmk:") (* jop%: "18-Jul-85 13:50") (PROG [(TOPWINDOW (WINDOWPROP WINDOW 'TOPWINDOW)) (RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (OR (NOT (EQP 0 DX)) (FLOATP DX)) then (APPLY* (WINDOWPROP TOPWINDOW 'SCROLLFN) TOPWINDOW DX 0 FLG)) (if (OR (NOT (EQP 0 DY)) (FLOATP DY)) then (APPLY* (OR (WINDOWPROP RIGHTWINDOW 'SCROLLFN) (FUNCTION SCROLLBYREPAINTFN)) RIGHTWINDOW 0 DY FLG)) (SCROLLBYREPAINTFN WINDOW DX DY FLG]) (TWODINSPECT.CLOSEFN [LAMBDA (WINDOW) (* jop%: " 4-Oct-85 17:51") (DETACHALLWINDOWS (WINDOWPROP WINDOW 'RIGHTWINDOW)) (DETACHALLWINDOWS WINDOW) (WINDOWPROP WINDOW 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'SELECTION NIL]) (TWODINSPECT.REDISPLAY [LAMBDA (WINDOW ELTROWPROPS ELTCOLUMNPROPS) (* ; "Edited 8-Apr-87 17:00 by jop") (* ;; "ELTROWPROPS and ELTCOLUMNPROPS may be single entries, lists, or NIL. If NIL than the whole inspector is refetched and redisplayed") (if (AND ELTROWPROPS (NLISTP ELTROWPROPS)) then (SETQ ELTROWPROPS (LIST ELTROWPROPS))) (if (AND ELTCOLUMNPROPS (NLISTP ELTCOLUMNPROPS)) then (SETQ ELTCOLUMNPROPS (LIST ELTCOLUMNPROPS))) (PROG ((FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (DATUM (WINDOWPROP WINDOW 'DATUM)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (COLUMNWIDTHS (WINDOWPROP WINDOW 'COLUMNWIDTHS)) (SELECTION (WINDOWPROP WINDOW 'SELECTION)) ELTCOLUMNWIDTHS ELTS ELTRIGHTS ELTBOTTOMS) [SETQ ELTS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (APPLY* FETCHFN DATUM RPROP CPROP] [SETQ ELTCOLUMNWIDTHS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for COLWIDTH in COLUMNWIDTHS as COLPROP in COLUMNPROPS thereis (EQUAL COLPROP CPROP] [SETQ ELTRIGHTS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for HMARK in HORZMARKS as COLPROP in COLUMNPROPS thereis (EQUAL COLPROP CPROP] [SETQ ELTBOTTOMS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for VMARK in VERTMARKS as ROWPROP in ROWPROPS thereis (EQUAL ROWPROP RPROP] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (AND ELTS (for ELT in ELTS as COLUMNWIDTH in ELTCOLUMNWIDTHS never (IGREATERP (STRINGWIDTH ELT WINDOW T) COLUMNWIDTH))) then (INSPECT.INVERTSELECTION WINDOW) (bind (FHEIGHT _ (FONTPROP WINDOW 'HEIGHT)) (FDESCENT _ (FONTPROP WINDOW 'DESCENT)) for ELT in ELTS as RIGHT in ELTRIGHTS as BOTTOM in ELTBOTTOMS as COLUMNWIDTH in ELTCOLUMNWIDTHS do (BITBLT NIL NIL NIL WINDOW (IDIFFERENCE (ADD1 RIGHT) COLUMNWIDTH) BOTTOM COLUMNWIDTH FHEIGHT 'TEXTURE 'REPLACE WHITESHADE) (TWODINSPECT.PRINTELEMENT ELT RIGHT BOTTOM FDESCENT WINDOW)) (TWODINSPECT.ADJUSTSELECTION WINDOW) (INSPECT.INVERTSELECTION WINDOW) else (* ; "Recompute the whole picture") (WINDOWPROP WINDOW 'COLUMNWIDTHS NIL) (TWODINSPECT.MAKEREGIONS WINDOW) (TWODINSPECT.ADJUSTSELECTION WINDOW) (DSPRESET WINDOW) (TWODINSPECT.REPAINTFN WINDOW) (DSPRESET (WINDOWPROP WINDOW 'TOPWINDOW)) (TOPW.REPAINTFN (WINDOWPROP WINDOW 'TOPWINDOW)) (DSPRESET (WINDOWPROP WINDOW 'RIGHTWINDOW)) (RIGHTW.REPAINTFN (WINDOWPROP WINDOW 'RIGHTWINDOW]) (TWODINSPECT.REPLACE [LAMBDA (WINDOW ROWPROP COLUMNPROP NEWVALUE) (* jop%: "30-Sep-85 20:44") (PROG [(DATUM (WINDOWPROP WINDOW 'DATUM)) (STOREFN (WINDOWPROP WINDOW 'STOREFN] (APPLY* STOREFN NEWVALUE DATUM ROWPROP COLUMNPROP) (TWODINSPECT.REDISPLAY WINDOW ROWPROP COLUMNPROP]) (TWODINSPECT.SELECTITEM [LAMBDA (WINDOW ROWPROP COLUMNPROP) (* ; "Edited 6-Apr-87 12:05 by jop") (if (WINDOWPROP WINDOW 'SELECTION) then (INSPECT.INVERTSELECTION WINDOW)) (if (AND ROWPROP COLUMNPROP) then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDROWPROP SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDROWPROP (for RPROP on ROWPROPS thereis (EQUAL (CAR RPROP) ROWPROP))) (SETQ SELECTEDCOLUMNPROP (for CPROP on COLUMNPROPS thereis (EQUAL (CAR CPROP) COLUMNPROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as RPROP on ROWPROPS thereis (EQ RPROP SELECTEDROWPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM ROWPROP COLUMNPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as CPROP on COLUMNPROPS thereis (EQ CPROP SELECTEDCOLUMNPROP))) SELECTEDELTWIDTH)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) WINDOW) (WINDOWPROP WINDOW 'SELECTION (create TWOD.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM ROWPROP _ SELECTEDROWPROP COLUMNPROP _ SELECTEDCOLUMNPROP]) (TWODINSPECT.SELECTROWPROP [LAMBDA (WINDOW ROWPROP) (* ; "Edited 6-Apr-87 12:07 by jop") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (WINDOWPROP RIGHTWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION RIGHTWINDOW)) (PROG ((ROWPROPSPACE (WINDOWPROP WINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) SELECTEDROWPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDROWPROP (for RPROP on ROWPROPS thereis (EQUAL (CAR RPROP) ROWPROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as RPROP on ROWPROPS thereis (EQ RPROP SELECTEDROWPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDROWPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) RIGHTWINDOW) (WINDOWPROP RIGHTWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDROWPROP]) (TWODINSPECT.SELECTCOLUMNPROP [LAMBDA (WINDOW COLUMNPROP) (* ; "Edited 6-Apr-87 12:08 by jop") (PROG [(TOPWINDOW (WINDOWPROP WINDOW 'TOPWINDOW] (if (WINDOWPROP TOPWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION TOPWINDOW)) (PROG ((COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDCOLUMNPROP (for CPROP on COLUMNPROPS thereis (EQUAL (CAR CPROP) COLUMNPROP))) (SETQ SELECTEDELTBOTTOM 0) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDCOLUMNPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as CPROP on COLUMNPROPS thereis (EQ CPROP SELECTEDCOLUMNPROP) )) SELECTEDELTWIDTH)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) TOPWINDOW) (WINDOWPROP TOPWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDCOLUMNPROP]) (TWODINSPECT.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 12:06 by jop") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) (SELROWPROP (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (SELCOLPROP (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM (for VMARK in VERTMARKS as ROWPROP on ROWPROPS thereis (EQ ROWPROP SELROWPROP))) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM (CAR SELROWPROP ) (CAR SELCOLPROP)) WINDOW T))) (SETQ SELLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as COLPROP on COLUMNPROPS thereis (EQ COLPROP SELCOLPROP))) SELWIDTH)) (WINDOWPROP WINDOW 'SELECTION (create TWOD.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT ROWPROP _ SELROWPROP COLUMNPROP _ SELCOLPROP]) (TWODINSPECT.DEFAULT.TITLECOMMANDFN [LAMBDA (WINDOW) (* ; "Edited 20-Jul-90 20:54 by yabu") (if (MOUSESTATE MIDDLE) then (PROG [(TITLEMENU (CONSTANT (\CREATE.TWODINSPECTOR.TITLEMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Refetch%" 'REFETCH %"Refetch the datum%") (%"IT _ Datum%" 'IT %"Bind IT to the inspected datum%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (DATUM (WINDOWPROP WINDOW 'DATUM] (SELECTQ (MENU TITLEMENU) (REFETCH (TWODINSPECT.REDISPLAY WINDOW)) (IT (SETQ IT DATUM) (PROMPTPRINT "IT bound to " DATUM)) NIL]) (TWODINSPECT.DEFAULT.VALUECOMMANDFN [LAMBDA (VALUE ROWPROP COLUMNPROP DATUM WINDOW) (* ; "Edited 20-Jul-90 21:03 by yabu") (PROG ((SETMENU (CONSTANT (\CREATE.TWODINSPECTOR.SETMENU))) (* ; "Original was (create MENU ITEMS _ '((%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (INSPECTMENU (CONSTANT (\CREATE.TWODINSPECTOR.INSPECTMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Inspect%" 'INSPECT %"Inspect the value of the selected entry%") (%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  " Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (SELECTQ (if (OR (NULL VALUE) (NUMBERP VALUE)) then (MENU SETMENU) else (MENU INSPECTMENU)) (INSPECT (INSPECT VALUE)) (IT (SETQ IT VALUE) (PROMPTPRINT "IT bound to " IT)) (SET (TWODINSPECT.SETELT ROWPROP COLUMNPROP WINDOW)) NIL]) (TWODINSPECT.SETELT [LAMBDA (ROWPROP COLUMNPROP WINDOW) (* ; "Edited 5-Apr-87 16:41 by jop") (PROG ((PRTWINDOW (GETPROMPTWINDOW WINDOW)) (NEWVALUE (APPLY* (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) ROWPROP COLUMNPROP))) (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM PRTWINDOW)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (CLEARBUF T T) (printout T "Eval> ") (SETQ NEWVALUE (CL:FUNCALL XCL:*EVAL-FUNCTION* (LISPXREAD T T))) (* ;  "clear tty buffer because it sometimes has stuff left.") (CLEARBUF T T))) (REMOVEPROMPTWINDOW WINDOW) (TWODINSPECT.REPLACE WINDOW ROWPROP COLUMNPROP NEWVALUE]) (TWODINSPECT.ROWPROPWIDTH [LAMBDA (ROWPROPS FONT) (* ; "Edited 5-Apr-87 16:33 by jop") (for ROWPROP in ROWPROPS largest (STRINGWIDTH ROWPROP FONT T) finally (RETURN $$EXTREME]) (TWODINSPECT.COLUMNWIDTHS [LAMBDA (DATUM ROWPROPS COLUMNPROPS FETCHFN FONT) (* ; "Edited 5-Apr-87 15:38 by jop") (* ;; "Computes the MIN fieldwidth for the jth column of SLICE") (for COLUMNPROP in COLUMNPROPS collect (TWODINSPECT.COLUMNWIDTH DATUM ROWPROPS COLUMNPROP FETCHFN FONT]) (TWODINSPECT.COLUMNWIDTH [LAMBDA (DATUM ROWPROPS COLUMNPROP FETCHFN FONT) (* ; "Edited 5-Apr-87 16:29 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (IMAX (STRINGWIDTH COLUMNPROP FONT T) (for ROWPROP in ROWPROPS largest (STRINGWIDTH (APPLY* FETCHFN DATUM ROWPROP COLUMNPROP) FONT T) finally (RETURN $$EXTREME]) (TWODINSPECT.TOTALWIDTH [LAMBDA (COLUMNWIDTHS SPACE FONT) (* jop%: "25-Sep-85 13:21") (IPLUS (ITIMES (LENGTH COLUMNWIDTHS) (STRINGWIDTH SPACE FONT)) (for COLUMN in COLUMNWIDTHS sum COLUMN]) ) (* ;; "Right window fns") (DEFINEQ (GET-RIGHTW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 19-Feb-2021 12:16 by rmk:") (* ; "Edited 6-Apr-87 12:14 by jop") (LET [(RIGHTWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'RIGHTWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (WINDOWPROP RIGHTWINDOW 'REPAINTFN (FUNCTION RIGHTW.REPAINTFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP RIGHTWINDOW 'BUTTONEVENTFN (FUNCTION RIGHTW.BUTTONEVENTFN)) (* ;; "RMK: The rightwindow should only scroll as a consequence of left-window scrolling. If it were to scroll on its own, the parallelism would be lost. The left-window scroller knows to do the SCROLLBYREPAINTFN on the right window") (* (WINDOWPROP RIGHTWINDOW  (QUOTE SCROLLFN) (FUNCTION  SCROLLBYREPAINTFN))) (WINDOWPROP RIGHTWINDOW 'NOSCROLLBARS T) (DSPFONT FONT RIGHTWINDOW) (WINDOWPROP DISPLAYWINDOW 'RIGHTWINDOW RIGHTWINDOW) RIGHTWINDOW]) (RIGHTW.REPAINTFN [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 19-Feb-2021 13:37 by rmk:") (* ; "Edited 22-May-92 17:37 by jds") (* ;; "RMK: Right justify the PROP in its window (assuming its a numeric index)") (* ;;  "REPAINT the right-hand window of a two-d inspector. This window contains the element indices.") [COND ((NULL WINDOWREGION) (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW] (LET [(DISPLAYW (MAINWINDOW WINDOW)) (TOP (fetch (REGION TOP) of WINDOWREGION)) (BOTTOM (fetch (REGION BOTTOM) of WINDOWREGION)) (ROWPROPWIDTH (WINDOWPROP WINDOW 'ROWPROPWIDTH] (LET ((VERTMARKS (WINDOWPROP DISPLAYW 'VERTMARKS)) (ROWPROPS (WINDOWPROP DISPLAYW 'ROWPROPS)) (SPACE (STRINGWIDTH (WINDOWPROP DISPLAYW 'ROWPROPSPACE) WINDOW)) STARTROWPROPS LASTROWPROP STARTVERTMARKS) (for ROWPROP on ROWPROPS as MARK on VERTMARKS until (ILESSP (CAR MARK) TOP) finally (SETQ STARTROWPROPS ROWPROP) (SETQ STARTVERTMARKS MARK)) (for ROWPROP on STARTROWPROPS as MARK in STARTVERTMARKS until (ILESSP MARK BOTTOM) finally (SETQ LASTROWPROP ROWPROP)) [COND (STARTROWPROPS (WITH-INSPECTOR-ENV (WINDOWPROP DISPLAYW 'PROFILE) (bind [FDESCENT _ (SUB1 (FONTPROP WINDOW 'DESCENT] for ROWPROP on STARTROWPROPS as VERTMARK in STARTVERTMARKS repeatuntil (EQ ROWPROP LASTROWPROP) do (MOVETO (- ROWPROPWIDTH (STRINGWIDTH (CAR ROWPROP) WINDOW)) (IPLUS VERTMARK FDESCENT) WINDOW) (PRIN2 (CAR ROWPROP) WINDOW] (INSPECT.INVERTSELECTION WINDOW]) (RIGHTW.RESHAPEFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 10:37 by jop") (CLEARW WINDOW) (RIGHTW.ADJUSTSELECTION WINDOW) (RIGHTW.REPAINTFN WINDOW]) (RIGHTW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:48 by jop") (TOTOPW WINDOW) (LET* [(SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW)) (ROWPROPCOMMANDFN (WINDOWPROP MAINWINDOW 'ROWPROPCOMMANDFN] (if ROWPROPCOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP MAINWINDOW 'ROWPROPS) (WINDOWPROP MAINWINDOW 'VERTMARKS) (STRINGWIDTH (WINDOWPROP MAINWINDOW 'ROWPROPSPACE) WINDOW) NIL (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) P] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (CL:FUNCALL ROWPROPCOMMANDFN (CAR (fetch (ONED.SELECTION PROP) of SELECTION )) (WINDOWPROP MAINWINDOW 'DATUM) MAINWINDOW]) (RIGHTW.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 10:31 by jop") (PROG ((SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW))) (if SELECTION then (PROG ((ROWPROPSPACE (WINDOWPROP MAINWINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP MAINWINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP MAINWINDOW 'VERTMARKS)) (SELROWPROP (fetch (ONED.SELECTION PROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM (for VMARK in VERTMARKS as ROWPROP on ROWPROPS thereis (EQ ROWPROP SELROWPROP))) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (STRINGWIDTH (CAR SELROWPROP) WINDOW T))) (SETQ SELLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT PROP _ SELROWPROP smashing SELECTION]) ) (* ;; "Top window fns") (DEFINEQ (GET-TOPW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 6-Apr-87 14:43 by jop") (LET [(TOPWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'TOPWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (WINDOWPROP TOPWINDOW 'REPAINTFN (FUNCTION TOPW.REPAINTFN)) (WINDOWPROP TOPWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP TOPWINDOW 'BUTTONEVENTFN (FUNCTION TOPW.BUTTONEVENTFN)) (WINDOWPROP TOPWINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (DSPRIGHTMARGIN MAX.SMALLP TOPWINDOW) (* ;  "TOPWINDOW will scroll under program control") (WINDOWPROP TOPWINDOW 'NOSCROLLBARS T) (DSPFONT FONT TOPWINDOW) (WINDOWPROP DISPLAYWINDOW 'TOPWINDOW TOPWINDOW) TOPWINDOW]) (TOPW.REPAINTFN [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 6-Apr-87 11:12 by jop") (if (NULL WINDOWREGION) then (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW))) @@ -204,4 +114,4 @@ BOTTOM WINDOW) (PRIN2 (CAR COLUMNPROP) WINDOW] - (INSPECT.INVERTSELECTION WINDOW]) (TOPW.RESHAPEFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:55 by jop") (CLEARW WINDOW) (TOPW.ADJUSTSELECTION WINDOW) (TOPW.REPAINTFN WINDOW (DSPCLIPPINGREGION NIL WINDOW]) (TOPW.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:54 by jop") (PROG ((SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW))) (if SELECTION then (PROG ((COLUMNPROPS (WINDOWPROP MAINWINDOW 'COLUMNPROPS)) (HORZMARKS (WINDOWPROP MAINWINDOW 'HORZMARKS)) (SELCOLPROP (fetch (ONED.SELECTION PROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM 0) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (STRINGWIDTH (CAR SELCOLPROP) WINDOW T))) (SETQ SELLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as COLPROP on COLUMNPROPS thereis (EQ COLPROP SELCOLPROP))) SELWIDTH)) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT PROP _ SELCOLPROP]) (TOPW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:43 by jop") (TOTOPW WINDOW) (LET* [(SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW)) (COLUMNPROPCOMMANDFN (WINDOWPROP MAINWINDOW 'COLUMNPROPCOMMANDFN] (if COLUMNPROPCOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP MAINWINDOW 'COLUMNPROPS) (WINDOWPROP MAINWINDOW 'HORZMARKS) NIL 0 (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) P] (FUNCTION INSPECT.INVERTREGION) T)) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (CL:FUNCALL COLUMNPROPCOMMANDFN (CAR (fetch (ONED.SELECTION PROP) of SELECTION)) (WINDOWPROP MAINWINDOW 'DATUM) MAINWINDOW]) ) (* ;; "Title window fns") (DEFINEQ (GET-TITLEW [LAMBDA (DISPLAYWINDOW TITLE TITLEFONT DATUM) (* ; "Edited 6-Apr-87 17:02 by jop") (LET [(TITLEWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'TITLEWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL 1 T] (WINDOWPROP TITLEWINDOW 'REPAINTFN (FUNCTION TITLEW.REPAINTFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP TITLEWINDOW 'BUTTONEVENTFN (FUNCTION TITLEW.BUTTONEVENTFN)) (DSPFONT TITLEFONT TITLEWINDOW) (DSPOPERATION 'INVERT TITLEWINDOW) (WINDOWPROP TITLEWINDOW 'INSPECTTITLE (OR TITLE (CONCAT DATUM " Inspector"))) (WINDOWPROP DISPLAYWINDOW 'TITLEWINDOW TITLEWINDOW) TITLEWINDOW]) (TITLEW.REPAINTFN [LAMBDA (WINDOW) (* ; "Edited 5-Apr-87 14:50 by jop") (BITBLT NIL NIL NIL WINDOW NIL NIL NIL NIL 'TEXTURE 'REPLACE BLACKSHADE) (MOVETOUPPERLEFT WINDOW) (PRINTOUT WINDOW (WINDOWPROP WINDOW 'INSPECTTITLE]) (TITLEW.BUTTONEVENTFN [LAMBDA (TITLEWINDOW) (* ; "Edited 5-Apr-87 16:41 by jop") (PROG ((MAINWINDOW (MAINWINDOW TITLEWINDOW)) TITLECOMMANDFN) (SETQ TITLECOMMANDFN (WINDOWPROP MAINWINDOW 'TITLECOMMANDFN)) (if TITLECOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (APPLY* TITLECOMMANDFN MAINWINDOW]) ) (* ;; "Utilites ") (DEFINEQ (ONED.TRACKCURSOR [LAMBDA (WINDOW SELECTION PROPS MARKS LEFT BOTTOM HEIGHT NEW-ITEM-FN HIGHLIGHT-FN HORIZONTAL-P) (* ; "Edited 6-Apr-87 17:41 by jop") (LET (SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH SELECTEDPROP) (if SELECTION then (SETQ SELECTEDELTBOTTOM (fetch (ONED.SELECTION ELTBOTTOM) of SELECTION)) (SETQ SELECTEDELTLEFT (fetch (ONED.SELECTION ELTLEFT) of SELECTION)) (SETQ SELECTEDELTWIDTH (fetch (ONED.SELECTION ELTWIDTH) of SELECTION)) (SETQ SELECTEDPROP (fetch (ONED.SELECTION PROP) of SELECTION))) (bind X Y NEWPROP WIDTH while (MOUSESTATE LEFT) do (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) [if (NOT HORIZONTAL-P) then [for PROP on PROPS as MARK in MARKS until (ILESSP MARK Y) finally (if PROP then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR PROP) WINDOW) WINDOW T)) (SETQ BOTTOM MARK) (* ;  "Select the new region only if the cursor is inside the element box") (SETQ NEWPROP (AND [NOT (OR (ILESSP X LEFT) (IGREATERP X (IPLUS LEFT WIDTH] PROP] else (for PROP on PROPS as MARK in MARKS until (IGREATERP MARK X) finally (if PROP then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR PROP) WINDOW) WINDOW T)) (SETQ LEFT (ADD1 (IDIFFERENCE MARK WIDTH))) (SETQ NEWPROP (AND (NOT (ILESSP X LEFT)) PROP] (if (NEQ NEWPROP SELECTEDPROP) then (* ;  "We need to consider highlighting a new region") (if SELECTEDPROP then (* ; "Lowlight the old region") (CL:FUNCALL HIGHLIGHT-FN SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH HEIGHT WINDOW) (SETQ SELECTEDPROP NIL)) (if NEWPROP then (* ;  "cursor inside element box, highlight that box") (CL:FUNCALL HIGHLIGHT-FN LEFT BOTTOM WIDTH HEIGHT WINDOW) (SETQ SELECTEDPROP NEWPROP) (SETQ SELECTEDELTWIDTH WIDTH) (SETQ SELECTEDELTLEFT LEFT) (SETQ SELECTEDELTBOTTOM BOTTOM))) finally (if SELECTEDPROP then (if (NULL SELECTION) then (SETQ SELECTION (create ONED.SELECTION))) (RETURN (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP smashing SELECTION]) (TWOD.TRACKCURSOR [LAMBDA (WINDOW SELECTION ROWPROPS VERTMARKS COLUMNPROPS HORZMARKS HEIGHT NEW-ITEM-FN HIGHLIGHT-FN) (* ; "Edited 6-Apr-87 18:36 by jop") (TOTOPW WINDOW) (LET (SELECTEDROWPROP SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (if SELECTION then (SETQ SELECTEDROWPROP (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (SETQ SELECTEDCOLUMNPROP (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION)) (SETQ SELECTEDELTBOTTOM (fetch (TWOD.SELECTION ELTBOTTOM) of SELECTION)) (SETQ SELECTEDELTLEFT (fetch (TWOD.SELECTION ELTLEFT) of SELECTION)) (SETQ SELECTEDELTWIDTH (fetch (TWOD.SELECTION ELTWIDTH) of SELECTION))) (bind NEWROWPROP NEWCOLUMNPROP NEWHORZMARK LEFT BOTTOM WIDTH X Y while (MOUSESTATE LEFT) do (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) (for ROWPROP on ROWPROPS as VERTMARK in VERTMARKS until (ILESSP VERTMARK Y) finally (SETQ NEWROWPROP ROWPROP) (SETQ BOTTOM VERTMARK)) (for COLUMNPROP on COLUMNPROPS as HORZMARK in HORZMARKS until (IGREATERP HORZMARK X) finally (SETQ NEWCOLUMNPROP COLUMNPROP) (SETQ NEWHORZMARK HORZMARK)) (if (AND NEWROWPROP NEWCOLUMNPROP) then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR NEWROWPROP) (CAR NEWCOLUMNPROP) WINDOW) WINDOW T)) (SETQ LEFT (ADD1 (IDIFFERENCE NEWHORZMARK WIDTH))) (* ;  "Select the new region only if the cursor is inside the element box") (if (ILESSP X LEFT) then (SETQ NEWROWPROP NIL) (SETQ NEWCOLUMNPROP NIL))) (if (OR (NEQ NEWROWPROP SELECTEDROWPROP) (NEQ NEWCOLUMNPROP SELECTEDCOLUMNPROP)) then (* ;  "We need to consider highlighting a new region") (if (AND SELECTEDROWPROP SELECTEDCOLUMNPROP) then (* ; "Lowlight the old region") (CL:FUNCALL HIGHLIGHT-FN SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH HEIGHT WINDOW) (SETQ SELECTEDROWPROP NIL) (SETQ SELECTEDCOLUMNPROP NIL)) (if (AND NEWROWPROP NEWCOLUMNPROP) then (* ;  "cursor inside element box, highlight that box") (CL:FUNCALL HIGHLIGHT-FN LEFT BOTTOM WIDTH HEIGHT WINDOW) (SETQ SELECTEDROWPROP NEWROWPROP) (SETQ SELECTEDCOLUMNPROP NEWCOLUMNPROP) (SETQ SELECTEDELTWIDTH WIDTH) (SETQ SELECTEDELTLEFT LEFT) (SETQ SELECTEDELTBOTTOM BOTTOM))) finally (if (AND SELECTEDROWPROP SELECTEDCOLUMNPROP) then (if (NULL SELECTION) then (SETQ SELECTION (create TWOD.SELECTION))) (RETURN (create TWOD.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM ROWPROP _ SELECTEDROWPROP COLUMNPROP _ SELECTEDCOLUMNPROP smashing SELECTION]) (INSPECT.INVERTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:11 by jop") (* ;; "Inverts SELECTION if non-NIL") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (INSPECT.INVERTREGION (fetch (INSPECT.SELECTION ELTLEFT) of SELECTION ) (fetch (INSPECT.SELECTION ELTBOTTOM) of SELECTION) (fetch (INSPECT.SELECTION ELTWIDTH) of SELECTION) (FONTPROP WINDOW 'HEIGHT) WINDOW]) (INSPECT.INVERTREGION [LAMBDA (LEFT BOTTOM WIDTH HEIGHT WINDOW) (* ; "Edited 6-Apr-87 16:38 by jop") (BLTSHADE BLACKSHADE WINDOW LEFT BOTTOM WIDTH HEIGHT 'INVERT]) (INSPECT.FLIPSELECTION [LAMBDA (LEFT BOTTOM WIDTH HEIGHT WINDOW) (* ; "Edited 6-Apr-87 16:45 by jop") (BLTSHADE GRAYSHADE WINDOW LEFT BOTTOM WIDTH HEIGHT 'INVERT]) ) (RPAQ? INSPECTORFONT NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS INSPECTORFONT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD INSPECT.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH)) (DATATYPE ONED.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH PROP)) (DATATYPE TWOD.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH ROWPROP COLUMNPROP)) ) (/DECLAREDATATYPE 'ONED.SELECTION '(POINTER POINTER POINTER POINTER) '((ONED.SELECTION 0 POINTER) (ONED.SELECTION 2 POINTER) (ONED.SELECTION 4 POINTER) (ONED.SELECTION 6 POINTER)) '8) (/DECLAREDATATYPE 'TWOD.SELECTION '(POINTER POINTER POINTER POINTER POINTER) '((TWOD.SELECTION 0 POINTER) (TWOD.SELECTION 2 POINTER) (TWOD.SELECTION 4 POINTER) (TWOD.SELECTION 6 POINTER) (TWOD.SELECTION 8 POINTER)) '10) ) (/DECLAREDATATYPE 'ONED.SELECTION '(POINTER POINTER POINTER POINTER) '((ONED.SELECTION 0 POINTER) (ONED.SELECTION 2 POINTER) (ONED.SELECTION 4 POINTER) (ONED.SELECTION 6 POINTER)) '8) (/DECLAREDATATYPE 'TWOD.SELECTION '(POINTER POINTER POINTER POINTER POINTER) '((TWOD.SELECTION 0 POINTER) (TWOD.SELECTION 2 POINTER) (TWOD.SELECTION 4 POINTER) (TWOD.SELECTION 6 POINTER) (TWOD.SELECTION 8 POINTER)) '10) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS TWODINSPECTOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1900 1987 1990 1992 1993 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3520 4267 (\CREATE.TWODINSPECTOR.TITLEMENU 3530 . 3737) (\CREATE.TWODINSPECTOR.SETMENU 3739 . 3957) (\CREATE.TWODINSPECTOR.INSPECTMENU 3959 . 4265)) (4301 37441 (ONEDINSPECTW.CREATE 4311 . 8038) (GET-ONED-DISPLAYW 8040 . 10127) (ONEDINSPECT.ARRANGEWINDOWS 10129 . 15403) ( ONEDINSPECT.REPAINTFN 15405 . 17099) (ONEDINSPECT.PRINTELEMENT 17101 . 17319) (ONEDINSPECT.RESHAPEFN 17321 . 17657) (ONEDINSPECT.MAKEREGIONS 17659 . 19607) (ONEDINSPECT.BUTTONEVENTFN 19609 . 21622) ( ONEDINSPECT.COPYBUTTONFN 21624 . 23463) (ONEDINSPECT.SCROLLFN 23465 . 23881) (ONEDINSPECT.CLOSEFN 23883 . 24146) (ONEDINSPECT.REDISPLAY 24148 . 26904) (ONEDINSPECT.REPLACE 26906 . 27216) ( ONEDINSPECT.SELECTITEM 27218 . 29057) (ONEDINSPECT.SELECTPROP 29059 . 30803) ( ONEDINSPECT.ADJUSTSELECTION 30805 . 32345) (ONEDINSPECT.PROPWIDTH 32347 . 32964) ( ONEDINSPECT.VALUEWIDTH 32966 . 33352) (ONEDINSPECT.DEFAULT.TITLECOMMANDFN 33354 . 34329) ( ONEDINSPECT.DEFAULT.VALUECOMMANDFN 34331 . 35893) (ONEDINSPECT.SETELT 35895 . 37439)) (37474 83543 ( TWODINSPECTW.CREATE 37484 . 42117) (GET-TWOD-DISPLAYW 42119 . 44769) (GET-CORNERW 44771 . 45476) ( TWODINSPECT.ARRANGEWINDOWS 45478 . 51599) (TWODINSPECT.REPAINTFN 51601 . 54786) ( TWODINSPECT.PRINTELEMENT 54788 . 55063) (TWODINSPECT.RESHAPEFN 55065 . 55401) (TWODINSPECT.MAKEREGIONS 55403 . 58204) (TWODINSPECT.BUTTONEVENTFN 58206 . 60835) (TWODINSPECT.COPYBUTTONFN 60837 . 63128) ( TWODINSPECT.DOWINDOWCOMFN 63130 . 63740) (TWODINSPECT.SCROLLFN 63742 . 64401) (TWODINSPECT.CLOSEFN 64403 . 64796) (TWODINSPECT.REDISPLAY 64798 . 69035) (TWODINSPECT.REPLACE 69037 . 69375) ( TWODINSPECT.SELECTITEM 69377 . 72298) (TWODINSPECT.SELECTROWPROP 72300 . 74078) ( TWODINSPECT.SELECTCOLUMNPROP 74080 . 76114) (TWODINSPECT.ADJUSTSELECTION 76116 . 78484) ( TWODINSPECT.DEFAULT.TITLECOMMANDFN 78486 . 79461) (TWODINSPECT.DEFAULT.VALUECOMMANDFN 79463 . 81039) ( TWODINSPECT.SETELT 81041 . 82077) (TWODINSPECT.ROWPROPWIDTH 82079 . 82328) (TWODINSPECT.COLUMNWIDTHS 82330 . 82725) (TWODINSPECT.COLUMNWIDTH 82727 . 83270) (TWODINSPECT.TOTALWIDTH 83272 . 83541)) (83578 91324 (GET-RIGHTW 83588 . 84440) (RIGHTW.REPAINTFN 84442 . 86941) (RIGHTW.RESHAPEFN 86943 . 87162) ( RIGHTW.BUTTONEVENTFN 87164 . 89759) (RIGHTW.ADJUSTSELECTION 89761 . 91322)) (91357 98194 (GET-TOPW 91367 . 92359) (TOPW.REPAINTFN 92361 . 94220) (TOPW.RESHAPEFN 94222 . 94465) (TOPW.ADJUSTSELECTION 94467 . 96086) (TOPW.BUTTONEVENTFN 96088 . 98192)) (98229 99746 (GET-TITLEW 98239 . 99003) ( TITLEW.REPAINTFN 99005 . 99291) (TITLEW.BUTTONEVENTFN 99293 . 99744)) (99774 110379 (ONED.TRACKCURSOR 99784 . 104485) (TWOD.TRACKCURSOR 104487 . 109193) (INSPECT.INVERTSELECTION 109195 . 109983) ( INSPECT.INVERTREGION 109985 . 110180) (INSPECT.FLIPSELECTION 110182 . 110377))))) STOP \ No newline at end of file + (INSPECT.INVERTSELECTION WINDOW]) (TOPW.RESHAPEFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:55 by jop") (CLEARW WINDOW) (TOPW.ADJUSTSELECTION WINDOW) (TOPW.REPAINTFN WINDOW (DSPCLIPPINGREGION NIL WINDOW]) (TOPW.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:54 by jop") (PROG ((SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW))) (if SELECTION then (PROG ((COLUMNPROPS (WINDOWPROP MAINWINDOW 'COLUMNPROPS)) (HORZMARKS (WINDOWPROP MAINWINDOW 'HORZMARKS)) (SELCOLPROP (fetch (ONED.SELECTION PROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM 0) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (STRINGWIDTH (CAR SELCOLPROP) WINDOW T))) (SETQ SELLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as COLPROP on COLUMNPROPS thereis (EQ COLPROP SELCOLPROP))) SELWIDTH)) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT PROP _ SELCOLPROP]) (TOPW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:43 by jop") (TOTOPW WINDOW) (LET* [(SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW)) (COLUMNPROPCOMMANDFN (WINDOWPROP MAINWINDOW 'COLUMNPROPCOMMANDFN] (if COLUMNPROPCOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP MAINWINDOW 'COLUMNPROPS) (WINDOWPROP MAINWINDOW 'HORZMARKS) NIL 0 (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) P] (FUNCTION INSPECT.INVERTREGION) T)) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (CL:FUNCALL COLUMNPROPCOMMANDFN (CAR (fetch (ONED.SELECTION PROP) of SELECTION)) (WINDOWPROP MAINWINDOW 'DATUM) MAINWINDOW]) ) (* ;; "Title window fns") (DEFINEQ (GET-TITLEW [LAMBDA (DISPLAYWINDOW TITLE TITLEFONT DATUM) (* ; "Edited 6-Apr-87 17:02 by jop") (LET [(TITLEWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'TITLEWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL 1 T] (WINDOWPROP TITLEWINDOW 'REPAINTFN (FUNCTION TITLEW.REPAINTFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP TITLEWINDOW 'BUTTONEVENTFN (FUNCTION TITLEW.BUTTONEVENTFN)) (DSPFONT TITLEFONT TITLEWINDOW) (DSPOPERATION 'INVERT TITLEWINDOW) (WINDOWPROP TITLEWINDOW 'INSPECTTITLE (OR TITLE (CONCAT DATUM " Inspector"))) (WINDOWPROP DISPLAYWINDOW 'TITLEWINDOW TITLEWINDOW) TITLEWINDOW]) (TITLEW.REPAINTFN [LAMBDA (WINDOW) (* ; "Edited 5-Apr-87 14:50 by jop") (BITBLT NIL NIL NIL WINDOW NIL NIL NIL NIL 'TEXTURE 'REPLACE BLACKSHADE) (MOVETOUPPERLEFT WINDOW) (PRINTOUT WINDOW (WINDOWPROP WINDOW 'INSPECTTITLE]) (TITLEW.BUTTONEVENTFN [LAMBDA (TITLEWINDOW) (* ; "Edited 5-Apr-87 16:41 by jop") (PROG ((MAINWINDOW (MAINWINDOW TITLEWINDOW)) TITLECOMMANDFN) (SETQ TITLECOMMANDFN (WINDOWPROP MAINWINDOW 'TITLECOMMANDFN)) (if TITLECOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (APPLY* TITLECOMMANDFN MAINWINDOW]) ) (* ;; "Utilites ") (DEFINEQ (ONED.TRACKCURSOR [LAMBDA (WINDOW SELECTION PROPS MARKS LEFT BOTTOM HEIGHT NEW-ITEM-FN HIGHLIGHT-FN HORIZONTAL-P) (* ; "Edited 6-Apr-87 17:41 by jop") (LET (SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH SELECTEDPROP) (if SELECTION then (SETQ SELECTEDELTBOTTOM (fetch (ONED.SELECTION ELTBOTTOM) of SELECTION)) (SETQ SELECTEDELTLEFT (fetch (ONED.SELECTION ELTLEFT) of SELECTION)) (SETQ SELECTEDELTWIDTH (fetch (ONED.SELECTION ELTWIDTH) of SELECTION)) (SETQ SELECTEDPROP (fetch (ONED.SELECTION PROP) of SELECTION))) (bind X Y NEWPROP WIDTH while (MOUSESTATE LEFT) do (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) [if (NOT HORIZONTAL-P) then [for PROP on PROPS as MARK in MARKS until (ILESSP MARK Y) finally (if PROP then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR PROP) WINDOW) WINDOW T)) (SETQ BOTTOM MARK) (* ;  "Select the new region only if the cursor is inside the element box") (SETQ NEWPROP (AND [NOT (OR (ILESSP X LEFT) (IGREATERP X (IPLUS LEFT WIDTH] PROP] else (for PROP on PROPS as MARK in MARKS until (IGREATERP MARK X) finally (if PROP then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR PROP) WINDOW) WINDOW T)) (SETQ LEFT (ADD1 (IDIFFERENCE MARK WIDTH))) (SETQ NEWPROP (AND (NOT (ILESSP X LEFT)) PROP] (if (NEQ NEWPROP SELECTEDPROP) then (* ;  "We need to consider highlighting a new region") (if SELECTEDPROP then (* ; "Lowlight the old region") (CL:FUNCALL HIGHLIGHT-FN SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH HEIGHT WINDOW) (SETQ SELECTEDPROP NIL)) (if NEWPROP then (* ;  "cursor inside element box, highlight that box") (CL:FUNCALL HIGHLIGHT-FN LEFT BOTTOM WIDTH HEIGHT WINDOW) (SETQ SELECTEDPROP NEWPROP) (SETQ SELECTEDELTWIDTH WIDTH) (SETQ SELECTEDELTLEFT LEFT) (SETQ SELECTEDELTBOTTOM BOTTOM))) finally (if SELECTEDPROP then (if (NULL SELECTION) then (SETQ SELECTION (create ONED.SELECTION))) (RETURN (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP smashing SELECTION]) (TWOD.TRACKCURSOR [LAMBDA (WINDOW SELECTION ROWPROPS VERTMARKS COLUMNPROPS HORZMARKS HEIGHT NEW-ITEM-FN HIGHLIGHT-FN) (* ; "Edited 6-Apr-87 18:36 by jop") (TOTOPW WINDOW) (LET (SELECTEDROWPROP SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (if SELECTION then (SETQ SELECTEDROWPROP (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (SETQ SELECTEDCOLUMNPROP (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION)) (SETQ SELECTEDELTBOTTOM (fetch (TWOD.SELECTION ELTBOTTOM) of SELECTION)) (SETQ SELECTEDELTLEFT (fetch (TWOD.SELECTION ELTLEFT) of SELECTION)) (SETQ SELECTEDELTWIDTH (fetch (TWOD.SELECTION ELTWIDTH) of SELECTION))) (bind NEWROWPROP NEWCOLUMNPROP NEWHORZMARK LEFT BOTTOM WIDTH X Y while (MOUSESTATE LEFT) do (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) (for ROWPROP on ROWPROPS as VERTMARK in VERTMARKS until (ILESSP VERTMARK Y) finally (SETQ NEWROWPROP ROWPROP) (SETQ BOTTOM VERTMARK)) (for COLUMNPROP on COLUMNPROPS as HORZMARK in HORZMARKS until (IGREATERP HORZMARK X) finally (SETQ NEWCOLUMNPROP COLUMNPROP) (SETQ NEWHORZMARK HORZMARK)) (if (AND NEWROWPROP NEWCOLUMNPROP) then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR NEWROWPROP) (CAR NEWCOLUMNPROP) WINDOW) WINDOW T)) (SETQ LEFT (ADD1 (IDIFFERENCE NEWHORZMARK WIDTH))) (* ;  "Select the new region only if the cursor is inside the element box") (if (ILESSP X LEFT) then (SETQ NEWROWPROP NIL) (SETQ NEWCOLUMNPROP NIL))) (if (OR (NEQ NEWROWPROP SELECTEDROWPROP) (NEQ NEWCOLUMNPROP SELECTEDCOLUMNPROP)) then (* ;  "We need to consider highlighting a new region") (if (AND SELECTEDROWPROP SELECTEDCOLUMNPROP) then (* ; "Lowlight the old region") (CL:FUNCALL HIGHLIGHT-FN SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH HEIGHT WINDOW) (SETQ SELECTEDROWPROP NIL) (SETQ SELECTEDCOLUMNPROP NIL)) (if (AND NEWROWPROP NEWCOLUMNPROP) then (* ;  "cursor inside element box, highlight that box") (CL:FUNCALL HIGHLIGHT-FN LEFT BOTTOM WIDTH HEIGHT WINDOW) (SETQ SELECTEDROWPROP NEWROWPROP) (SETQ SELECTEDCOLUMNPROP NEWCOLUMNPROP) (SETQ SELECTEDELTWIDTH WIDTH) (SETQ SELECTEDELTLEFT LEFT) (SETQ SELECTEDELTBOTTOM BOTTOM))) finally (if (AND SELECTEDROWPROP SELECTEDCOLUMNPROP) then (if (NULL SELECTION) then (SETQ SELECTION (create TWOD.SELECTION))) (RETURN (create TWOD.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM ROWPROP _ SELECTEDROWPROP COLUMNPROP _ SELECTEDCOLUMNPROP smashing SELECTION]) (INSPECT.INVERTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:11 by jop") (* ;; "Inverts SELECTION if non-NIL") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (INSPECT.INVERTREGION (fetch (INSPECT.SELECTION ELTLEFT) of SELECTION ) (fetch (INSPECT.SELECTION ELTBOTTOM) of SELECTION) (fetch (INSPECT.SELECTION ELTWIDTH) of SELECTION) (FONTPROP WINDOW 'HEIGHT) WINDOW]) (INSPECT.INVERTREGION [LAMBDA (LEFT BOTTOM WIDTH HEIGHT WINDOW) (* ; "Edited 6-Apr-87 16:38 by jop") (BLTSHADE BLACKSHADE WINDOW LEFT BOTTOM WIDTH HEIGHT 'INVERT]) (INSPECT.FLIPSELECTION [LAMBDA (LEFT BOTTOM WIDTH HEIGHT WINDOW) (* ; "Edited 6-Apr-87 16:45 by jop") (BLTSHADE GRAYSHADE WINDOW LEFT BOTTOM WIDTH HEIGHT 'INVERT]) ) (RPAQ? INSPECTORFONT NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS INSPECTORFONT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD INSPECT.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH)) (DATATYPE ONED.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH PROP)) (DATATYPE TWOD.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH ROWPROP COLUMNPROP)) ) (/DECLAREDATATYPE 'ONED.SELECTION '(POINTER POINTER POINTER POINTER) '((ONED.SELECTION 0 POINTER) (ONED.SELECTION 2 POINTER) (ONED.SELECTION 4 POINTER) (ONED.SELECTION 6 POINTER)) '8) (/DECLAREDATATYPE 'TWOD.SELECTION '(POINTER POINTER POINTER POINTER POINTER) '((TWOD.SELECTION 0 POINTER) (TWOD.SELECTION 2 POINTER) (TWOD.SELECTION 4 POINTER) (TWOD.SELECTION 6 POINTER) (TWOD.SELECTION 8 POINTER)) '10) ) (/DECLAREDATATYPE 'ONED.SELECTION '(POINTER POINTER POINTER POINTER) '((ONED.SELECTION 0 POINTER) (ONED.SELECTION 2 POINTER) (ONED.SELECTION 4 POINTER) (ONED.SELECTION 6 POINTER)) '8) (/DECLAREDATATYPE 'TWOD.SELECTION '(POINTER POINTER POINTER POINTER POINTER) '((TWOD.SELECTION 0 POINTER) (TWOD.SELECTION 2 POINTER) (TWOD.SELECTION 4 POINTER) (TWOD.SELECTION 6 POINTER) (TWOD.SELECTION 8 POINTER)) '10) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS TWODINSPECTOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1900 1987 1990 1992 1993 2020 2021 )) (DECLARE%: DONTCOPY (FILEMAP (NIL (3566 4313 (\CREATE.TWODINSPECTOR.TITLEMENU 3576 . 3783) (\CREATE.TWODINSPECTOR.SETMENU 3785 . 4003) (\CREATE.TWODINSPECTOR.INSPECTMENU 4005 . 4311)) (4347 37661 (ONEDINSPECTW.CREATE 4357 . 8084) (GET-ONED-DISPLAYW 8086 . 10173) (ONEDINSPECT.ARRANGEWINDOWS 10175 . 15449) ( ONEDINSPECT.REPAINTFN 15451 . 17145) (ONEDINSPECT.PRINTELEMENT 17147 . 17365) (ONEDINSPECT.RESHAPEFN 17367 . 17703) (ONEDINSPECT.MAKEREGIONS 17705 . 19653) (ONEDINSPECT.BUTTONEVENTFN 19655 . 21668) ( ONEDINSPECT.COPYBUTTONFN 21670 . 23509) (ONEDINSPECT.SCROLLFN 23511 . 24101) (ONEDINSPECT.CLOSEFN 24103 . 24366) (ONEDINSPECT.REDISPLAY 24368 . 27124) (ONEDINSPECT.REPLACE 27126 . 27436) ( ONEDINSPECT.SELECTITEM 27438 . 29277) (ONEDINSPECT.SELECTPROP 29279 . 31023) ( ONEDINSPECT.ADJUSTSELECTION 31025 . 32565) (ONEDINSPECT.PROPWIDTH 32567 . 33184) ( ONEDINSPECT.VALUEWIDTH 33186 . 33572) (ONEDINSPECT.DEFAULT.TITLECOMMANDFN 33574 . 34549) ( ONEDINSPECT.DEFAULT.VALUECOMMANDFN 34551 . 36113) (ONEDINSPECT.SETELT 36115 . 37659)) (37694 84172 ( TWODINSPECTW.CREATE 37704 . 42337) (GET-TWOD-DISPLAYW 42339 . 44989) (GET-CORNERW 44991 . 45696) ( TWODINSPECT.ARRANGEWINDOWS 45698 . 52054) (TWODINSPECT.REPAINTFN 52056 . 55241) ( TWODINSPECT.PRINTELEMENT 55243 . 55518) (TWODINSPECT.RESHAPEFN 55520 . 55856) (TWODINSPECT.MAKEREGIONS 55858 . 58659) (TWODINSPECT.BUTTONEVENTFN 58661 . 61290) (TWODINSPECT.COPYBUTTONFN 61292 . 63583) ( TWODINSPECT.DOWINDOWCOMFN 63585 . 64195) (TWODINSPECT.SCROLLFN 64197 . 65030) (TWODINSPECT.CLOSEFN 65032 . 65425) (TWODINSPECT.REDISPLAY 65427 . 69664) (TWODINSPECT.REPLACE 69666 . 70004) ( TWODINSPECT.SELECTITEM 70006 . 72927) (TWODINSPECT.SELECTROWPROP 72929 . 74707) ( TWODINSPECT.SELECTCOLUMNPROP 74709 . 76743) (TWODINSPECT.ADJUSTSELECTION 76745 . 79113) ( TWODINSPECT.DEFAULT.TITLECOMMANDFN 79115 . 80090) (TWODINSPECT.DEFAULT.VALUECOMMANDFN 80092 . 81668) ( TWODINSPECT.SETELT 81670 . 82706) (TWODINSPECT.ROWPROPWIDTH 82708 . 82957) (TWODINSPECT.COLUMNWIDTHS 82959 . 83354) (TWODINSPECT.COLUMNWIDTH 83356 . 83899) (TWODINSPECT.TOTALWIDTH 83901 . 84170)) (84207 92503 (GET-RIGHTW 84217 . 85619) (RIGHTW.REPAINTFN 85621 . 88120) (RIGHTW.RESHAPEFN 88122 . 88341) ( RIGHTW.BUTTONEVENTFN 88343 . 90938) (RIGHTW.ADJUSTSELECTION 90940 . 92501)) (92536 99373 (GET-TOPW 92546 . 93538) (TOPW.REPAINTFN 93540 . 95399) (TOPW.RESHAPEFN 95401 . 95644) (TOPW.ADJUSTSELECTION 95646 . 97265) (TOPW.BUTTONEVENTFN 97267 . 99371)) (99408 100925 (GET-TITLEW 99418 . 100182) ( TITLEW.REPAINTFN 100184 . 100470) (TITLEW.BUTTONEVENTFN 100472 . 100923)) (100953 111558 ( ONED.TRACKCURSOR 100963 . 105664) (TWOD.TRACKCURSOR 105666 . 110372) (INSPECT.INVERTSELECTION 110374 . 111162) (INSPECT.INVERTREGION 111164 . 111359) (INSPECT.FLIPSELECTION 111361 . 111556))))) STOP \ No newline at end of file diff --git a/sources/TWODINSPECTOR.LCOM b/sources/TWODINSPECTOR.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..465a97cd0ccec2ef232d3cb99e99e73e07947ab1 GIT binary patch literal 55515 zcmeHwYjj-4eIIt0FG<95cL|{|OheZ&LxYR}V|Vc&X;;AlSO5zw_CmW0E-A}eQCvs> z2$2dOwv{-ij@>kFo5YbEKWoQr`XNoyCd&s>ixjmzIVUI9>1j`Tj?_|a9$%6)ZNE^* z$?1n4hyDHkGjnI=-n%40$&Z|xwy^iky?18r-2eRF^P7R`{7j*gADk%^^Mi%bjO+9* z<)#*Lvw5e#P^#w3#X@DN-{~vobJNw_WYJeVnXBZT^zgyX0jgjMcUAM#PJjBy;LOT1 zgPGw>+DVTb&8ClLv;EFM|EaUjzp%Ek(s0h6ar&LkpPjBO{M<*D&##<2|Jdo1FKnDV z^H}lhsgoOzJ-^b}Sa~r!H2Td0X3g>z_cc-ToFK01u{GN}KVb1PnpE1!Jf-1(n4>bRx6dU_~VF6TUSC^FW?pX&GK~i=x7@M@4vT^ zdY4AVNvE^v(Q)V0>d7@F@PB}l5uTIT@hUFFK!s-f**v04j z4`Rj?s!rXR=2P`Zp^CdF*UmH?T)c3WA6Pqc{)LrOM0WDggYCwnlIKqUXp9EGU1enh zU0*wU#v7EdH~jd?jf*SJ*=PB6&+{XA+m$mH&b`P3Rav>qOhxqLZ~qY-BsqNtcVA=ouaMjgzyr3#M59Knj1k>h;a;c4&PdDxlG zRhJiW<%lyo=~k;Q9jAw#*A(7I~W3STvc6E;q6hx4u$KoL=4&KlNa%QcKjF+Wy*s zT3@Yyxpt`5-T5HhdTLjr)-8^9S8D^cp;}@$m&a@S9-xCO3l;wTiuieb$LGYs)mY_; z&2Djg`Gb|nsjgNfdMedwzLyT?qY)g>NAc53KltrwRgcx;wXRyK)?4eT?d#md?L1oL z>W}f?TAY8X%#8WZLv+(I-+3+WD@b$L>CyO5r0Ygu)kzDBT2=Ocj+Ue zlAcglnaeHF7fT;LVhK9)O4_>O(<;*VdP{DlP%XG65Iu;loSzlPm`G8TNZ%t#uot5?cEj(Ngf7mk>> zU)O;+U z2OcLVpbLUS6%^OeGrE9|hzVVg%*wnr;%5K_^hPm=0{Wr2Nddheimo^Xbb~n=CcTS! z`XJAtr)iFC?&dkc^JkSycvf%jWDO_zg@@+q-F#90xZ+GtGPet}Xne$Za@rk2YqQ6k zu@U|lN9BtTGQX-gP$=me8O7xSSq8W=Y+flmk$18gXS%Y)tQ8zhDouPk;w1$wMrL&;+iqJHcB zK9J-h!m`t|Fq00bT$y1Aa#63oFAX7UNT4BAolhG}Lje1Wz#SETPLCN=8GKJnW|H-0 z-BU%k!pZ~s<{b~)^fu)#otRvPN?IZ<11f#l}+$H@1__R*uNCsY)ekU_JLcf+w_xn!B?j8U` z#phA_Ggzow%@w5>hm58(K?|g1<3uXy&~xdGwREMa2|*1-hW!-c3?INW4!}*Llc|o5 zT@%cZn4jJCF!>kBNg+PP&+CseXQ?O5C%LM6Pa($#ZqLmeKl1vc;zDX>b4+mXIWGUs zsyI`1^|sDL{>JTn`(?NHGdOz9O_Xjvv%B?KH}TeM`OVDy!UWfIQ#~bW-PhXqw!04x z?fdzSZ`b23H|54}KJ#Gf7u?iaIGq(*^H*o%kymHq(HqT)sc%kyV=908t(&h-&*1Nk z=1_iSwIQ4xojXWfsP{!9ZXYS;H=n2UXMFN%(T%&QH%`CxX1#0O?Rxv`>-DZy z@$^kM^(GoyEV&83*1hg_fA?$a_3qXpt|i`lO$^g|qnC$m!tHXq-FS)lH@`-XzlEDx z7dNO=2pp@Rhab<$5!g|8BCaF5iFUf(lv$-{lb@L6>etou}4IP5NF zAh4h-O}fYBn`W|j3vJdM83X5sp>U^)XkabVeb|7jwreq*jk$xEG<}@-f~@cqK-% z;N?QxNnQ$#*n0$$MLm*5mFgJO?Md3~VM|C$kuB;%Rq8$#;htozuslFD{Yz)huaO_m zk>07Z=bTTluI`f$o+R12I|$mp^6`)}C0DK<%a^Ore-_9M1OZ1y{Pp0E8Fq@fig%_I zZd~w0H_WKYPVhsvmz3`$8iB7QRf{v9{PqK<-%5U9$HI;I*ygrof8@2r*wy#dx)&oG z(OS=*c&S*6Gly#}HfmkBURq5=Z_G!ZXui=g02Rk3HVUV(E4qpigHA(~Go6P>E-b+- zMBNRT%lBeJ8;%PlY149)#8f>yMa=Dzp# z<>PMmYi>_Hu@}Nq-xk|kaJ%dAy`{^;Mq|lHr`yYtxGsL=8TWz3#$F*5RugV_l-lcw zHa{P!_q3?V%a>XOx99CE|3+R*MeC{NS2_mLm~!%44HZg6ffan&De~|j8g$q&p-HRv z8O!kbRbZ+LM@NVeorX$fJVH~P^!@;Aa8Pxy5CSP!2v<2uEpUX{uOQS^}Gv zX?c%Fog40}lu5T=2xII{0Z&JoWJhX+_p zc}S1t$u!LvXvJ`eNELC|$rr0o_&WANt=YDoo4hG((upY+=aArFT~u=h{9)0B{qG*6 zIFP?_tp%%TdG#22aWj)oa#&MZB z=BXW`sKV2b6)m660eNZ;hhdn*90}4cSZbgULjk|A`J`rF@U}~8EHZ@nA(zMDAxMm+)cTYRGqr~X@R&jE19=KpfLQXdnI zE%J90$LovSR-`a5?Uw~v@TPX(7+vJvsAv4;JZnRqUj>O|4*Q)G8L(SRbYS&G5O zU@%Qq3CLItP>7R(8cJdh@q!Qq41pNGgCv7Uklp045S;LakOpFCxX`P)>U2P#PQwV0 zdhHQYU>pvY7f_uInUIGoR{31vy)v$lv=|GU9OR-v^bDyUGkIian5rs|%{x|8$yX*c z#SD3K4BMP6h5YdP|?n3vM{p7K%}-%U%4BlgrcCYoSiFu|0>fzm4VZLIxj0d27@4)v?m=CG z2|*vEM1Yx6fO`k~rMNr8wqx=@|?{Py$I353L2l5~+&3AJ9E{M5~78h=8`^)uP zS8^iuhRB^b;MX<|*H@1TJ^4YN)cmKDnSo&IwRq$5NBEA{cSMZmu3s}wUNw$yEX;32 z7vu8_$2PVVX*9!?pL8g}rZJqs84fGZHfCigZ>U;Es?*eRxdQcD1l7b)c_tt6{+kO~BqV%qo& z3HbK(M1r%xlQ)?LbVom%SqHZV|_bUjk&S~l-#$<-_hK=?ql%<4UM-G%2)UGhQ z4B?QBL<&q;CmQ@CPPAYHsemi!=oP-5!5E2UvgQq4*jKDLDZZg`g*a)bKxm_h!A}Wq z0_hv$clmB`ntIIZj%u5B1kaRy1o={+d-}uQLt=-Dbc3t@$u_W6ixKt5L{`A+wT%hE zjJE#)xY0}NpFRzq^r?+qqHw2C_?)`)A)~N7-?+RexKDIm{C3FSZ5z>Q=k^Z#Yl(CN z=4{uEV|n8anEDIC!@8Of{INQ3+-4lEBT(mOgO_eU28ocC)86Dblx7gZT@HszkMUt= zvgl4Nz!1nflM9s-mC5Cqq1k*XU(OX_Acj^2e^5vRa6T!9GXqP{ULVyeeUrIyw(QGIU51Yq_(oo5XwHZt>4Hu^5kccjMtP~8%e*$>k6qp;M&R{6883ciZhdlUV_RWQyfu-VoMMZD zi~+b%M6;78w1th)v0b#V^74;!7D-?#;4R>l2-acgsDW2iaXj^=o*2WM9RfSClZ&pqp?h`R*D;CItl~5Ev68lzgz5?8a1v8^%zm4`tU%J?&&1#>3r>5&1OpsWG$FgSyGTfiL!N4a_3u)>h->e}hzwLQa~5PEWXy9i*9}S~$%>IG zQi4JnN^}*LDN^&CBLNK?*0@jSzHjm2O+Fzz5GGI4JR+MMa|P3Il$p1dCFGdb(+PLL zxTbkWscpu~m?9_gP=d_X&62@$@AI&g%uo)xQV~{lDlv7f37wE%I%HTd&xZyPgV2VUcFaQ?^DLhBqMv=KAvWE@gvW8 z4)SznKN3E*mZ%xzKo}BIi`4eELMCV|P&Q?7wthdH^x^)65M7VwfNe&4^d^{n26ZV% z3dTeW5c1uV!K4C-T6@C;HS{{=zVMW`fV@;wO3BNNQ_9!4Zkg6-=>|Uu-5_RsPva1) zFec}68!;#X6C(YBJ|#Yc$uGS3qYUcc=fFG-6r#tl=~QA5WGe-_0ex|oC- zB-771BZ@M(M?58$^4L8?_>rhzHbx`m3QUzf@ns`gi6C!N@VFJz1C>u^DB08|T6yYPQN6cWP%&16j8xBE| z`+hits5d`N&x1dxs3(ky-l*SC3!V_EXm&v9#qT0J;2tP$Ei%vBq!6glkiE8aj_s5W zU`+F5G9prfc|Lwg*my1DhVaAW)UJgSH1%&R6e-xxfvPTO@y+*O>VL7oxTx8uDIPE)_Hj5~x2;tY~w+p_>8#*Otj!3-L3tRM@}6EbZoJEj(6 zq#rwQk}D3tc}}pA^sC(2GvKpThzn#rxq2_=w5cbcQOOG0s0vP~ssLxDtt(g&$#Kr1IPjviOU)($S{^%U53;#BpA%vIC3Fq#PF6KcR zo(IqbCkY|7zTG6p@(exQ;54w60S7^5Evzw0YN|Rg{uQB-i-Xl|C7zI$6%f`$p2D`# zl8!VAXt;E#Lebts$Y_a95JAQ^J2#v)7AS?AiAYY!-fM*~%oo1<()=rP(c{fOBPWi{ zyOEwVhZK8Ciw(^3qTy6{m%Y$Cfl@K3~w zPgAJ4z)N$g4P%BTx5b2@7t8B!eN`q*wVL}_^S*WU;e~&|)$p?mJi=tvVYvuC16I04mHAezZJiL5~yZJ0b&$_2zWUWmvW1Fr&2h2^w4sN3?f>BSVbD=A+~Dy0xgm$EiVnuxaGwP ztw#rYq6gT4>J?Hlip(Bo)twmhp*+6Z;LLJ~(?aRd5zp~~8FW0dts}yNUgmEGoQc)m z$9qqS_#uB8yL_#|Uy8rD;6xQfj%4ZSxp?Z-E_p)JM`i{hM(DtnBn%hi?dPT)#7t;L zr70rD3xMbje3feT1TFfU%2zlG0H-o00M?PukvD`QX65Bl33;L3ozSPu2l>qZ9M(uU z{dr&%Jmy~}WPB8*Oz_g&z99vUQJP3Zy#F2+$)K`oZn~aC0=W zoP7T_{u(^!{7102{W~HUPs*IYXXmdjXvKkx{mI2+s25Inn>!ir#l%K~C*H(-{vG&i zcpfU|ta81j;37*cnCor$+-S%=YQ<=L9?}GP+x*H%+TPgC!yx=?-(hMK$2Y(C_RAZw zPoHKg%<)Zp7)*iM6Hg_hc9v93Fs6@kE8>`IU!NNQENvvLCni+za zKpo6em8K;OLC_54GMQswkd;GvrAoLSSK1DA2kEDSJ2OWN7KGXVQ#9=iNE~}PHB-?& z&Z0X*aj^14NF0;~qk@8V{AC8KuFci>jK-k=IA9OTgl>)?3K_`3L$%r;C-^2pX~Qv+ zFx@iJAH2p8D)AN=;`+OW#v$JfB428oT6i-w$CO)KUM%5zELj&MLs4t$J5unJ4C{-Bo!I zR|oq5>jaFCZgFFxCL$#FjPQ{ngpV#p_#kW#f%6eW_}ItGXSx{WqferYjD?_l)Dp}N zME;Cs2O<|xp9jD`Y6-rm?*N0&K;ro#>Ci5GB_RkQfu}I(1c{n)SUAPK;H-y}fdD9x zx&etn@kC>$Sy$55l>kHt`l{E`fpi5Iz{Esqv7OJ52E>^lc_3k!$RY^8f;SC{-qT`V zI+IhxfrUn=;w`Y0Ox%j@lb4ep1E`t>9|Avda3G*RLxxF2lnlj7Imy6y(+s$waSI$% zzCrRqkRX~AK4hFK?6tKeX=zlbxSdikLe@dyAGrVpT44g-%!7RA6L z%(-aMl*!X5JZteK3ecKCXL5;X7RgQ#bLBF`_dNiRpo<=>LnsCm!5~SDOhR~Pnh_B` z3HJ{=E!L`fjK{pgTiIt8$_4snkzV~yNF_?x5K@V*moQ2^MoA~iaCJJ)z$3hywJKI` z?*drzuXpDN!RX5qr*nJa2s2O0GZ?zhY-`QkePNf|1HM3M_F6N5MPo>LPcaDQ+$+5R zhM(~Or-Z^h+cKaD&Djv5B<(QG9RJ-$G@-`4*(_+EG7Cf^1JR4p9su9qkwgWg;>oE1 zmI9G=P|kt2{rC#^i+*w%TKR4fF#J(KKk0tA(N9>p6~TnrcnB1V#4%y9Hk+6gpj^g7 ztcx4xvnk^whbK~#v)v+QVO$72)g>;HQ3Ge1Eg`dD*S-?)XI}~Q7lW3E1XZwBRzbpa zK%kP0vQyl!V#Qx#OGimkLet9xP*5@y$+N43edQ|wt=lF4pJK4U@1o{<7GYXFhs7e9 zEXK+Df*GtvGH!wi0o_MNL?v{KS0F!-89m9sQZ}hWIlWi}X<0(KGX5fhND1LEZ82QJ zn(_J8?i<6!tXt)Krm2Gp&jn#B>z;eUa50~-S4=>AwF?jiH18HUs=$YVTIU@@(`tj^ zVm_*K|KK9`PRKgUB9zeYkTVnBRt9k~HAd}UkZy55z)A-(Y%{{U`CbFDN-*-*AN6pn zawb33y1QVA{&O>JcFtp1X#y0oCO%U0?1FnjGg1N^10vS()yM;EtJ$#5tu=n62l^2r zFo?jHvb4Rh4=FzqKAl#Kecw(Y?UHGzZCccCneOd?br>IlbxczB3}78X-0^^QB<7CP zU?t`b>#(3TQW~Wp4Y(1b4^Zw*?UnUTc_TDCQ*%XVBK8=(%MTj<|E(M*|8{S3xOBk}aC1Ec^bJw1%X)BPq|EFovP>kWzG)4T5We)pT}NS`bLK?g7O z1_AkqZ=>OQdfZ-G4a~j)elOwV0|Jl<&qIJZs=)1$;q-8V}Wz8nt_Nr;8o+5 z9zy328J$N(M&+VMvOk(pP4nTpn-ZfVPHA*hf!iagbVvPBH1McyU>5L7x`An9bO>+g zF#JIl7|>z3x+GA~VXVrr*wQ%VjUhCmAw$dI<3`X&llGOMQCZ^%MO7FBU#9bnK;^RU&O)JvATe;1 z2no>h{ZPsvt5qH(QYN^f1q5PBc!S4h;G|U2Ee(Mq+!$V61X^dmAc2i2cqN3>Nz_Z% z2jL6aJxK?IWEzWWOdoa{+N8h9VYuck(tyY`n!!?B^Ia^}A0y+d4YX}nhET3i*%s23 z!W{Wq$rwJ2o8f|S#xbM{Vrd-7kshoPhEIs(af*@=oD_^Jb>|qUK;1cth^qD4qX^Qe z8%OCO3?I23MzM~bDjI&W!SUg4$a)w^q~%#iaorJTK@)?t9O-k zMZClv@tv%XsE`7MgJUZ(1`rUV4ym5OJr4H6MP}zX6d=_Q4h8TXIx_@i-g)n{w_YTe2H?F+9m zNYt^&jbiNTZJm}KWh!UYl4RIP$Dt7rNYWs^3Hx=24)%x~8U_+$W zdS%+7n`+ehkub5h*r*-2^)&!X(c{slnyu)ogfR7G;oLIE-CS{lkA~SmbK`y?rp%f> zyFvSsq|;P}tH^EXU-by*DW#qOkV}s{%E*go;dY@c%Y$uv3zUU?c9aTm5BXUr{!1JP z)p-O%{#Fq@GLz5Dl(WcZftKDLswx-3|D=+z75z2*-sJioe?hg( zQzf6nU4U>oQ19F8_PIU!*4XAJajAE&(Y<7(%N<}nyDom@nO1HzDAxWcb^8DkS?414 z11)OwH!j`&X)O0S@b=4>Za)jHkKZd=cP`z2T%OVGb#?pYe~jlB=;oiXZeByw2KE~m z7VYE`z|qQJ9klk`W?&E-o>!cs&IPPEkWiQ~K-Yq|em|1u z!y&gauw+ALpmZ8z-JkO7unnqQvvA^i?)-{_c#WQW{zP{%OLUfdz}z(Xi8t}px_ycO zC@ijw!s3#ktZ@1xRfuxc`Z_u~w&y0MMQYlcr*BS9-JBLC)HE9z6uYBbFM{U+2NC#O zFk=n1!pohr$Afh)xI~nrLWRYs*$<*wYaK4P)gGAc=d~})bwv|OpW-rWvm%4^X^spB(8Sf9d(GG^| z&yqwr`rYq-$U|h@rf|6q?3};ym{FdL>~clKyDom@ndZ8wYvOj12h$QRi_^tL0Chn* za8m@-)lG{fdjZt759=#?iRE_zsEe|i7vCU&uD9HM2Vm#}sH-RS)V#n*IsN?Y8|Zf~j{7cG^E6Db0=_5TSOVoa)PP zlG{yYf$3;9nT6@+%@xrS7?4+@tCE^4f-PYwN`%a9w?yt;t0ltn<-TTArwJ=fl!W9+ z1o9~0{8lz2`s^M0+f75A))G7<`%2`xW26l+ZRWaT=#48Rz(a=~DgbO=58BKee;!5* zy&+93=rcX2VJg5@?7=JySrHG(64Z%-y^ux9zr;Ap!c|~hLQ0r4x3j`ZR6bbHqk>FB zKn7Nyyg*CZ)ddic7VhLG(Dn}{+gr>T8^Kwe+u)f(#*pJ&W|X0ms#D5jq;ZtU{N(T^ zWkYiPJ6Vmk^V$kmDaA#-4gSu=yJy&v&~nDD+avp}YyaW;XK!0#5?nkh|! z-4q%IOpSY4!lTl+Ab*Voix9Z~d8dCBUw>>D)D#PC?Ma#Jgng0{@{nKs-j3zsRc4<2 z#{yzYTy?E#5^~85(2m8?u1GSr!@T91d2+qDSlWm!#1{$jcw_rKL$g8G3^FJ}iw!9a z)ei{M+vZkjP!xR+3!E)f83)M*n+XR$4ADYp>k2$>Ee}W|-$Usogxu>7Ct_xB*F4>g zftUP6P;R6~1LM>-Z=_q0vQq9$b7E>>>iaBs47i^2u!&5i2A(L*0buEPCNY?_?lCkn z;`H~A`_{JOdY%y1HkGe;3HOb)3qR}|tyF*$ObZ%FFhgp1mLgPFU$HV2F+9c+XOCz0TG!BKaQNN@%yoN*Y24)+KQV9Jv8v%Czvxk2_u zo7{wyLL&>7w!@bLa<)K{1OEs?k_&4f9SRnnh6Swnn;#=i&kI7`X>%7jv<(A0Kv9D3 zGiXLLy$pq;ygZQ#oCYRtETPVMe2>B%Jg%DirLh9iUjz?`uTwjixzXYV!G=u%_d)<3}2LuHBmv5n#QN zVx0jm6`*Z-xdF0^EN>9iC$5l3Xbs9_B$*H%d=@0f8*s%htCew1YXYHn)|!MJD*f=R zel>^q!mTU4B31{;Jb zYMN^#?4=GHUMlWs~10TlXWw&VUL?a(oFYT zv?EuENsIq@@P=>=;!?cUBSVji(HjEg5Di|seXiDHkfYs%|BP?cG%laqN&yHv3$KVE z3u6sVwyiG=z8_v!>16R`gA*W2x%Zg1MqQau;9c5Vz^jY46$sXq!4xyaln#p$`n`S_ zNw?;0fxv;!jczz&un9rX-DZa&tf)*H-ad`12<1lU1_4|}sbi|^{yrgyWID-UM5#M{ zHDM}}ugaXaSu9dA&ofZM^o-9yB{I(7r?O@l;kaNN1?nOklL~ba%-(1F%3P0kC!Q@+ z7lqn{wGkOT{n^yg_H{~F*N5%V1YoZ|sF)en8fJ#e5tKyZ%#-9415JF&01{hK`qYVWW2 zQ|UE#KhTu8p^Gf!>iw?sp5|Y1&4l~di|qrGsUCL-Yzts4!!7qwf&0j<>=&&N?qe@d z-G&A3<509dg!`iPM+x^)b>M1f2fjibh~J?D`&x?&_tb%X@1O&zUrR|_*>n8HwD>&WT0S61TzFr z>3W8r#B;2S!6fySE6>UpCWvu~Tq|Q>$3ezA0)>H_%)%Js1HyvigV1%@$a)M`f;xhQ zW;DR__CpB?-Wlqjgh~>;Gc39bwm9aC7yERSQAi!-{=teft?59Kvp6F7oN3@fgHvqC zv0VO8+O)q9`RdB)sBG8}rAe?^rK4s&KniOKpI*O*D5_mPBd*+(x zs}_J~WPXx>xgt{rce&5QZ;o9{0H!mDrd->)^Vy8EIOWOtCnbWye8u96Df^;SLApxkza5g3LO>UJ?i zV2U6D0T&32z!H$c2s3b(0t{umu)fXTU2Fc1(b&gnNuEC(LM!TQO-wouXnnMHdea6I z2B-CyGr?y1$`x}a$C+`7m~%Qb&VndJkOv~B94tg)YOoOD&tT!bXX=8&?f2J=6Z0rg zGpVQG7=RZe1`&V}rS)#Qf(-n3J|#1Qe3Uz}7FtrKxHv?U_Dez}X>Lru8^cElA*5Nj z-YEzYNAPTdOOpFX2AHG)e8BKcNOh?A2$=K(!DxBBY(4MWelhde&4t|OrG z5VYdoUu#|gTJdiywBkJL74f&8T6E(|sR#!ij+0hVY6m~wz4^*o^Y=a2;pRVu+6hT! zJ9R0&!Iq^e5CN&Eb&0gC7A+Gy0fwXUpx42monwWL822JKo!K&2i0A#zq6_|Ra+xt#&1fO5-ex|n2 zDQGsM%SvqeOd4E4_t+S)O`85tlP0o^(6?pO;0wJ=Mvd={J=_9=&vqPIEei)|Ko zn-im*WF+A_!d?+S^31YVT17w^cVQ990M=l{Hes-^5wUOc>RR)X+#97Y+WZ2qx)_LU z{zGN3bjyXl9H)4s;ikwUkv2*<+b9HNOqPl^PZF?&4s8C1wdM`EVq+lM{2Vw6avc2} z1skhPy95Y1dkjmeEO(E`IA~)XgFl#@BaN&X;}RPo@KgtRM`)%Qe8j;!e}KTpv~f&3 zOCy8jl!9f5UE%Fi2OrT(y#f9b#Y_}rkhWk5?TfSkqXhh1a~ur5Hb4-LFxk&mk&;bq zqYZ?IlG2`wh`lC1ByeD}zuL=$xG=@n3EwnGCR}D^|ACqauJ#884s3Q>4YDuePz|!@ zj#8*_JmM=azQ3s98MkZ6C}_egng?>F`|*j5PN%HV%sX}OgS5V`_W=ofMs zh-yGgLGIM3%R4KVK^DtM&>TPv-$XY-^ij-Xd-lc%W0MX?EJ0t6~gn9YDy9N&qIxmp5imKc8{RqLvW zMW?6VN`7F+!VL!C_)z4v#n{zDwVuUDEzZejZFD@B2;)X`za>{913Xu9geU=92o$Yc)N+MjpBA2cJX+z06MU_e z%kv*RK4Q+ZW|Fus>|`tMF1lVQ=R=OcTPB z_E*5EU`TmSEuhWnedWs2>D!r+{S`>h4r&I-YO}a~SjNc~_J$2zQ3tdkonsyjBS8^e zKXFQD16GnMX9E_3NKzAWg@C;!G!W@M+N}VurZpi6pwO%SPJj$ulq4&t(ELmCT;&cL z37TL8vR0p;gpx6^BTE_Ut>iXF@;-|<@(a=*y|@(f5LzxTD}{vYhyrMhD!5xE%F?)} z#A0|G^ydirTk|4NMebHPh8`X&7~AJ#P%zj>r*er?(Ou}NwLEl5tR<>0SM+2JKdka( zU9HOeV!oaKm`g&JufFftwPmsRb4SFiXd@=pcZM(f0SKKfC@Ec^wyLn!Y|>H&Q{M?A z;n1lA5f+?JV7w@_{55H4-%>M1x;nS79d1Zku$h1ibs!>e7m@)}P%OS&SgN{Z+NVfO z2S(Du%+XVVgsYk>m>#+Z(Az12?fw^9hV@esWY`ujeyUkEa zh_Rd?NI3Wm#u&7*&AdgNZPYKpGATJn#(F44U3_(K5|jGk4KJs0g!3>_7c12FxTc(Q zIAn7_$S7@i{}l;Bk)_XNDl(kMqB?33*q;IW-&8mxUBPR?B0AE&`Ng&7 z%U-e5zkh?6 zpVk(z&m8u;CQ|RLr9xZh)s`vDHk*#nd3LZFnqy0t6a`%fb@1t(esvINlZjfY78e@b z10nWqi7Z<|Q~+87N(U32ZSQv3_AXo?!rldPC{~zOT?e|2!Li609ax96we)3cJdG(S zyr70%9J-INA3YMtL)K71$00)t0FZk4#I7^a%j$HzNhv@f#;^hNn5^tHtkRDf$4`>5 zc?i3X17RzHjODMpU5(gR0WB3Nkg3~s1Ats{fHT4(R(HiV=iRQS_AdG?-QBKOl~)%( z@=P-a4Y?@x4oAlGODx&YAWU7id!9^PaSd3Y2{LsFqr}#74d!csVx*zF7=lBax?nTD za!=MkG8mUw)`TvHzygJ!1c9Ur7Q)su#7Y~Bm2fmHqLIP^D;$)tAedz%y%zk%n`GuB zzLP=vUYJ%&{PL^v;;4%mpUbG^9i`1p~{u{?%Fzg zVO0?Cj*(dUL8^jby;q80o4h>LOG^*@Prlv0eR|-p8~U4Z=qZ2Mo$EJ@@_R_dd(BS7 z)7oN|5@bq*?k^n4YUb+biI@p++PhCr;&-37}feO)X3lqK1Usgv zDQFIxu}_aAe(aSY(Y0l-OmN%uE`UxL|aE`{9eGIl;X?QMA^^hmAZ-R*o*Scm+8X(;A4JEu5#i**y8@qyrHV513M zgkXg;$?}?VOH;Y31Dgw~jJuRC=c<&R2*XgBmdGizc>*kRy8t0Ey8wPzfiH@EltA<5 z1{iHtV36z9+;fNk@gyq{gAO;Xz#YH_3-V6C{RbGU z*il490V*J66mX%~9Y%;$@gCN=-H#4xDDjkL&cowPI1EL1)Q@!;jg(JU_5d@IBQ9IB zAVWIs*^w3*QFt|IMap^X^$#~8y6Z)1(A_*jLedtn*N2>FTpcuw!DJ*l&mZv#{wt34 z^kyVNb5SM?BSVq%G(UW9U$N5spdJ}lNb?I#UBx^O%5u}qjgO7lAgMOwYhy*S($PTc zzRyQ7y?_#+2%eWX6rMmvMXoqVOLFGma4M41X%JIzoEDT17O)PR&Hz=Jrz@CYa?>%| zYi0(R${7Cg0-)Qd7ts6+zd1gQG~9u&^V0}pKbU-ad+zdqoQP6&d`ligUy%pfuE~QP z*OLI^lRT8y3RJ)s4xCLzM?84Uz zbMrG38{20S@z&~fH-Wtu`lj=4N|m{Z>u&1W^eg#q0pU6V6b{!xkG|A$`%7TD zeXq1^D4MpOX}GJkhq^6szu4W;@qjdciNrso=va~XE=A%Uio~PW716(%{B&oK);qo@ ziM&T9e1Jl2GF)~YY$8|h+MAzF_CJi>Ld0s4kGTVw815ltZIrIQ;KnbX2C0?+{tjY| zX<|i~1&J6S)_MvX&Rw2aeX1UB<~*wVO-vWJ|LrT^Fvza?%aQsaAjp6yzljF$*p)A0 z3pQ>S8;3N1p)_~v%Wk|t)SjOEX5kwP^F>A5tH)m{f!=%FIQ|0up5Uw0wbHlT_$zMr zt8VJL+jZ^I-~H{})kh0g5Bli4Nc6ox^gU1XJx2>&3Rvd?BBw+SlgMETd1QCOLH34s zb{so5*+fk$gF=1H!WTvPh{mdnEZBIvRUzhVQPdrTq$HiiSEpD$VzeSR0W(S<_wA>c z-fas@TSAKL4TjtCD1jteE0a3r8kc)tkIuc`G57j5wLnp#9+12 zRbzh3&1d!7-IcYez8cFQq-Y^5x9RE}W|bP4EY z)#?eTFQg+@&E!|NjM55jDKF(7e>`}_85lU^eE7poXMg45Gv_ayJ9%NndG_o%=fWq> z4mQ@FUpaGr?d+M88_t?ibl+&4n6zHN4fUOa;fO%rk9tTPpn;7J$vzj0~pRl)LdO%dC@s__W2hsq8}S) zPd1zj=mbj6oWF4L%!TuhIw#LGoaZl|zd(1Pt83?Qh^|~%rIU@7q5e*EVWw1Zo)kvL zkdX=OmWNo8;T1pO*O6d-hpUqE=#Ea%k9f&`_smLT&>J9!#(+9N!bd((8xox%9x+Je zdgFEDF8|)GtYRr**T#tX1b=U=Z$^)*W`nRplyPI;ZlcIpwOb0HRgncCYu4q(-poP; zacNbqS6i94D*MAMldK2Iq16XbOp2gmRqS(>ThGwlV&0n#@X{wyY}KUJR@r*4RiV1Y zxBSYiU1aAgy6Eh$e&Vb_7>X_og0$#@$~9dOrN~Wo%~>0u5u-N4_%ur`8Zj?u8Zk>P z8Zj@}G-6({XvDl=kNRqs9fRTrUn_lI#SV?=P=C zw|W6w_e|sLC!A-`oL59io^G*|&wW*gcz|_lYZo?F+O@~t0%iN^HkA*@dM~fW%O*34edbI(5$gJuhEt$bp`AP^vFKWsiUZKM}5cNY;-KLXKil&cNf#ZZ*%m+vv0^ z9$0drBIV22P&f3K-cD37Fu)>0*8#_adGj> zVjA;!lJ2XlMm5#$SGR( Date: Sun, 21 Feb 2021 13:41:15 -0800 Subject: [PATCH 10/31] PRETTY: Fix PRINTCOPYRIGHT1 to avoid line overflow --- sources/PRETTY | 2 +- sources/PRETTY.LCOM | Bin 30039 -> 30075 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/sources/PRETTY b/sources/PRETTY index 82e15fa7..4caf08e6 100644 --- a/sources/PRETTY +++ b/sources/PRETTY @@ -1 +1 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Apr-2018 21:37:09" {DSK}kaplan>Local>medley3.5>lispcore>sources>PRETTY.;6 56513 changes to%: (FNS PRINTDEF1) previous date%: "16-Apr-2018 10:21:19" {DSK}kaplan>Local>medley3.5>lispcore>sources>PRETTY.;5) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1984 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance with the terms of said license. ") (PRETTYCOMPRINT PRETTYCOMS) (RPAQQ PRETTYCOMS [(FNS PRETTYDEF PRETTYDEFCOMS PRETTYDEF0 PRETTYDEF1 PRINTDATE PRINTDATE1 PRINTFNS PRETTYCOM PRETTYVAR PRETTYVAR1 PRETTYCOM1 ENDFILE MAKEDEFLIST PP PP* PPT PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 PRETTYPRINT3 PRINTDEF1 SUPERPRINTEQ SUPERPRINTGETPROP CHANGEFONT) (FNS READARRAY PRINTARRAY READARRAY-FROM-LIST PRINTARRAY-TO-LIST) (COMS (DECLARE%: DONTCOPY (MACROS CHANGFONT))) (COMS (* ; "COPYRIGHT") (FNS PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT) (BLOCKS (NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T) (NOLINKFNS PRINTCOPYRIGHT1))) (GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER COPYRIGHTSRESERVED) (INITVARS (COPYRIGHTFLG) (DEFAULTCOPYRIGHTOWNER) (COPYRIGHTPRETTYFLG T) (COPYRIGHTOWNERS) [DEFAULTCOPYRIGHTKEYLST '((NONE " " EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN 'NONE) [%[ "owner: " EXPLAINSTRING "[ - new copyright owner -- type one line of text" NOECHOFLG T KEYLST (( " " RETURN (SUBSTRING (CADR ANSWER) 2 -2] (%] "No copyright notice now " EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL] (COPYRIGHTSRESERVED T) (*NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (*DEFAULT-MAKEFILE-ENVIRONMENT*)) (GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG *DEFAULT-MAKEFILE-ENVIRONMENT* *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*)) (INITVARS (COMMENTFLG '*) (**COMMENT**FLG '" **COMMENT** ") (PRETTYFLG T) (%#RPARS 4) (CLISPIFYPRETTYFLG) (PRETTYTRANFLG) (FONTCHANGEFLG) (CHANGECHARTABSTR) (PRETTYTABFLG T) (DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST)) (AVERAGEVARLENGTH 4) (AVERAGEFNLENGTH 5) (%#CAREFULCOLUMNS 0) (CHANGECHAR '%|) (ENDLINEUSERFN)) [INITVARS (PRETTYDEFMACROS) (PRETTYPRINTMACROS) (PRETTYEQUIVLST) (PRETTYPRINTYPEMACROS) (FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *)) (SYSPROPS '(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS AMAC ARGNAMES BLKLIBRARYDEF BROADSCOPE CLISPCLASS CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE EDIT-SAVE EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP FILEHISTORY FILEMAP FILETYPE GLOBALVAR HISTORY I.S.OPR I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS OLDVALUE OPD SETFN SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET TRYHARDER] (BLOCKS (PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT) (SPECVARS FNSLST FILEFLG))) (GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG PRETTYHEADER FILERDTBL PRETTYEQUIVLST PRETTYTRANFLG CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS COMMENTFLG) [DECLARE%: EVAL@COMPILE DOCOPY (P (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT LAMBDAFONT PRETTYCOMFONT COMMENTFONT **COMMENT**FLG PRETTYPRINTMACROS] (DECLARE%: DOEVAL@COMPILE DONTCOPY (* ;  "IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES") (FILES (IMPORT) FILEPKG)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPT PP* PP) (NLAML) (LAMA]) (DEFINEQ (PRETTYDEF (LAMBDA (PRTTYFNS PRTTYFILE PRTTYCOMS REPRINTFNS SOURCEFILE CHANGES) (* ; "Edited 16-Feb-88 11:46 by raf") (DECLARE (SPECVARS PRTTYFILE REPRINTFNS SOURCEFILE CHANGES)) (RESETLST (RESETSAVE (RESETUNDO) (QUOTE (AND RESETSTATE (RESETUNDO OLDVALUE)))) (* ;; "Says undo everything if there is an error or control-D This is particularly necessary if user is using the PRINT* prettyprintmacro which updates comments to point to the newest version.") (PROG ((NEWFILEMAP (AND BUILDMAPFLG (LIST NIL))) (%#RPARS %#RPARS) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) FILEFLG FNSLST PRTTYTEM PRETTYCOMSLST PRTTYSPELLFLG OLDFILEMAP MAPADR NLAMALST NLAMLST LAMALST LAM?LST FILEDATES ORIGFLG ROOTNAME DESTINATIONENV SOURCEFILENV SOURCEFC FCLOCATION) (DECLARE (SPECVARS *PRINT-ARRAY* XCL:*PRINT-STRUCTURE* *PRINT-LEVEL* *PRINT-LENGTH* NEWFILEMAP ORIGFLG FILEFLG NLAMALST PRTTYSPELLFLG PRETTYCOMSLST PRTTYCOMS LAM?LST FNSLST OLDFILEMAP LAMALST MAPADR ORIGFLG NLAMLST DESTINATIONENV SOURCEFILENV %#RPARS)) (* ; "NEWFILEMAP corresponds to the map being built for the file being written. OLDFILEMAP corresponds to the map that exists for SOURCEFILE, if any.") (COND ((OR (NULL (\DTEST PRTTYFILE (QUOTE LITATOM))) (EQ PRTTYFILE T)) (* ; "we no longer support any of the crufty alternatives to writing a brand new file") (\ILLEGAL.ARG PRTTYFILE))) (SETQ ROOTNAME (ROOTFILENAME PRTTYFILE)) (if (OR (EQ SOURCEFILE T) (AND REPRINTFNS (NULL SOURCEFILE))) then (* ;; "SOURCEFILE plays the role of CFILE for recompiling. It permits PRETTYPRINT to obtain the definitions from the file withou having to reprettyprint them, or even having them loaded into core. T (or NIL if REPRINTFNS is specified) is the same as PRETTYFILE.") (* ;; "REPRINTFNS specifies those functions to be printed anew. REPRINTFNS=T means reprint all EXPRS, a la recompile. For example, if you have an entire file loaded in, but only change a few functions, using this option can speed up dumping the file by a factor of two. If REPRINTFNS=ALL, all functions that contain in core exprs, whether on function definition cell or property lists, are reprinted. REPRINTFNS can also be a list. MAKEFILE uses this for the REMAKE option by specifying as REPRINTFNS the list CHANGES. In any case, if the function does not contain an in core defnition, prettyprint will try to find one on the file. i.e., act as though REPRINTFNS were NIL.") (SETQ SOURCEFILE ROOTNAME)) (if (SETQ DESTINATIONENV (GET ROOTNAME (QUOTE MAKEFILE-ENVIRONMENT))) then (* ; "use this explicit environment. Copy it in case user later on destructively edits it") (SETQ DESTINATIONENV (\DO-DEFINE-FILE-INFO NIL (COPY DESTINATIONENV))) else (* ; "see if we already know the environment of the source") (CL:MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP SOURCEFC) (LOOKUP-ENVIRONMENT-AND-FILEMAP (OR SOURCEFILE ROOTNAME) (OR (NULL SOURCEFILE) (EQ SOURCEFILE ROOTNAME))))) (if SOURCEFILE then (if (NULL (NLSETQ (SETQ SOURCEFILE (OPENSTREAM SOURCEFILE (QUOTE INPUT))))) then (* ; "can't find file to reprint from.") (* ; "OPENSTREAM is called in order that 'correction' take place.") (SETQ SOURCEFILE NIL) (PRIN1 PRTTYFILE T) (PRIN1 (QUOTE " not found, so it will be written anew. ") T) elseif (RANDACCESSP SOURCEFILE) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) SOURCEFILE)) (RESETSAVE (INPUT SOURCEFILE)) (if (EQ REPRINTFNS (QUOTE EXPRS)) then (SETQ REPRINTFNS T) elseif (EQ REPRINTFNS (QUOTE CHANGES)) then (SETQ REPRINTFNS (UNION (FILEPKG.CHANGEDFNS CHANGES) (FILEPKG.CHANGEDFNS (fetch FILECHANGES of ROOTNAME))))) (if (NULL SOURCEFILENV) then (* ; "if we didn't have environment cached, look it up from the actual stream now") (CL:MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP SOURCEFC) (GET-ENVIRONMENT-AND-FILEMAP SOURCEFILE))) (if (NULL OLDFILEMAP) then (* ; "no map on file, so we will build one as needed") (SETFILEPTR SOURCEFILE (OR SOURCEFC 0)) elseif (NULL (CAR OLDFILEMAP)) then (* ; "complete map.") elseif (LISTP (CAR OLDFILEMAP)) then (* ; "only partial map built up. should only happen for files that were made with BUILDMAPFLG=NIL, since otherwise there would be a coplete map on the file.") (SETFILEPTR SOURCEFILE (CAAR OLDFILEMAP)) else (* ; "Redundancy check. Should only occur if there was a compiled function in the file. and a partial map was formed that stopped after that function.") (HELP)) else (* ; "Can't copy from non-randaccessp source") (SETQ SOURCEFILE NIL))) (* ;; "Now figure out what environment to write the new file in.") (if DESTINATIONENV then (* ; "have explicit env, ok") elseif SOURCEFILENV then (* ; "use same as source") (SETQ DESTINATIONENV (if (EQUAL-READER-ENVIRONMENT SOURCEFILENV *OLD-INTERLISP-READ-ENVIRONMENT*) then (* ; "write the new style") (\DO-DEFINE-FILE-INFO NIL *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*) else (* ; "use same env on new file as old") SOURCEFILENV)) else (* ; "new file, use default") (SETQ DESTINATIONENV (\DO-DEFINE-FILE-INFO NIL (COPY *DEFAULT-MAKEFILE-ENVIRONMENT*)))) (if (NULL SOURCEFILE) then (* ; "get rid of anything we knew about source") (SETQ OLDFILEMAP NIL) (SETQ SOURCEFC NIL) (SETQ SOURCEFILENV NIL) elseif (AND SOURCEFILENV (EQUAL-READER-ENVIRONMENT SOURCEFILENV DESTINATIONENV)) then (* ; "source and destination compatible, so we won't need to worry about it in PRETTYPRINT1/2") (SETQ SOURCEFILENV NIL)) (RESETSAVE NIL (LIST (FUNCTION PRETTYDEF0) (SETQ PRTTYFILE (OPENSTREAM PRTTYFILE (QUOTE OUTPUT))))) (* ; "Cleans up by closing and deleting file if aborted.") (RESETSAVE (OUTPUT PRTTYFILE)) (PRINT-READER-ENVIRONMENT DESTINATIONENV) (SETQ FCLOCATION (GETFILEPTR PRTTYFILE)) (WITH-READER-ENVIRONMENT DESTINATIONENV (if (NOT (SYNTAXP (CHARCODE "[") (QUOTE LEFTBRACKET))) then (* ; "can't use brackets on this read table") (SETQ %#RPARS NIL)) (SETQ FILEDATES (PRINTDATE PRTTYFILE CHANGES)) (AND (NEQ COPYRIGHTFLG (QUOTE NEVER)) ROOTNAME (PRINTCOPYRIGHT ROOTNAME)) (SETQ FILEFLG T) (SETQ CHANGES (FILEPKG.CHANGEDFNS CHANGES)) (* ; "Used freely by PRETTYPRINT to decide clispifying.") (if (NOT (RANDACCESSP PRTTYFILE)) then (* ; "No point building a map, since we won't be able to go back to the start to point at it") (SETQ NEWFILEMAP NIL)) (if FONTCHANGEFLG then (* ; "this is expensive in that it costs as many conses as there are functions, but you can afford it for a makefile.") (SETQ FNSLST (OR (for FL in (GETPROP ROOTNAME (QUOTE FILEGROUP)) when (fetch FILEPROP of FL) join (FILEFNSLST FL)) (FILEFNSLST ROOTNAME)))) (if (OR (LISTP PRTTYFNS) (LISTP (GETTOPVAL PRTTYFNS))) then (* ; "Ancient cruft from before the days of MAKEFILE.") (PRINTFNS PRTTYFNS T) (PRETTYCOM PRTTYFNS T)) (if (SETQ PRETTYCOMSLST (OR (LISTP PRTTYCOMS) (AND (LITATOM PRTTYCOMS) (LISTP (GETTOPVAL PRTTYCOMS))))) then (PRETTYCOM PRTTYCOMS T) (* ; "PRTTYCOMS is just like the argument to a COMS command. see comment in prettycom1") (for L on PRETTYCOMSLST do (PRETTYCOM (CAR L) NIL L)) (* ; "The original value of PRTTYCOMS is saved so that it can be rewritten if a spelling correction occurs. The list PRTTYCOMSLST is searched by PRETTYCOM1 for * commands to see if the variable has be dumped out as well.")) (if (PRETTYDEF1) then (* ; "The coms were reprinted by PRETTYDEF1 due to a change to nlama and or nlaml") elseif PRTTYSPELLFLG then (* ; "A correction on prettycoms was performed, so dump it out aain to get the corrected version on the file.") (PRETTYCOM PRTTYCOMS T)) (if (NEQ COPYRIGHTFLG (QUOTE NEVER)) then (SAVECOPYRIGHT ROOTNAME)) (if NEWFILEMAP then (PRIN1 "(") (PRIN2 (QUOTE DECLARE%:)) (SPACES 1) (PRIN2 (QUOTE DONTCOPY)) (TERPRI) (SPACES 2) (for ADR in MAPADR do (SETQ PRTTYTEM (GETFILEPTR PRTTYFILE)) (SETFILEPTR PRTTYFILE ADR) (* ; "Write the current file positon into the filecreated expression, and then restores the file pointer.") (PRIN2 PRTTYTEM) (SETFILEPTR PRTTYFILE PRTTYTEM)) (PRIN2 (LIST (QUOTE FILEMAP) NEWFILEMAP)) (* ; "printed instead of prettyprinted, so wont take up two pages of listing.") (PRIN1 (QUOTE ") ")) (PUTFILEMAP (FULLNAME PRTTYFILE) NEWFILEMAP NIL DESTINATIONENV NIL FCLOCATION) (* ; "Also save map, so can be used for subsequent makefiles.")) (ENDFILE PRTTYFILE) (if (AND FILEDATES ROOTNAME) then (/replace FILEDATES of ROOTNAME with FILEDATES))) (RETURN (FULLNAME PRTTYFILE))))) ) (PRETTYDEFCOMS (LAMBDA (PRTTYCOMS FNSLST) (* ; "Edited 19-Aug-88 16:07 by raf") (DECLARE (SPECVARS FNSLST)) (PROG ((%#RPARS %#RPARS) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) BUILDMAPFLG PRTTYSPELLFLG ORIGFLG SOURCEFILE) (DECLARE (SPECVARS *PRINT-ARRAY* XCL:*PRINT-STRUCTURE* *PRINT-LEVEL* *PRINT-LENGTH* BUILDMAPFLG NEWFILEMAP ORIGFLG PRTTYSPELLFLG LAM?LST ORIGFLG SOURCEFILE %#RPARS)) (if (NOT (SYNTAXP (CHARCODE "[") (QUOTE LEFTBRACKET))) then (* ; "can't use brackets on this read table") (SETQ %#RPARS NIL)) (for L on (OR (LISTP PRTTYCOMS) (AND (LITATOM PRTTYCOMS) (LISTP (GETTOPVAL PRTTYCOMS)))) do (PRETTYCOM (CAR L) NIL L)))) ) (PRETTYDEF0 (LAMBDA (MADEFILE) (* bvm%: " 2-Aug-86 16:24") (* ;; "Cleans up after prettydef in case of control-d.") (COND ((OPENP MADEFILE (QUOTE OUTPUT)) (DELFILE (CLOSEF MADEFILE))))) ) (PRETTYDEF1 (LAMBDA NIL (* wt%: " 9-SEP-78 16:05") (* ; "Updates the DECLARE: for NLAMA/NLAML") (PROG (PRTTYCOM PRTTYTEM PRTTYNEW) (COND ((NULL (SOME PRETTYCOMSLST (FUNCTION (LAMBDA (X) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (SETQ PRTTYTEM (MEMB (QUOTE COMPILERVARS) (SETQ PRTTYCOM X))) (EQ (CAAR (SETQ PRTTYTEM (CDR PRTTYTEM))) (QUOTE ADDVARS))))))) (AND (NULL NLAMALST) (NULL NLAMLST) (NULL LAMALST) (RETURN NIL)) (* ;; "If thee is no DECLARE: and no nlambdas, dont bother to add any. note tha if thee is IS a DECLARE:, then we must check even if there are no nlambdas, because consider what happens when user changes the only nlambda to a lambda must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NLAMALST NLAMLST LAMALST)) (LIST NLAMALST NLAMLST LAMALST) (QUOTE (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA . NLAMALST) (NLAML . NLAMLST) (LAMA . LAMALST)))))) (COND ((AND (LISTP PRETTYCOMSLST) (NLISTP PRTTYCOMS)) (/NCONC1 PRETTYCOMSLST PRTTYCOM) (PRETTYCOM PRTTYCOMS T)))) ((NOT (EQUAL (CAR PRTTYTEM) (SETQ PRTTYNEW (LIST (QUOTE ADDVARS) (CONS (QUOTE NLAMA) (UNION NLAMALST (INTERSECTION LAM?LST (CDADAR PRTTYTEM)))) (CONS (QUOTE NLAML) (UNION NLAMLST (INTERSECTION LAM?LST (CDR (CADDAR PRTTYTEM))))) (CONS (QUOTE LAMA) (UNION LAMALST (INTERSECTION LAM?LST (CDR (CADDDR (CAR PRTTYTEM)))))))))) (* ;; "The reason for the unions and intersections is that prettydef simply may not know the fntyps of some of the functions in the file, namely those on lam?lst, and theefore tese should not be removed from NLAMA and NLAML if they are there from a previous makefile.") (/RPLACA PRTTYTEM PRTTYNEW) (AND (NLISTP PRTTYCOMS) (PRETTYCOM PRTTYCOMS T))) (T (RETURN NIL))) (PRETTYCOM PRTTYCOM) (RETURN T))) ) (PRINTDATE (LAMBDA (OUTSTREAM CHANGES) (* bvm%: " 1-Aug-86 15:51") (* ;;; "assumes that OUTSTREAM is a file open for output, and prints the date information for that file on it") (PROG ((DAT (DATE)) (ROOTNAME (ROOTFILENAME OUTSTREAM)) PREVPAIR FILEDATES) (if FILEPKGFLG then (if ROOTNAME then (/replace FILECHANGES of ROOTNAME with (SETQ CHANGES (FILEPKG.MERGECHANGES CHANGES (fetch FILECHANGES of ROOTNAME))))) (* ;; "The reason for the order of arguments in UNION is so that the changes will be listed in roughly the order made.") (SETQ FILEDATES (CONS (create FILEDATEPAIR FILEDATE _ DAT DATEFILENAME _ (FULLNAME OUTSTREAM)) (SETQ PREVPAIR (LAST (fetch FILEDATES of ROOTNAME))))) (* ;;; "Right now, FILEDATES simply keeps latest version and date, and original version and date. Latter for integrity checks on makefile remake, as described in filepackage. Note that don't want to change FILEDATES property until PRETTDEF completes. In case of control-d, the file will be deleted automatically.")) (PRINTDATE1 OUTSTREAM CHANGES DAT (fetch FILEDATE of (CAR PREVPAIR)) (fetch DATEFILENAME of (CAR PREVPAIR))) (* ; "PRINTDATE1 does the actual printing. It is a separate function so that it can be advised.") (RETURN FILEDATES))) ) (PRINTDATE1 (LAMBDA (OUTSTREAM CHANGES DAT PREVDATE PREVERS TERMINATING.STRING) (* bvm%: "18-Sep-86 19:08") (* ;;; "does the printing for PRINTDATE") (printout OUTSTREAM .FONT DEFAULTFONT "(" |.P2| (QUOTE FILECREATED) %, |.P2| DAT %, .FONT LAMBDAFONT |.P2| (FULLNAME OUTSTREAM) .FONT DEFAULTFONT) (* ;; "note that CHANGEFONT checks for FONTCHANGEFLG explicitly so that it won't do anything if FONTCHANGEFLG is NIL") (if (AND BUILDMAPFLG (NOT (DISPLAYP OUTSTREAM))) then (push MAPADR (ADD1 (GETFILEPTR OUTSTREAM))) (PRIN3 " " OUTSTREAM) (* ;; "The address of where the map begins will be stored in this slot. 8 spaces left because when radix is 8, can overflow seven spaces by a file of 300000 characters (Alice did it). The push is because of a feature no longer used where there could be two FILECREATED expressions at the head of a file font")) (if FILEPKGFLG then (if CHANGES then (printout OUTSTREAM T T 6 |.P2| (QUOTE changes) %, |.P2| (QUOTE to%:) %,, .PPVTL CHANGES)) (if PREVDATE then (printout OUTSTREAM T T 6 |.P2| (QUOTE previous) %, |.P2| (QUOTE date%:) %, |.P2| PREVDATE) (if PREVERS then (printout OUTSTREAM %, |.P2| PREVERS)))) (PRIN1 (OR TERMINATING.STRING ") ") OUTSTREAM))) (PRINTFNS (LAMBDA (X PRETTYDEFLG) (* lmm "13-OCT-82 16:44") (* ; "prettydeflg=T when called from prettydef.") (AND X (PROG (FNADRLST) (COND ((AND PRETTYDEFLG NEWFILEMAP) (SETQ FNADRLST (TCONC NIL (GETFILEPTR PRTTYFILE))) (TCONC FNADRLST NIL) (NCONC1 NEWFILEMAP (CAR FNADRLST)))) (PRIN1 (QUOTE %()) (PRINT (QUOTE DEFINEQ)) (PRETTYPRINT X (AND PRETTYDEFLG (OR FNADRLST T)) FNSLST) (* ; "FNSLST bound in prettydef to list of functions on this file. used for font stuff.") (PRIN1 (QUOTE %))) (AND FNADRLST (RPLACA (CDAR FNADRLST) (GETFILEPTR PRTTYFILE))) (TERPRI)))) ) (PRETTYCOM (LAMBDA (PRTTYCOM PRTTYFLG PRETTYCOMSTAIL) (* ; "Edited 14-Apr-88 18:26 by bvm") (PROG (PRTTYTEM) (COND ((NULL PRTTYCOM) (* ; "So that RECOMPILE and BRECOMPILE do not have to check before calling PRETTYCOM.") (RETURN)) ((AND PRTTYFLG (NEQ PRTTYFILE T)) (PRINT (COND (LISPXPRINTFLG (* ;; "PRETTYCOMPRINT is an nlambda that does a lispxprint, except when prettyheader is NIL, in hich case it does nothing.") (LIST (QUOTE PRETTYCOMPRINT) PRTTYCOM)) (T (LIST (QUOTE PRINT) (LIST (QUOTE QUOTE) PRTTYCOM) T T)))))) (COND ((LITATOM PRTTYCOM) (COND ((AND (NULL PRTTYFLG) (NOT (BOUNDP PRTTYCOM)) DWIMFLG (SETQ PRTTYTEM (FIXSPELL PRTTYCOM 70 USERWORDS T PRETTYCOMSTAIL (FUNCTION BOUNDP))) (SETQ PRTTYSPELLFLG T)) (SETQ PRTTYCOM PRTTYTEM))) (PRETTYVAR PRTTYCOM PRTTYFLG) (* ;; "FNS and VARS are printed as (RPAQQ atom value T) so that LOAD ALLPROP will still stre them in the value cell.") (RETURN PRTTYCOM)) (PRTTYFLG (* ; "PRETTYDEF called with a list for FNS or VARS,") (RETURN PRTTYCOM))) TOP (COND ((AND (NULL ORIGFLG) (SETQ PRTTYTEM (fetch (FILEPKGCOM MACRO) of (CAR PRTTYCOM)))) (for X on (SUBPAIR (CAR PRTTYTEM) (PRETTYCOM1 PRTTYCOM T T) (CDR PRTTYTEM)) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X)))) (T (SELECTQ (CAR PRTTYCOM) (FNS (PROG (PRTTYSPELLFLG) (PRINTFNS (PRETTYCOM1 PRTTYCOM T T) (NOT (NULL PRETTYCOMSTAIL))) (AND PRTTYSPELLFLG (EQ (CADR PRTTYCOM) (QUOTE *)) (LITATOM (SETQ PRTTYTEM (CADDR PRTTYCOM))) (PRETTYCOM PRTTYTEM)) (* ; "The FNSlst had an error in it that was corrected."))) ((VARS ARRAY) (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR X))) (DECLARE%: (* ;; "Normally, expressions appearing in a symbolic file are (1) evaluated upon loading the file, (2) not evaluated when compiling the file, and (3) copied to the compile file. DECLARE: can be used to change state around any PRETTYCOM. The atomic symbols DONTCOPY, DOCOPY, DONTEVAL@COMPILE, DOEVAL@COMPILE, DONTEVAL@LOAD, and DOEVAL@LOAD have the obvious meaning. DECLARE: eliminates the pretty commands DECLARE, COMPROP, COMPROP*, PD, PC, and PC*. DECLARE: is defined as a functionthat evaluates all list expressions except when under a DONTEVAL@LOAD state.") (PRIN1 "(") (PRIN2 (QUOTE DECLARE%:)) (SPACES 1) (for LST on (PRETTYCOM1 PRTTYCOM T T) do (COND ((NLISTP (CAR LST)) (COND ((NOT (MEMB (CAR LST) DECLARETAGSLST)) (COND ((AND DWIMFLG (FIXSPELL (CAR LST) 70 DECLARETAGSLST T LST)) (SETQ PRTTYSPELLFLG T)) (T (GO ERROR))))) (PRIN2 (CAR LST)) (SPACES 1)) (T (TERPRI) (PRETTYCOM (CAR LST) NIL LST))) (SELECTQ (CAR LST) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (COND ((SETQ LST (CDR LST)) (PRINTDEF (CAR LST)) (SPACES 1)))) NIL)) (PRIN1 (QUOTE ") "))) ((CL:EVAL-WHEN) (* ;; "Has the syntax (EVAL-WHEN (times ...) coms ...). Dumps an EVAL-WHEN form on the file containing whatever is dumped by the given COMS.") (CL:ASSERT (AND (CL:CONSP (CADR PRTTYCOM)) (CL:SUBSETP (CADR PRTTYCOM) (QUOTE (EVAL CL:EVAL COMPILE CL:COMPILE LOAD CL:LOAD)))) NIL "The first argument to the ~S command must be a list of times") (CL:FORMAT T "(~S ~S" (QUOTE CL:EVAL-WHEN) (CADR PRTTYCOM)) (for LST on (PRETTYCOM1 (CDR PRTTYCOM) T NIL) do (CL:TERPRI) (PRETTYCOM (CAR LST) NIL LST)) (CL:FORMAT T "~&)~%%")) ((SPECVARS LOCALVARS GLOBALVARS) (SETQ PRTTYTEM (CONS (CAR PRTTYCOM) (PRETTYCOM1 PRTTYCOM T T))) (PRIN1 "(") (MAPRINT (QUOTE (DECLARE%: DOEVAL@COMPILE DONTCOPY)) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) (PRINTDEF1 PRTTYTEM) (PRIN1 ") ")) ((PROP IFPROP) (PROG ((PRTTYFLG (EQ (CAR PRTTYCOM) (QUOTE IFPROP))) (PRTTYTEM (CADR PRTTYCOM)) (PRTTYX (PRETTYCOM1 (CDR PRTTYCOM) T T))) (* ; "IFPROP only dumps those property values that are non-NIL.") (COND ((LISTP PRTTYTEM) (for X in PRTTYTEM do (MAKEDEFLIST PRTTYX X PRTTYFLG))) ((NEQ PRTTYTEM (QUOTE ALL)) (MAKEDEFLIST PRTTYX PRTTYTEM PRTTYFLG PRTTYCOM)) ((ASSOC (QUOTE PUTPROPS) PRETTYPRINTMACROS) (for ATM in PRTTYX do (PRINTDEF1 (CONS (QUOTE PUTPROPS) (CONS ATM (CONS (for X on (GETPROPLIST ATM) by (CDDR X) unless (MEMB (CAR X) SYSPROPS) join (LIST (CAR X) (CADR X))))))))) (T (for ATM in PRTTYX do (printout NIL %,, "(" |.P2| (QUOTE PUTPROPS) %, |.P2| ATM) (SETQ PRTTYTEM (ADD1 (POSITION))) (for X on (GETPROPLIST ATM) by (CDDR X) unless (MEMB (CAR X) SYSPROPS) do (printout NIL .TAB PRTTYTEM .PPV (CAR X) %, .PPV (CADR X))) (PRIN1 (QUOTE ") "))))))) (P (* ; "Arbitrary expression to evaluate when loaded. Be sure to prettyprint as code") (for X in (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T)) do (PRINTDEF1 X T))) (INITVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (COND ((LISTP X) (OR (EQ (CAR X) COMMENTFLG) (PRETTYVAR1 (QUOTE RPAQ?) (CAR X) (CDR X) NIL T))) (T (PRETTYVAR1 (QUOTE RPAQ?) X NIL))))) (ADDVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR1 (QUOTE ADDTOVAR) (CAR (OR (LISTP X) (ERRORX (LIST 4 X)))) (CDR X) NIL T))) (APPENDVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR1 (QUOTE APPENDTOVAR) (CAR (OR (LISTP X) (ERRORX (LIST 4 X)))) (CDR X) NIL T))) (E (for X in (PRETTYCOM1 PRTTYCOM T) do (EVAL X))) (COMS (for X on (PRETTYCOM1 PRTTYCOM T) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X)))) (ORIGINAL (LET ((ORIGFLG T)) (DECLARE (SPECVARS ORIGFLG)) (for X on (PRETTYCOM1 PRTTYCOM T) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X))))) (BLOCKS (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T T)) (PRIN1 "(") (MAPRINT (QUOTE (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY)) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) (for X in PRTTYTEM do (PRINTDEF1 (CONS (QUOTE BLOCK%:) X))) (PRIN1 ") ")) ((*) (COND ((EQ (CADR PRTTYCOM) (QUOTE *)) (* ; "Form-feed if super-comment indicated. Use * no matter what current COMMENTFLG is.") (printout NIL .PAGE)) (T (RPTQ 3 (TERPRI)))) (COND ((AND (COND (FILEFLG FONTCHANGEFLG) (T (EQ FONTCHANGEFLG (QUOTE ALL)))) LAMBDAFONT) (CHANGEFONT LAMBDAFONT) (PRIN2 PRTTYCOM) (CHANGEFONT DEFAULTFONT)) (T (PRIN2 PRTTYCOM))) (RPTQ 2 (TERPRI))) (COND ((AND (LITATOM (CAR PRTTYCOM)) (fetch (FILEPKGTYPE GETDEF) of (CAR PRTTYCOM))) (* ; "If its the name of a type with a GETDEF, put out PUTDEF expressions.") (for X in (PRETTYCOM1 PRTTYCOM T T) do (printout NIL "(" |.P2| (QUOTE PUTDEF) %, |.P2| (KWOTE X) %, |.P2| (KWOTE (CAR PRTTYCOM)) %, .PPV (KWOTE (GETDEF X (CAR PRTTYCOM))) ")" T))) ((FIXSPELL (CAR PRTTYCOM) 70 FILEPKGCOMSPLST T PRTTYCOM) (SETQ PRTTYSPELLFLG T) (GO TOP)) (T (GO ERROR)))))) (RETURN PRTTYCOM) ERROR (ERROR "bad file package command" PRTTYCOM))) ) (PRETTYVAR (LAMBDA (VAR FLG) (* lmm "27-Aug-84 20:15") (* ; "I don't see what FLG is used for--rmk") (PROG (VAL TEM) (* ;; "Dumps value of VAR for reloading. If VAR is non-atomic, of form (var form) where VAR is to be dumped so as to be set to value of form, computed at LOAD time.") (COND ((LITATOM VAR) (AND (EQ (SETQ VAL (GETTOPVAL VAR)) (QUOTE NOBIND)) (printout T T "****WARNING: " |.P2| VAR " is unbound" T T)) (PRETTYVAR1 (QUOTE RPAQQ) VAR VAL)) ((LISTP VAR) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR)) (COND ((AND (EQ (CAR (SETQ TEM (LISTP (CAR (LISTP VAL))))) (QUOTE QUOTE)) (LISTP (CDR TEM))) (PRETTYVAR1 (QUOTE RPAQQ) VAR (CADR TEM))) ((EQ VAR COMMENTFLG) (* ; "don't print out comments")) ((OR (NULL VAL) (AND (LISTP VAL) (OR (NUMBERP (CAR VAL)) (EQ T (CAR VAL)) (NULL (CAR VAL))) (NULL (CDR VAL)))) (* ; "A minor optimization for RPAQQ's to suppresses unnecessary load-time eval's.") (PRETTYVAR1 (QUOTE RPAQQ) VAR (CAR VAL))) (T (PRETTYVAR1 (QUOTE RPAQ) VAR VAL NIL T)))) (T (ERROR "Bad variable specification" VAR))))) ) (PRETTYVAR1 (LAMBDA (OP VAR E DEF TAILFLG) (* ; "Edited 10-Feb-87 18:01 by Pavel") (* ;; "does printing for VAR, ADDVAR, and PROP commands. OP is the name of the function, VAR the operand, and E the rest of the expression to be printed, either as an element, or as a tail if TAILFLG=T. VAR is printed in LAMBDAFONT. If VAR is a list, each element is printed in LAMBDAFONT. This option is used to print both the name of the atom and its property for PROP commands.") (PROG ((LASTCOL (LINELENGTH)) TEM (*PRINT-ARRAY* T)) (* ; "This is supposed to be bound above here but isn't in some case I can't find. --Pavel") (TERPRI) (* ;; "because if you have a really bold font, it lines up the bottoms, but you can get crowded into the line above.") (COND ((AND (MEMB OP (QUOTE (RPAQQ RPAQ RPAQ?))) (EQ (TYPENAME (SETQ TEM (COND (TAILFLG (CAR E)) (T E)))) (QUOTE ARRAYP))) (* ;; "dump arrays and bitmaps specially. This really ought to be handled by having *PRINT-ARRAY* say how to dump these, so that only a single expression ends up on the file.") (* ;; "1 December 1986, Pavel: Well, I fixed bitmaps for this. Maybe I'll fix arrays as well...") (* ;; "10 February 1987, Pavel: ARRAYP's are now fixed as well, but not by using *PRINT-ARRAY*. Rather than invent another non-standard reader macro, I simply store the elements in a list and use a non-READing version of READARRAY.") (COND ((EQ OP (QUOTE RPAQQ)) (SETQQ OP RPAQ))) (printout NIL "(" |.P2| OP %, |.P2| VAR %,) (PRIN2 (BQUOTE (READARRAY-FROM-LIST (\, (ARRAYSIZE TEM)) (QUOTE (\, (ARRAYTYP TEM))) (\, (ARRAYORIG TEM)) (QUOTE (\, (PRINTARRAY-TO-LIST TEM)))))) (printout NIL (QUOTE %)) T)) ((ASSOC OP PRETTYPRINTMACROS) (OR TAILFLG (SETQ E (CONS E))) (PRINTDEF (CONS OP (COND ((LISTP VAR) (APPEND VAR E)) (T (CONS VAR E)))) 0 DEF)) (T (PRIN1 (QUOTE %()) (PRIN2 OP) (SPACES 1) (SETQ TEM (POSITION)) (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT PRETTYCOMFONT))) (COND ((LISTP VAR) (MAPRINT VAR NIL NIL NIL NIL (FUNCTION PRIN2))) (T (PRIN2 VAR))) (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT DEFAULTFONT))) (SPACES 1) (PRINTDEF E (COND ((OR (NLISTP E) (FITP E NIL NIL LASTCOL)) (POSITION)) (T TEM)) DEF TAILFLG) (PRIN1 (QUOTE %))))) (TERPRI))) ) (PRETTYCOM1 (LAMBDA (PRTYCOM PRTYFLG REMOVECOMMENTS) (* rmk%: "13-Feb-85 22:54") (PROG (PRTYX) (COND ((AND (EQ (CAR (LISTP (SETQ PRTYX (CDR PRTYCOM)))) (QUOTE *)) (CDR PRTYX)) (COND ((AND (LITATOM (SETQ PRTYX (CADR PRTYX))) PRTYFLG) (* ; "Checks to see if the variable is already being dumped and dumps it if not.") (PRETTYCOM PRTYX))) (SETQ PRTYX (COND (PRTYFLG (EVAL PRTYX)) ((LITATOM PRTYX) (AND (NEQ (SETQ PRTYX (GETTOPVAL PRTYX)) (QUOTE NOBIND)) PRTYX)) (T (RESETVARS (DWIMLOADFNSFLG) (RETURN (AND (ERSETQ (SETQ PRTYX (EVAL PRTYX))) PRTYX)))))))) (RETURN (if (AND REMOVECOMMENTS (LISTP PRTYX)) then (SUBSET PRTYX (FUNCTION (LAMBDA (X) (OR (NLISTP X) (NEQ (CAR X) COMMENTFLG))))) else PRTYX)))) ) (ENDFILE (LAMBDA (FILE) (* wt%: "10-SEP-78 13:54") (PRINT (QUOTE STOP) FILE) (CLOSEF FILE))) (MAKEDEFLIST (LAMBDA (X PROP FLG) (* ; "Edited 11-Feb-87 11:10 by bvm:") (for Z in X bind TEM do (COND ((AND (LITATOM Z) (SETQ TEM (SOME (GETPROPLIST Z) (FUNCTION (LAMBDA (X) (EQ X PROP))) (QUOTE CDDR)))) (PRETTYVAR1 (QUOTE PUTPROPS) (LIST Z PROP) (CADR TEM) (OR (EQ PROP (QUOTE EXPR)) (MEMB PROP MACROPROPS)))) ((NULL FLG) (* ; "PROP command") (EXEC-FORMAT "(no ~S property for ~S)~%%" PROP Z))))) ) (PP (NLAMBDA X (* lmm "15-Nov-86 00:54") (DECLARE (LOCALVARS . T)) (MAPC (NLAMBDA.ARGS X) (FUNCTION (LAMBDA (NAME) (for TYPE in (TYPESOF NAME NIL (QUOTE (FIELDS)) (QUOTE CURRENT)) do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME) (SHOWDEF NAME TYPE)))))) ) (PP* (NLAMBDA X (* lmm "14-Aug-84 19:11") (DECLARE (LOCALVARS . T)) (* ;; "Prettyprints definitions to terminal with comments not suppressed.") (LET ((**COMMENT**FLG NIL) (*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT)))) (DECLARE (SPECVARS **COMMENT**FLG *STANDARD-OUTPUT*)) (PRETTYPRINT (NLAMBDA.ARGS X)))) ) (PPT (NLAMBDA X (* lmm "14-Aug-84 19:12") (DECLARE (LOCALVARS . T)) (* ;; "Prettyprints definitions to terminal with clisp translations shown.") (LET ((*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT)))) (DECLARE (SPECVARS *STANDARD-OUTPUT*)) (RESETVARS ((PRETTYTRANFLG T)) (RETURN (PRETTYPRINT (NLAMBDA.ARGS X)))))) ) (PRETTYPRINT (LAMBDA (FNS PRETTYDEFLG FNSLST) (* ; "Edited 11-Feb-87 11:11 by bvm:") (* ;; "PRETTYDEFLG is supplied when called from PRINTFNS. it is either a paatial file map or T, so that it is also used as a flag for whether you are being called from prettydef.") (* ;; "Note that prettyprint does all of its printing to standard output file and using current readtable. it assumes that higher functions have set these appropriately, as is the case when called from prettydef, pp, pp*,") (RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPFONT) (DSPFONT) (GETSTREAM NIL (QUOTE OUTPUT)))) (PROG ((CLK (CLOCK 0)) (NEWADRLST (LISTP PRETTYDEFLG)) (FILEFLG (NOT (DISPLAYP (OUTPUT)))) FN DEF ADR LST SKIPPEDLST TEM) (* ; "NEWADRLST Corresponds to the current entry on NEWFILEMAP. Is in TCONC format.") (COND ((ATOM (SETQ LST FNS)) (SETQ LST (EVALV FNS)))) LP (COND ((NLISTP LST) (RETURN FNS)) ((AND FILEFLG (IGREATERP (CLOCKDIFFERENCE CLK) 30000)) (* ; "Every 30 seconds say what function we're working on") (SETQ CLK (CLOCK 0)) (PRIN2 (CAR LST) T T) (PRIN1 (QUOTE ", ") T))) (SETQ FN (CAR LST)) (TERPRI) (* ; "The initial TERPRI is not in map") (AND NEWADRLST (TCONC NEWADRLST (LIST FN (GETFILEPTR PRTTYFILE)))) (* ; "Address of start.") LP1 (SETQ DEF (VIRGINFN FN)) (AND PRETTYDEFLG (SELECTQ (ARGTYPE DEF) (1 (SETQ NLAMLST (CONS FN NLAMLST))) (2 (SETQ LAMALST (CONS FN LAMALST))) (3 (SETQ NLAMALST (CONS FN NLAMALST))) (NIL (SETQ LAM?LST (CONS FN LAM?LST))) NIL)) (* ; "So prettydef can add the appropriate DECLARE:") (COND ((NULL DEF) (COND ((AND (NULL PRETTYDEFLG) FN (BOUNDP FN)) (* ; "No fn definition, but is a variable. Only make this check when called via PP or PP*") (PRINTDEF (EVALV FN) 2)) (T (GO NOPRINT)))) ((NULL (EXPRP DEF)) (GO NOPRINT)) (T (AND ADDSPELLFLG (ADDSPELL FN)) (COND ((AND PRETTYDEFLG SOURCEFILE (NULL SOURCEFILENV) (NULL (SELECTQ REPRINTFNS (ALL T) ((T EXPRS) (EXPRP FN)) (AND (LISTP REPRINTFNS) (FMEMB FN REPRINTFNS)))) (PRETTYPRINT1 FN)) (* ; "Was a fn to be copied from old file, and we succeeded")) (T (* ; "Prettyprint afresh") (PRETTYPRINT3 FN DEF PRETTYDEFLG))))) DEFPRINTED (* ;;; "At this point we have prettyprinted FN one way or another") (AND NEWADRLST (RPLACD (CDADR NEWADRLST) (GETFILEPTR PRTTYFILE))) (* ; "Store end address") (TERPRI) (* ; "TERPRI is not included in map address") (SETQ LST (CDR LST)) (GO LP) NOPRINT (COND ((AND FILEFLG SOURCEFILE (PRETTYPRINT1 FN)) (GO DEFPRINTED)) ((AND (NULL PRETTYDEFLG) (SETQ TEM (EDITLOADFNS? FN))) (* ; "only make this check when called from PP or PP*") (LOADFNS FN TEM (QUOTE PROP)) (COND ((GETPROP FN (QUOTE EXPR)) (GO LP1))) (PRINT (CONS FN (QUOTE (not found))) T T)) ((AND DWIMFLG (NULL DEF) (SETQ TEM (MISSPELLED? FN 70 USERWORDS (AND PRETTYDEFLG T) LST)) (NEQ TEM FN)) (/RPLACA LST (SETQ FN TEM)) (AND NEWADRLST (FRPLACA (CADR NEWADRLST) FN)) (* ; "Fixes filemap.") (AND PRETTYDEFLG (SETQ PRTTYSPELLFLG T)) (GO LP1))) (EXEC-FORMAT "(~S not printable)~%%" FN) (AND LISPXHISTORY (LISPXPUT (QUOTE *ERROR*) FN NIL (CAAR LISPXHISTORY))) (COND (NEWADRLST (SETQ TEM (NLEFT (CAR NEWADRLST) 2)) (RPLACD TEM) (RPLACD NEWADRLST TEM))) LP3 (SETQ LST (CDR LST)) (GO LP)))) ) (PRETTYPRINT1 (LAMBDA (FN) (* bvm%: "30-Aug-86 17:25") (* ;;; "Like BRECOMPILE1. Obtains FN from SOURCEFILE. works whether the file has previously been mapped by PRETTYDEF, LOAD, or LOADFNS (or patially mapped)") (WITH-READER-ENVIRONMENT (OR SOURCEFILENV DESTINATIONENV) (PROG (ADR TEM) (COND ((NULL OLDFILEMAP) (GO DEFQLP)) ((PRETTYPRINT2 FN) (RETURN FN)) ((NULL (CAR OLDFILEMAP)) (RETURN NIL) (* ; "The entire file has been scanned.")) (T (GO FNLP) (* ; "Already inside of DEFINEQ."))) DEFQLP (* ; "Find DEFINEQ") (SELECTQ (SETQ TEM (RATOM SOURCEFILE)) ((STOP NIL) (* ; "End of file reached.") (SETQ OLDFILEMAP (CONS NIL OLDFILEMAP)) (* ; "Just to inform future calls to PRETTYPRINT1 not to bother scanning.") (RETURN NIL)) (%( (COND ((EQ (SETQ TEM (RATOM SOURCEFILE)) (QUOTE DEFINEQ)) (COND ((NULL OLDFILEMAP) (SETQ OLDFILEMAP (LIST T)) (* ;; "In case functionis found right off, OLDFILEMAP must not be left as NIL or else next call to PRETTYPRINT1 will not realize are alredy inside of DEFINEQ."))) (GO FNLP)) (T (SKREAD SOURCEFILE (QUOTE %())))) (SKREAD SOURCEFILE TEM)) (GO DEFQLP) FNLP (SELECTQ (SETQ TEM (RATOM SOURCEFILE)) (%) (* ; "End of DEFINEQ.") (GO DEFQLP)) ((%( %[) NIL) (SCANFILEHELP)) (SETQ ADR (SUB1 (GETFILEPTR SOURCEFILE))) (SETQ TEM (RATOM SOURCEFILE)) (SETFILEPTR SOURCEFILE ADR) (SKREAD SOURCEFILE) (COND ((EQ TEM FN) (PRETTYPRINT2 FN ADR (GETFILEPTR SOURCEFILE)) (* ; "copies the bytes.") (RETURN FN)) (T (SETQ OLDFILEMAP (CONS (CONS TEM (CONS ADR (GETFILEPTR SOURCEFILE))) OLDFILEMAP)) (* ;; "Note that this situation only occurs when (a) the entire file was not peviously scanned, e.g. if loaded with buildmapflg off, and (b) user is doing a remake, and (c) this functio was either dumped directly because it was changed, or else it has been deleted from the FNS. The function is added to OLDFILEMAP just in case it is out of order.") (GO FNLP)))))) ) (PRETTYPRINT2 (LAMBDA (FN FROM TO) (* bvm%: "30-Aug-86 18:13") (* ;; "Copies function from sourcefile to prettyfile. looking it up on the map when not already given address. returns nil if not there") (PROG (TEM) (COND (FROM) ((for X in OLDFILEMAP thereis (COND ((NLISTP X) NIL) ((EQ (CAR X) FN) (* ;; "occurs when remaking a file without a map, and a function is previously skipped that later is needed.") (SETQ TEM X)) ((LISTP (CDDR X)) (SETQ TEM (FASSOC FN (CDDR X)))))) (SETQ FROM (CADR TEM)) (SETQ TO (CDDR TEM))) (T (RETURN NIL))) (SETFILEPTR SOURCEFILE FROM) (RATOM SOURCEFILE) (* ;; "The RATOM skips the paren. the reason for the RATOM instead of simply setting file ptr to (ADD1 FROM) is that there may be font info there.") (COND ((NEQ FN (SETQ TEM (READ SOURCEFILE))) (* ; "Consistency check.") (LISPXPRINT (CONS FN TEM) T) (ERROR (QUOTE "filemap does not agree with contents of") SOURCEFILE T))) (if (NULL SOURCEFILENV) then (* ; "compatible environments, just copy characters") (COPYCHARS SOURCEFILE PRTTYFILE FROM TO) else (* ; "incompatible, have to read old def and reprettyprint") (SETQ TEM (READ SOURCEFILE)) (* ; "old definition") (WITH-READER-ENVIRONMENT DESTINATIONENV (PRETTYPRINT3 FN TEM T))) (* ; "Initial and final TERPRI's are done by callers; they are not in map.") (RETURN FN))) ) (PRETTYPRINT3 (LAMBDA (FN DEF PRETTYDEFLG) (* bvm%: "30-Aug-86 17:18") (LET (TEM) (AND (OR (SELECTQ CLISPIFYPRETTYFLG ((T EXPRS) (EXPRP FN)) (ALL T) (CHANGES (AND PRETTYDEFLG (MEMB FN CHANGES))) (MEMB FN CLISPIFYPRETTYFLG)) (AND (SUPERPRINTEQ (CAR (SETQ TEM (CADDR DEF))) COMMENTFLG) (EQ (CADR TEM) (QUOTE DECLARATIONS%:)) (MEMB (QUOTE CLISPIFY) TEM))) (SETQ DEF (CLISPIFY DEF))) (* ;; "If the function is stored on property list, only clispify if user specifically said MAKEFILE (file CLISPIFY), otherwise, assume that functions on property list have already been clispified") (COND ((AND LAMBDAFONT FONTCHANGEFLG) (PRIN1 (QUOTE %()) (* ;; "The font change is after the paren because of problems with updating filemaps when moving back and forth between -10 and -D systems--rmk") (CHANGEFONT LAMBDAFONT) (PRIN2 FN) (CHANGEFONT DEFAULTFONT) (TERPRI)) (T (PRIN1 (QUOTE %()) (PRINT FN))) (PRINTDEF DEF 2 (QUOTE FNS) NIL FNSLST) (PRIN1 (QUOTE %))) FN)) ) (PRINTDEF1 [LAMBDA (EXPR FORMFLG) (* ; "Edited 16-Apr-2018 21:35 by rmk:") (* ; "Edited 16-Apr-2018 10:14 by rmk:") (* ; "Edited 14-Apr-88 18:21 by bvm") (* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS") (* ;; "Used by MAKEFILE to print P, etc expressions. ") (TERPRI) (LET (STARTPOS ENDPOS) (IF (AND FORMFLG NEWFILEMAP (EQ (CAR EXPR) 'CL:DEFUN)) THEN (SETQ STARTPOS (GETFILEPTR PRTTYFILE))) (PRINTDEF EXPR NIL FORMFLG NIL FNSLST) [IF STARTPOS THEN (SETQ ENDPOS (GETFILEPTR PRTTYFILE)) (NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR) (CONS STARTPOS ENDPOS] (TERPRI]) (SUPERPRINTEQ (LAMBDA (X Y) (OR (EQ X Y) (AND Y (EQ (CDR (FASSOC X PRETTYEQUIVLST)) Y))))) (SUPERPRINTGETPROP (LAMBDA (ATM PROP) (* wt%: "17-SEP-79 15:57") (OR (GETPROP (CDR (FASSOC ATM PRETTYEQUIVLST)) PROP) (GETPROP ATM PROP))) ) (CHANGEFONT (LAMBDA (FONTCLASS FILE) (* lmm "17-Jan-86 20:59") (* ;; "for calls to changefont when not under prettyprin prettydef. This is only for non-D systems. For D, DSPFONT is moved'ed in.") (* ;; "Don't bother testing for FONTCHANGEFLG=ALL, because presumably the FONTCLASS will have a NULL entry if display printing isn't wanted. FONTCHANGEFLG=ALL tests are really only needed if something expensive can be avoided by advance knowledge.") (AND FONTCHANGEFLG FONTCLASS (DSPFONT FONTCLASS FILE))) ) ) (DEFINEQ (READARRAY (LAMBDA (SIZE TYPE ORIG) (* rrb " 4-JUL-80 17:07") (* ;; "type is one of: POINTER, FIXP, SMALLPOSP BYTE DOUBLEPOINTER or a number which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.") (PROG (X (A (ARRAY SIZE TYPE NIL ORIG)) M DELTA) LP (COND ((NEQ (READC) (QUOTE %()) (GO LP))) (SETQ M 1) (SETQ DELTA (SUB1 (OR ORIG 1))) LP1 (COND ((NOT (IGREATERP M SIZE)) (SETA A (IPLUS M DELTA) (READ)) (SETQ M (ADD1 M)) (GO LP1)) ((NULL (READ)) (* ;; "PRINTARRAY writes a NIL if there are no elements in the array for which the left half must be set using SETD, otherwise it writes a T.") (GO OUT))) (SETQ M (COND ((NUMBERP TYPE) (ADD1 TYPE)) ((EQ TYPE (QUOTE DOUBLEPOINTER)) 1) (T (SHOULDNT)))) LP2 (COND ((NOT (IGREATERP M SIZE)) (SETD A (IPLUS M DELTA) (READ)) (SETQ M (ADD1 M)) (GO LP2))) OUT (READ) (* ; "Reads the final right parentheses surrounding the elements of the array.") (RETURN A))) ) (PRINTARRAY (LAMBDA (V) (* bvm%: " 3-Oct-86 12:57") (* ; "Used by prettydef. Included in ABASIC because it uses LOC and VAG on the 10") (PROG (A N M TYPE FLG DOUBLEFLG ORIG) (COND ((AND (LITATOM V) (ARRAYP (SETQ A (EVALV V (QUOTE PRINTARRAY))))) (PRINT (BQUOTE (SETQ (\, V) (READARRAY (\, (SETQ N (ARRAYSIZE A))) (QUOTE (\, (SETQ TYPE (ARRAYTYP A)))) (\, (SETQ ORIG (ARRAYORIG A)))))))) ((ARRAYP V) (* ; "Just dumps the element expression--assumes that READARRAY has already been written") (SETQ A V) (SETQ N (ARRAYSIZE A)) (SETQ TYPE (ARRAYTYP A)) (SETQ ORIG (ARRAYORIG A))) (T (RETURN (HELP V "not array")))) (PRIN1 (QUOTE %()) (SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER)) (NUMBERP TYPE))) (* ; "note if this array has different ELTD.") (SETQ M 1) LP (COND ((NOT (IGREATERP M N)) (COND ((OR (EQ TYPE (QUOTE POINTER)) DOUBLEFLG) (PRINT (ELT A (SUB1 (IPLUS M ORIG))))) (T (* ; "changed from PRINT to PRIN2 so would look better in file.") (PRIN2 (ELT A (SUB1 (IPLUS M ORIG)))) (SPACES 1))) (* ;; "check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out avoids lots of NILs.") (AND DOUBLEFLG (COND ((NUMBERP TYPE) (* ; "check for M being in the double pointer part of the array") (IGREATERP M TYPE)) (T T)) (ELTD A (SUB1 (IPLUS M ORIG))) (SETQ FLG T)) (SETQ M (ADD1 M)) (GO LP)) ((NULL (PRINT FLG)) (* ; "if FLG is NULL, there are non-NIL double word entries.") (GO OUT))) (SETQ M (COND ((EQ TYPE (QUOTE DOUBLEPOINTER)) (* ; "all entries are double") 1) ((NUMBERP TYPE) (* ; "first TYPE elements in the array are numbers") (ADD1 TYPE)))) LP1 (COND ((NOT (IGREATERP M N)) (PRINT (ELTD A (SUB1 (IPLUS M ORIG)))) (SETQ M (ADD1 M)) (GO LP1))) OUT (PRIN1 (QUOTE %))) (RETURN A))) ) (READARRAY-FROM-LIST (LAMBDA (SIZE TYPE ORIG ELEMENTS) (* ; "Edited 10-Feb-87 17:59 by Pavel") (* ;;; "This is not written in the most straightforward way possible. Rather, in order to minimize the possibility of destabilization, we have kept this as much like READARRAY as possible. In essence, the only change is to use POP instead of READ.") (* ;; "type is one of: POINTER, FIXP, SMALLPOSP BYTE DOUBLEPOINTER or a number which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.") (PROG (X (A (ARRAY SIZE TYPE NIL ORIG)) M DELTA) LP (SETQ M 1) (SETQ DELTA (SUB1 (OR ORIG 1))) LP1 (COND ((NOT (IGREATERP M SIZE)) (SETA A (IPLUS M DELTA) (pop ELEMENTS)) (SETQ M (ADD1 M)) (GO LP1)) ((NULL (pop ELEMENTS)) (* ;; "PRINTARRAY writes a NIL if there are no elements in the array for which the left half must be set using SETD, otherwise it writes a T.") (GO OUT))) (SETQ M (COND ((NUMBERP TYPE) (ADD1 TYPE)) ((EQ TYPE (QUOTE DOUBLEPOINTER)) 1) (T (SHOULDNT)))) LP2 (COND ((NOT (IGREATERP M SIZE)) (SETD A (IPLUS M DELTA) (pop ELEMENTS)) (SETQ M (ADD1 M)) (GO LP2))) OUT (RETURN A))) ) (PRINTARRAY-TO-LIST (LAMBDA (V) (* ; "Edited 10-Feb-87 18:09 by Pavel") (* ;;; "This code is not written in the most straighforward way possible. Rather, to minimize the possibility of destabilization, we attempt to make it as much like PRINTARRAY as we can. In essence, the only changes are to PUSH the elements onto RESULT instead of printing them. At the end, we return the reversal of RESULT.") (PROG ((RESULT NIL) A N M TYPE FLG DOUBLEFLG ORIG) (COND ((ARRAYP V) (SETQ A V) (SETQ N (ARRAYSIZE A)) (SETQ TYPE (ARRAYTYP A)) (SETQ ORIG (ARRAYORIG A))) (T (RETURN (HELP V "not array")))) (SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER)) (NUMBERP TYPE))) (* ; "note if this array has different ELTD.") (SETQ M 1) LP (COND ((NOT (IGREATERP M N)) (push RESULT (ELT A (SUB1 (IPLUS M ORIG)))) (* ;; "check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out avoids lots of NILs.") (AND DOUBLEFLG (COND ((NUMBERP TYPE) (* ; "check for M being in the double pointer part of the array") (IGREATERP M TYPE)) (T T)) (ELTD A (SUB1 (IPLUS M ORIG))) (SETQ FLG T)) (SETQ M (ADD1 M)) (GO LP))) (push RESULT FLG) (COND ((NULL FLG) (* ; "if FLG is NULL, there are non-NIL double word entries.") (GO OUT))) (SETQ M (COND ((EQ TYPE (QUOTE DOUBLEPOINTER)) (* ; "all entries are double") 1) ((NUMBERP TYPE) (* ; "first TYPE elements in the array are numbers") (ADD1 TYPE)))) LP1 (COND ((NOT (IGREATERP M N)) (push RESULT (ELTD A (SUB1 (IPLUS M ORIG)))) (SETQ M (ADD1 M)) (GO LP1))) OUT (RETURN (REVERSE RESULT)))) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS CHANGFONT MACRO (= . DSPFONT)) ) ) (* ; "COPYRIGHT") (DEFINEQ (PRINTCOPYRIGHT [LAMBDA (FILENAME) (* ; "Edited 31-Aug-99 09:06 by rmk:") (* ; "Edited 31-Aug-99 09:01 by rmk:") (* edited%: " 1-Jan-85 20:16") (* ;;; "CALLED BY PRETTYDEF TO PUT a copyright notice on a file. The globalvar COPYRIGHTOWNERS is used to determine the possible copyright owners when it is determined the file doesn't have a copyright yet and has never been asked if the programmer wanted one. The whole copyright mechanism can be turned off by setting COPYRIGHTFLG to NEVER -- originaly NIL. If the file is copyrighted, any year the file is editted the new year is tacked on to the list of copyright years. The copyright notice comes immediately after the FILECREATED expression * *") (PROG [(OWNER (GETPROP FILENAME 'COPYRIGHT] (AND [OR OWNER (AND COPYRIGHTFLG (SETQ OWNER (ASKUSER (if (EQ COPYRIGHTFLG 'DEFAULT) then 0 else DWIMWAIT) (CONSTANT (CHARACTER (CHARCODE LF))) (CONCAT "Copyright owner for file " FILENAME ": ") (NCONC [MAPCAR COPYRIGHTOWNERS (FUNCTION (LAMBDA (X) (LIST (CAR X) "" 'EXPLAINSTRING (CONCAT (CAR X) " - " (CADR X)) 'RETURN (CADR X) 'CONFIRMFLG T] (CONS (if (SETQ OWNER (ASSOC DEFAULTCOPYRIGHTOWNER COPYRIGHTOWNERS)) then (LIST (CONSTANT (CHARACTER (CHARCODE LF))) (CONCAT DEFAULTCOPYRIGHTOWNER " ") 'EXPLAINSTRING (CONCAT " - " (CADR OWNER) " [Default]") 'NOECHOFLG T 'RETURN (CADR OWNER)) else '(% "No copyright notice now " EXPLAINSTRING " - no copyright notice now [Default]" NOECHOFLG T RETURN NIL)) DEFAULTCOPYRIGHTKEYLST)) T T)) (/PUTPROP FILENAME 'COPYRIGHT (SETQ OWNER (LIST OWNER] (COND ((NEQ (CAR OWNER) 'NONE) (PROG ((CURRENTYEAR (SUBATOM (DATE (DATEFORMAT YEAR.LONG NO.TIME)) -4 -1))) (OR (MEMBER CURRENTYEAR (CDR OWNER)) (NCONC1 OWNER CURRENTYEAR))) (PRINTCOPYRIGHT1 OWNER]) (PRINTCOPYRIGHT1 [LAMBDA (OWNER) (* ; "Edited 6-Apr-90 10:36 by jds") (PROG ((DATES (CDR OWNER)) (SEMICOLON (AND (READTABLEPROP *READTABLE* 'COMMONLISP) "; ")) (PRIVATE NIL)) (COND ((EQ (CAR DATES) T) (SETQ PRIVATE T) (pop DATES))) (COND (SEMICOLON (* ; "do CommonLisp style comment") (PRIN1 SEMICOLON)) (T (* ; "Print IL-style comment, with a ; in it so the pretty printer will render it as a CL-style comment.") (printout NIL "(" |.P2| '* '% '; " %" "))) (PRIN3 "Copyright (c) ") [for Y on DATES do (* ;  "print years of copyright, e.g., 1985, 1986") (PRINTNUM '(FIX 4) (CAR Y)) (COND ((CDR Y) (PRIN3 ", "] (PRIN3 " by ") (PRIN3 (CAR OWNER)) (PRIN3 ".") (AND COPYRIGHTSRESERVED (PRIN3 " All rights reserved.")) (TERPRI) [COND (PRIVATE (for LINE in (CONS (CONCAT "The following program was created in " (CAR DATES) " but has not been published") '( "within the meaning of the copyright law, is furnished under license," "and may not be used, copied and/or disclosed except in accordance" "with the terms of said license.")) do (COND (SEMICOLON (PRIN1 SEMICOLON))) (printout NIL LINE T] (COND ((NOT SEMICOLON) (PRIN1 "%") "))) (TERPRI]) (SAVECOPYRIGHT (LAMBDA (FILENAME) (* lmm "25-DEC-82 16:48") (* ;; "Called from PRETTYDEF to save copyright info on end of file") (AND (NEQ COPYRIGHTFLG (QUOTE NEVER)) (PROG (X) (COND ((SETQ X (GETPROP FILENAME (QUOTE COPYRIGHT))) (PRINT (LIST (QUOTE PUTPROPS) FILENAME (QUOTE COPYRIGHT) X))))))) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T) (NOLINKFNS PRINTCOPYRIGHT1)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER COPYRIGHTSRESERVED) ) (RPAQ? COPYRIGHTFLG ) (RPAQ? DEFAULTCOPYRIGHTOWNER ) (RPAQ? COPYRIGHTPRETTYFLG T) (RPAQ? COPYRIGHTOWNERS ) (RPAQ? DEFAULTCOPYRIGHTKEYLST '((NONE " " EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN 'NONE) [%[ "owner: " EXPLAINSTRING "[ - new copyright owner -- type one line of text" NOECHOFLG T KEYLST (( " " RETURN (SUBSTRING (CADR ANSWER) 2 -2] (%] "No copyright notice now " EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL))) (RPAQ? COPYRIGHTSRESERVED T) (RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (RPAQ? *DEFAULT-MAKEFILE-ENVIRONMENT* ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG *DEFAULT-MAKEFILE-ENVIRONMENT* *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*) ) (RPAQ? COMMENTFLG '*) (RPAQ? **COMMENT**FLG '" **COMMENT** ") (RPAQ? PRETTYFLG T) (RPAQ? %#RPARS 4) (RPAQ? CLISPIFYPRETTYFLG ) (RPAQ? PRETTYTRANFLG ) (RPAQ? FONTCHANGEFLG ) (RPAQ? CHANGECHARTABSTR ) (RPAQ? PRETTYTABFLG T) (RPAQ? DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST)) (RPAQ? AVERAGEVARLENGTH 4) (RPAQ? AVERAGEFNLENGTH 5) (RPAQ? %#CAREFULCOLUMNS 0) (RPAQ? CHANGECHAR '%|) (RPAQ? ENDLINEUSERFN ) (RPAQ? PRETTYDEFMACROS ) (RPAQ? PRETTYPRINTMACROS ) (RPAQ? PRETTYEQUIVLST ) (RPAQ? PRETTYPRINTYPEMACROS ) (RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *)) (RPAQ? SYSPROPS '(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS AMAC ARGNAMES BLKLIBRARYDEF BROADSCOPE CLISPCLASS CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE EDIT-SAVE EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP FILEHISTORY FILEMAP FILETYPE GLOBALVAR HISTORY I.S.OPR I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS OLDVALUE OPD SETFN SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET TRYHARDER)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT) (SPECVARS FNSLST FILEFLG)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG PRETTYHEADER FILERDTBL PRETTYEQUIVLST PRETTYTRANFLG CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS COMMENTFLG) ) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT LAMBDAFONT PRETTYCOMFONT COMMENTFONT **COMMENT**FLG PRETTYPRINTMACROS)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILESLOAD (IMPORT) FILEPKG) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPT PP* PP) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS PRETTY COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 1999 2018 )) (DECLARE%: DONTCOPY (FILEMAP (NIL (5962 40703 (PRETTYDEF 5972 . 14235) (PRETTYDEFCOMS 14237 . 14919) (PRETTYDEF0 14921 . 15112) (PRETTYDEF1 15114 . 16877) (PRINTDATE 16879 . 18115) (PRINTDATE1 18117 . 19322) (PRINTFNS 19324 . 19893) (PRETTYCOM 19895 . 26236) (PRETTYVAR 26238 . 27276) (PRETTYVAR1 27278 . 29496) (PRETTYCOM1 29498 . 30202) (ENDFILE 30204 . 30300) (MAKEDEFLIST 30302 . 30706) (PP 30708 . 30984) (PP* 30986 . 31299) (PPT 31301 . 31620) (PRETTYPRINT 31622 . 34774) (PRETTYPRINT1 34776 . 36662) (PRETTYPRINT2 36664 . 37980) (PRETTYPRINT3 37982 . 38937) (PRINTDEF1 38939 . 39947) (SUPERPRINTEQ 39949 . 40043) ( SUPERPRINTGETPROP 40045 . 40189) (CHANGEFONT 40191 . 40701)) (40704 46050 (READARRAY 40714 . 41640) ( PRINTARRAY 41642 . 43382) (READARRAY-FROM-LIST 43384 . 44489) (PRINTARRAY-TO-LIST 44491 . 46048)) ( 46177 52632 (PRINTCOPYRIGHT 46187 . 49959) (PRINTCOPYRIGHT1 49961 . 52327) (SAVECOPYRIGHT 52329 . 52630))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Feb-2021 10:59:08"  {DSK}kaplan>Local>medley3.5>git-medley>sources>PRETTY.;10 57241 changes to%: (FNS PRINTCOPYRIGHT1) previous date%: "16-Apr-2018 21:37:09" {DSK}kaplan>Local>medley3.5>git-medley>sources>PRETTY.;6) (* ; " Copyright (c) 1984-1990, 1999, 2018, 2021 by Venue & Xerox Corporation. The following program was created in 1984 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance with the terms of said license. ") (PRETTYCOMPRINT PRETTYCOMS) (RPAQQ PRETTYCOMS [(FNS PRETTYDEF PRETTYDEFCOMS PRETTYDEF0 PRETTYDEF1 PRINTDATE PRINTDATE1 PRINTFNS PRETTYCOM PRETTYVAR PRETTYVAR1 PRETTYCOM1 ENDFILE MAKEDEFLIST PP PP* PPT PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 PRETTYPRINT3 PRINTDEF1 SUPERPRINTEQ SUPERPRINTGETPROP CHANGEFONT) (FNS READARRAY PRINTARRAY READARRAY-FROM-LIST PRINTARRAY-TO-LIST) (COMS (DECLARE%: DONTCOPY (MACROS CHANGFONT))) (COMS (* ; "COPYRIGHT") (FNS PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT) (BLOCKS (NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T) (NOLINKFNS PRINTCOPYRIGHT1))) (GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER COPYRIGHTSRESERVED) (INITVARS (COPYRIGHTFLG) (DEFAULTCOPYRIGHTOWNER) (COPYRIGHTPRETTYFLG T) (COPYRIGHTOWNERS) [DEFAULTCOPYRIGHTKEYLST '((NONE " " EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN 'NONE) [%[ "owner: " EXPLAINSTRING "[ - new copyright owner -- type one line of text" NOECHOFLG T KEYLST (( " " RETURN (SUBSTRING (CADR ANSWER) 2 -2] (%] "No copyright notice now " EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL] (COPYRIGHTSRESERVED T) (*NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (*DEFAULT-MAKEFILE-ENVIRONMENT*)) (GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG *DEFAULT-MAKEFILE-ENVIRONMENT* *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*)) (INITVARS (COMMENTFLG '*) (**COMMENT**FLG '" **COMMENT** ") (PRETTYFLG T) (%#RPARS 4) (CLISPIFYPRETTYFLG) (PRETTYTRANFLG) (FONTCHANGEFLG) (CHANGECHARTABSTR) (PRETTYTABFLG T) (DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST)) (AVERAGEVARLENGTH 4) (AVERAGEFNLENGTH 5) (%#CAREFULCOLUMNS 0) (CHANGECHAR '%|) (ENDLINEUSERFN)) [INITVARS (PRETTYDEFMACROS) (PRETTYPRINTMACROS) (PRETTYEQUIVLST) (PRETTYPRINTYPEMACROS) (FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *)) (SYSPROPS '(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS AMAC ARGNAMES BLKLIBRARYDEF BROADSCOPE CLISPCLASS CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE EDIT-SAVE EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP FILEHISTORY FILEMAP FILETYPE GLOBALVAR HISTORY I.S.OPR I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS OLDVALUE OPD SETFN SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET TRYHARDER] (BLOCKS (PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT) (SPECVARS FNSLST FILEFLG))) (GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG PRETTYHEADER FILERDTBL PRETTYEQUIVLST PRETTYTRANFLG CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS COMMENTFLG) [DECLARE%: EVAL@COMPILE DOCOPY (P (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT LAMBDAFONT PRETTYCOMFONT COMMENTFONT **COMMENT**FLG PRETTYPRINTMACROS] (DECLARE%: DOEVAL@COMPILE DONTCOPY (* ;  "IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES") (FILES (IMPORT) FILEPKG)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPT PP* PP) (NLAML) (LAMA]) (DEFINEQ (PRETTYDEF (LAMBDA (PRTTYFNS PRTTYFILE PRTTYCOMS REPRINTFNS SOURCEFILE CHANGES) (* ; "Edited 16-Feb-88 11:46 by raf") (DECLARE (SPECVARS PRTTYFILE REPRINTFNS SOURCEFILE CHANGES)) (RESETLST (RESETSAVE (RESETUNDO) (QUOTE (AND RESETSTATE (RESETUNDO OLDVALUE)))) (* ;; "Says undo everything if there is an error or control-D This is particularly necessary if user is using the PRINT* prettyprintmacro which updates comments to point to the newest version.") (PROG ((NEWFILEMAP (AND BUILDMAPFLG (LIST NIL))) (%#RPARS %#RPARS) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) FILEFLG FNSLST PRTTYTEM PRETTYCOMSLST PRTTYSPELLFLG OLDFILEMAP MAPADR NLAMALST NLAMLST LAMALST LAM?LST FILEDATES ORIGFLG ROOTNAME DESTINATIONENV SOURCEFILENV SOURCEFC FCLOCATION) (DECLARE (SPECVARS *PRINT-ARRAY* XCL:*PRINT-STRUCTURE* *PRINT-LEVEL* *PRINT-LENGTH* NEWFILEMAP ORIGFLG FILEFLG NLAMALST PRTTYSPELLFLG PRETTYCOMSLST PRTTYCOMS LAM?LST FNSLST OLDFILEMAP LAMALST MAPADR ORIGFLG NLAMLST DESTINATIONENV SOURCEFILENV %#RPARS)) (* ; "NEWFILEMAP corresponds to the map being built for the file being written. OLDFILEMAP corresponds to the map that exists for SOURCEFILE, if any.") (COND ((OR (NULL (\DTEST PRTTYFILE (QUOTE LITATOM))) (EQ PRTTYFILE T)) (* ; "we no longer support any of the crufty alternatives to writing a brand new file") (\ILLEGAL.ARG PRTTYFILE))) (SETQ ROOTNAME (ROOTFILENAME PRTTYFILE)) (if (OR (EQ SOURCEFILE T) (AND REPRINTFNS (NULL SOURCEFILE))) then (* ;; "SOURCEFILE plays the role of CFILE for recompiling. It permits PRETTYPRINT to obtain the definitions from the file withou having to reprettyprint them, or even having them loaded into core. T (or NIL if REPRINTFNS is specified) is the same as PRETTYFILE.") (* ;; "REPRINTFNS specifies those functions to be printed anew. REPRINTFNS=T means reprint all EXPRS, a la recompile. For example, if you have an entire file loaded in, but only change a few functions, using this option can speed up dumping the file by a factor of two. If REPRINTFNS=ALL, all functions that contain in core exprs, whether on function definition cell or property lists, are reprinted. REPRINTFNS can also be a list. MAKEFILE uses this for the REMAKE option by specifying as REPRINTFNS the list CHANGES. In any case, if the function does not contain an in core defnition, prettyprint will try to find one on the file. i.e., act as though REPRINTFNS were NIL.") (SETQ SOURCEFILE ROOTNAME)) (if (SETQ DESTINATIONENV (GET ROOTNAME (QUOTE MAKEFILE-ENVIRONMENT))) then (* ; "use this explicit environment. Copy it in case user later on destructively edits it") (SETQ DESTINATIONENV (\DO-DEFINE-FILE-INFO NIL (COPY DESTINATIONENV))) else (* ; "see if we already know the environment of the source") (CL:MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP SOURCEFC) (LOOKUP-ENVIRONMENT-AND-FILEMAP (OR SOURCEFILE ROOTNAME) (OR (NULL SOURCEFILE) (EQ SOURCEFILE ROOTNAME))))) (if SOURCEFILE then (if (NULL (NLSETQ (SETQ SOURCEFILE (OPENSTREAM SOURCEFILE (QUOTE INPUT))))) then (* ; "can't find file to reprint from.") (* ; "OPENSTREAM is called in order that 'correction' take place.") (SETQ SOURCEFILE NIL) (PRIN1 PRTTYFILE T) (PRIN1 (QUOTE " not found, so it will be written anew. ") T) elseif (RANDACCESSP SOURCEFILE) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) SOURCEFILE)) (RESETSAVE (INPUT SOURCEFILE)) (if (EQ REPRINTFNS (QUOTE EXPRS)) then (SETQ REPRINTFNS T) elseif (EQ REPRINTFNS (QUOTE CHANGES)) then (SETQ REPRINTFNS (UNION (FILEPKG.CHANGEDFNS CHANGES) (FILEPKG.CHANGEDFNS (fetch FILECHANGES of ROOTNAME))))) (if (NULL SOURCEFILENV) then (* ; "if we didn't have environment cached, look it up from the actual stream now") (CL:MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP SOURCEFC) (GET-ENVIRONMENT-AND-FILEMAP SOURCEFILE))) (if (NULL OLDFILEMAP) then (* ; "no map on file, so we will build one as needed") (SETFILEPTR SOURCEFILE (OR SOURCEFC 0)) elseif (NULL (CAR OLDFILEMAP)) then (* ; "complete map.") elseif (LISTP (CAR OLDFILEMAP)) then (* ; "only partial map built up. should only happen for files that were made with BUILDMAPFLG=NIL, since otherwise there would be a coplete map on the file.") (SETFILEPTR SOURCEFILE (CAAR OLDFILEMAP)) else (* ; "Redundancy check. Should only occur if there was a compiled function in the file. and a partial map was formed that stopped after that function.") (HELP)) else (* ; "Can't copy from non-randaccessp source") (SETQ SOURCEFILE NIL))) (* ;; "Now figure out what environment to write the new file in.") (if DESTINATIONENV then (* ; "have explicit env, ok") elseif SOURCEFILENV then (* ; "use same as source") (SETQ DESTINATIONENV (if (EQUAL-READER-ENVIRONMENT SOURCEFILENV *OLD-INTERLISP-READ-ENVIRONMENT*) then (* ; "write the new style") (\DO-DEFINE-FILE-INFO NIL *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*) else (* ; "use same env on new file as old") SOURCEFILENV)) else (* ; "new file, use default") (SETQ DESTINATIONENV (\DO-DEFINE-FILE-INFO NIL (COPY *DEFAULT-MAKEFILE-ENVIRONMENT*)))) (if (NULL SOURCEFILE) then (* ; "get rid of anything we knew about source") (SETQ OLDFILEMAP NIL) (SETQ SOURCEFC NIL) (SETQ SOURCEFILENV NIL) elseif (AND SOURCEFILENV (EQUAL-READER-ENVIRONMENT SOURCEFILENV DESTINATIONENV)) then (* ; "source and destination compatible, so we won't need to worry about it in PRETTYPRINT1/2") (SETQ SOURCEFILENV NIL)) (RESETSAVE NIL (LIST (FUNCTION PRETTYDEF0) (SETQ PRTTYFILE (OPENSTREAM PRTTYFILE (QUOTE OUTPUT))))) (* ; "Cleans up by closing and deleting file if aborted.") (RESETSAVE (OUTPUT PRTTYFILE)) (PRINT-READER-ENVIRONMENT DESTINATIONENV) (SETQ FCLOCATION (GETFILEPTR PRTTYFILE)) (WITH-READER-ENVIRONMENT DESTINATIONENV (if (NOT (SYNTAXP (CHARCODE "[") (QUOTE LEFTBRACKET))) then (* ; "can't use brackets on this read table") (SETQ %#RPARS NIL)) (SETQ FILEDATES (PRINTDATE PRTTYFILE CHANGES)) (AND (NEQ COPYRIGHTFLG (QUOTE NEVER)) ROOTNAME (PRINTCOPYRIGHT ROOTNAME)) (SETQ FILEFLG T) (SETQ CHANGES (FILEPKG.CHANGEDFNS CHANGES)) (* ; "Used freely by PRETTYPRINT to decide clispifying.") (if (NOT (RANDACCESSP PRTTYFILE)) then (* ; "No point building a map, since we won't be able to go back to the start to point at it") (SETQ NEWFILEMAP NIL)) (if FONTCHANGEFLG then (* ; "this is expensive in that it costs as many conses as there are functions, but you can afford it for a makefile.") (SETQ FNSLST (OR (for FL in (GETPROP ROOTNAME (QUOTE FILEGROUP)) when (fetch FILEPROP of FL) join (FILEFNSLST FL)) (FILEFNSLST ROOTNAME)))) (if (OR (LISTP PRTTYFNS) (LISTP (GETTOPVAL PRTTYFNS))) then (* ; "Ancient cruft from before the days of MAKEFILE.") (PRINTFNS PRTTYFNS T) (PRETTYCOM PRTTYFNS T)) (if (SETQ PRETTYCOMSLST (OR (LISTP PRTTYCOMS) (AND (LITATOM PRTTYCOMS) (LISTP (GETTOPVAL PRTTYCOMS))))) then (PRETTYCOM PRTTYCOMS T) (* ; "PRTTYCOMS is just like the argument to a COMS command. see comment in prettycom1") (for L on PRETTYCOMSLST do (PRETTYCOM (CAR L) NIL L)) (* ; "The original value of PRTTYCOMS is saved so that it can be rewritten if a spelling correction occurs. The list PRTTYCOMSLST is searched by PRETTYCOM1 for * commands to see if the variable has be dumped out as well.")) (if (PRETTYDEF1) then (* ; "The coms were reprinted by PRETTYDEF1 due to a change to nlama and or nlaml") elseif PRTTYSPELLFLG then (* ; "A correction on prettycoms was performed, so dump it out aain to get the corrected version on the file.") (PRETTYCOM PRTTYCOMS T)) (if (NEQ COPYRIGHTFLG (QUOTE NEVER)) then (SAVECOPYRIGHT ROOTNAME)) (if NEWFILEMAP then (PRIN1 "(") (PRIN2 (QUOTE DECLARE%:)) (SPACES 1) (PRIN2 (QUOTE DONTCOPY)) (TERPRI) (SPACES 2) (for ADR in MAPADR do (SETQ PRTTYTEM (GETFILEPTR PRTTYFILE)) (SETFILEPTR PRTTYFILE ADR) (* ; "Write the current file positon into the filecreated expression, and then restores the file pointer.") (PRIN2 PRTTYTEM) (SETFILEPTR PRTTYFILE PRTTYTEM)) (PRIN2 (LIST (QUOTE FILEMAP) NEWFILEMAP)) (* ; "printed instead of prettyprinted, so wont take up two pages of listing.") (PRIN1 (QUOTE ") ")) (PUTFILEMAP (FULLNAME PRTTYFILE) NEWFILEMAP NIL DESTINATIONENV NIL FCLOCATION) (* ; "Also save map, so can be used for subsequent makefiles.")) (ENDFILE PRTTYFILE) (if (AND FILEDATES ROOTNAME) then (/replace FILEDATES of ROOTNAME with FILEDATES))) (RETURN (FULLNAME PRTTYFILE))))) ) (PRETTYDEFCOMS (LAMBDA (PRTTYCOMS FNSLST) (* ; "Edited 19-Aug-88 16:07 by raf") (DECLARE (SPECVARS FNSLST)) (PROG ((%#RPARS %#RPARS) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) BUILDMAPFLG PRTTYSPELLFLG ORIGFLG SOURCEFILE) (DECLARE (SPECVARS *PRINT-ARRAY* XCL:*PRINT-STRUCTURE* *PRINT-LEVEL* *PRINT-LENGTH* BUILDMAPFLG NEWFILEMAP ORIGFLG PRTTYSPELLFLG LAM?LST ORIGFLG SOURCEFILE %#RPARS)) (if (NOT (SYNTAXP (CHARCODE "[") (QUOTE LEFTBRACKET))) then (* ; "can't use brackets on this read table") (SETQ %#RPARS NIL)) (for L on (OR (LISTP PRTTYCOMS) (AND (LITATOM PRTTYCOMS) (LISTP (GETTOPVAL PRTTYCOMS)))) do (PRETTYCOM (CAR L) NIL L)))) ) (PRETTYDEF0 (LAMBDA (MADEFILE) (* bvm%: " 2-Aug-86 16:24") (* ;; "Cleans up after prettydef in case of control-d.") (COND ((OPENP MADEFILE (QUOTE OUTPUT)) (DELFILE (CLOSEF MADEFILE))))) ) (PRETTYDEF1 (LAMBDA NIL (* wt%: " 9-SEP-78 16:05") (* ; "Updates the DECLARE: for NLAMA/NLAML") (PROG (PRTTYCOM PRTTYTEM PRTTYNEW) (COND ((NULL (SOME PRETTYCOMSLST (FUNCTION (LAMBDA (X) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (SETQ PRTTYTEM (MEMB (QUOTE COMPILERVARS) (SETQ PRTTYCOM X))) (EQ (CAAR (SETQ PRTTYTEM (CDR PRTTYTEM))) (QUOTE ADDVARS))))))) (AND (NULL NLAMALST) (NULL NLAMLST) (NULL LAMALST) (RETURN NIL)) (* ;; "If thee is no DECLARE: and no nlambdas, dont bother to add any. note tha if thee is IS a DECLARE:, then we must check even if there are no nlambdas, because consider what happens when user changes the only nlambda to a lambda must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NLAMALST NLAMLST LAMALST)) (LIST NLAMALST NLAMLST LAMALST) (QUOTE (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA . NLAMALST) (NLAML . NLAMLST) (LAMA . LAMALST)))))) (COND ((AND (LISTP PRETTYCOMSLST) (NLISTP PRTTYCOMS)) (/NCONC1 PRETTYCOMSLST PRTTYCOM) (PRETTYCOM PRTTYCOMS T)))) ((NOT (EQUAL (CAR PRTTYTEM) (SETQ PRTTYNEW (LIST (QUOTE ADDVARS) (CONS (QUOTE NLAMA) (UNION NLAMALST (INTERSECTION LAM?LST (CDADAR PRTTYTEM)))) (CONS (QUOTE NLAML) (UNION NLAMLST (INTERSECTION LAM?LST (CDR (CADDAR PRTTYTEM))))) (CONS (QUOTE LAMA) (UNION LAMALST (INTERSECTION LAM?LST (CDR (CADDDR (CAR PRTTYTEM)))))))))) (* ;; "The reason for the unions and intersections is that prettydef simply may not know the fntyps of some of the functions in the file, namely those on lam?lst, and theefore tese should not be removed from NLAMA and NLAML if they are there from a previous makefile.") (/RPLACA PRTTYTEM PRTTYNEW) (AND (NLISTP PRTTYCOMS) (PRETTYCOM PRTTYCOMS T))) (T (RETURN NIL))) (PRETTYCOM PRTTYCOM) (RETURN T))) ) (PRINTDATE (LAMBDA (OUTSTREAM CHANGES) (* bvm%: " 1-Aug-86 15:51") (* ;;; "assumes that OUTSTREAM is a file open for output, and prints the date information for that file on it") (PROG ((DAT (DATE)) (ROOTNAME (ROOTFILENAME OUTSTREAM)) PREVPAIR FILEDATES) (if FILEPKGFLG then (if ROOTNAME then (/replace FILECHANGES of ROOTNAME with (SETQ CHANGES (FILEPKG.MERGECHANGES CHANGES (fetch FILECHANGES of ROOTNAME))))) (* ;; "The reason for the order of arguments in UNION is so that the changes will be listed in roughly the order made.") (SETQ FILEDATES (CONS (create FILEDATEPAIR FILEDATE _ DAT DATEFILENAME _ (FULLNAME OUTSTREAM)) (SETQ PREVPAIR (LAST (fetch FILEDATES of ROOTNAME))))) (* ;;; "Right now, FILEDATES simply keeps latest version and date, and original version and date. Latter for integrity checks on makefile remake, as described in filepackage. Note that don't want to change FILEDATES property until PRETTDEF completes. In case of control-d, the file will be deleted automatically.")) (PRINTDATE1 OUTSTREAM CHANGES DAT (fetch FILEDATE of (CAR PREVPAIR)) (fetch DATEFILENAME of (CAR PREVPAIR))) (* ; "PRINTDATE1 does the actual printing. It is a separate function so that it can be advised.") (RETURN FILEDATES))) ) (PRINTDATE1 (LAMBDA (OUTSTREAM CHANGES DAT PREVDATE PREVERS TERMINATING.STRING) (* bvm%: "18-Sep-86 19:08") (* ;;; "does the printing for PRINTDATE") (printout OUTSTREAM .FONT DEFAULTFONT "(" |.P2| (QUOTE FILECREATED) %, |.P2| DAT %, .FONT LAMBDAFONT |.P2| (FULLNAME OUTSTREAM) .FONT DEFAULTFONT) (* ;; "note that CHANGEFONT checks for FONTCHANGEFLG explicitly so that it won't do anything if FONTCHANGEFLG is NIL") (if (AND BUILDMAPFLG (NOT (DISPLAYP OUTSTREAM))) then (push MAPADR (ADD1 (GETFILEPTR OUTSTREAM))) (PRIN3 " " OUTSTREAM) (* ;; "The address of where the map begins will be stored in this slot. 8 spaces left because when radix is 8, can overflow seven spaces by a file of 300000 characters (Alice did it). The push is because of a feature no longer used where there could be two FILECREATED expressions at the head of a file font")) (if FILEPKGFLG then (if CHANGES then (printout OUTSTREAM T T 6 |.P2| (QUOTE changes) %, |.P2| (QUOTE to%:) %,, .PPVTL CHANGES)) (if PREVDATE then (printout OUTSTREAM T T 6 |.P2| (QUOTE previous) %, |.P2| (QUOTE date%:) %, |.P2| PREVDATE) (if PREVERS then (printout OUTSTREAM %, |.P2| PREVERS)))) (PRIN1 (OR TERMINATING.STRING ") ") OUTSTREAM))) (PRINTFNS (LAMBDA (X PRETTYDEFLG) (* lmm "13-OCT-82 16:44") (* ; "prettydeflg=T when called from prettydef.") (AND X (PROG (FNADRLST) (COND ((AND PRETTYDEFLG NEWFILEMAP) (SETQ FNADRLST (TCONC NIL (GETFILEPTR PRTTYFILE))) (TCONC FNADRLST NIL) (NCONC1 NEWFILEMAP (CAR FNADRLST)))) (PRIN1 (QUOTE %()) (PRINT (QUOTE DEFINEQ)) (PRETTYPRINT X (AND PRETTYDEFLG (OR FNADRLST T)) FNSLST) (* ; "FNSLST bound in prettydef to list of functions on this file. used for font stuff.") (PRIN1 (QUOTE %))) (AND FNADRLST (RPLACA (CDAR FNADRLST) (GETFILEPTR PRTTYFILE))) (TERPRI)))) ) (PRETTYCOM (LAMBDA (PRTTYCOM PRTTYFLG PRETTYCOMSTAIL) (* ; "Edited 14-Apr-88 18:26 by bvm") (PROG (PRTTYTEM) (COND ((NULL PRTTYCOM) (* ; "So that RECOMPILE and BRECOMPILE do not have to check before calling PRETTYCOM.") (RETURN)) ((AND PRTTYFLG (NEQ PRTTYFILE T)) (PRINT (COND (LISPXPRINTFLG (* ;; "PRETTYCOMPRINT is an nlambda that does a lispxprint, except when prettyheader is NIL, in hich case it does nothing.") (LIST (QUOTE PRETTYCOMPRINT) PRTTYCOM)) (T (LIST (QUOTE PRINT) (LIST (QUOTE QUOTE) PRTTYCOM) T T)))))) (COND ((LITATOM PRTTYCOM) (COND ((AND (NULL PRTTYFLG) (NOT (BOUNDP PRTTYCOM)) DWIMFLG (SETQ PRTTYTEM (FIXSPELL PRTTYCOM 70 USERWORDS T PRETTYCOMSTAIL (FUNCTION BOUNDP))) (SETQ PRTTYSPELLFLG T)) (SETQ PRTTYCOM PRTTYTEM))) (PRETTYVAR PRTTYCOM PRTTYFLG) (* ;; "FNS and VARS are printed as (RPAQQ atom value T) so that LOAD ALLPROP will still stre them in the value cell.") (RETURN PRTTYCOM)) (PRTTYFLG (* ; "PRETTYDEF called with a list for FNS or VARS,") (RETURN PRTTYCOM))) TOP (COND ((AND (NULL ORIGFLG) (SETQ PRTTYTEM (fetch (FILEPKGCOM MACRO) of (CAR PRTTYCOM)))) (for X on (SUBPAIR (CAR PRTTYTEM) (PRETTYCOM1 PRTTYCOM T T) (CDR PRTTYTEM)) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X)))) (T (SELECTQ (CAR PRTTYCOM) (FNS (PROG (PRTTYSPELLFLG) (PRINTFNS (PRETTYCOM1 PRTTYCOM T T) (NOT (NULL PRETTYCOMSTAIL))) (AND PRTTYSPELLFLG (EQ (CADR PRTTYCOM) (QUOTE *)) (LITATOM (SETQ PRTTYTEM (CADDR PRTTYCOM))) (PRETTYCOM PRTTYTEM)) (* ; "The FNSlst had an error in it that was corrected."))) ((VARS ARRAY) (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR X))) (DECLARE%: (* ;; "Normally, expressions appearing in a symbolic file are (1) evaluated upon loading the file, (2) not evaluated when compiling the file, and (3) copied to the compile file. DECLARE: can be used to change state around any PRETTYCOM. The atomic symbols DONTCOPY, DOCOPY, DONTEVAL@COMPILE, DOEVAL@COMPILE, DONTEVAL@LOAD, and DOEVAL@LOAD have the obvious meaning. DECLARE: eliminates the pretty commands DECLARE, COMPROP, COMPROP*, PD, PC, and PC*. DECLARE: is defined as a functionthat evaluates all list expressions except when under a DONTEVAL@LOAD state.") (PRIN1 "(") (PRIN2 (QUOTE DECLARE%:)) (SPACES 1) (for LST on (PRETTYCOM1 PRTTYCOM T T) do (COND ((NLISTP (CAR LST)) (COND ((NOT (MEMB (CAR LST) DECLARETAGSLST)) (COND ((AND DWIMFLG (FIXSPELL (CAR LST) 70 DECLARETAGSLST T LST)) (SETQ PRTTYSPELLFLG T)) (T (GO ERROR))))) (PRIN2 (CAR LST)) (SPACES 1)) (T (TERPRI) (PRETTYCOM (CAR LST) NIL LST))) (SELECTQ (CAR LST) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (COND ((SETQ LST (CDR LST)) (PRINTDEF (CAR LST)) (SPACES 1)))) NIL)) (PRIN1 (QUOTE ") "))) ((CL:EVAL-WHEN) (* ;; "Has the syntax (EVAL-WHEN (times ...) coms ...). Dumps an EVAL-WHEN form on the file containing whatever is dumped by the given COMS.") (CL:ASSERT (AND (CL:CONSP (CADR PRTTYCOM)) (CL:SUBSETP (CADR PRTTYCOM) (QUOTE (EVAL CL:EVAL COMPILE CL:COMPILE LOAD CL:LOAD)))) NIL "The first argument to the ~S command must be a list of times") (CL:FORMAT T "(~S ~S" (QUOTE CL:EVAL-WHEN) (CADR PRTTYCOM)) (for LST on (PRETTYCOM1 (CDR PRTTYCOM) T NIL) do (CL:TERPRI) (PRETTYCOM (CAR LST) NIL LST)) (CL:FORMAT T "~&)~%%")) ((SPECVARS LOCALVARS GLOBALVARS) (SETQ PRTTYTEM (CONS (CAR PRTTYCOM) (PRETTYCOM1 PRTTYCOM T T))) (PRIN1 "(") (MAPRINT (QUOTE (DECLARE%: DOEVAL@COMPILE DONTCOPY)) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) (PRINTDEF1 PRTTYTEM) (PRIN1 ") ")) ((PROP IFPROP) (PROG ((PRTTYFLG (EQ (CAR PRTTYCOM) (QUOTE IFPROP))) (PRTTYTEM (CADR PRTTYCOM)) (PRTTYX (PRETTYCOM1 (CDR PRTTYCOM) T T))) (* ; "IFPROP only dumps those property values that are non-NIL.") (COND ((LISTP PRTTYTEM) (for X in PRTTYTEM do (MAKEDEFLIST PRTTYX X PRTTYFLG))) ((NEQ PRTTYTEM (QUOTE ALL)) (MAKEDEFLIST PRTTYX PRTTYTEM PRTTYFLG PRTTYCOM)) ((ASSOC (QUOTE PUTPROPS) PRETTYPRINTMACROS) (for ATM in PRTTYX do (PRINTDEF1 (CONS (QUOTE PUTPROPS) (CONS ATM (CONS (for X on (GETPROPLIST ATM) by (CDDR X) unless (MEMB (CAR X) SYSPROPS) join (LIST (CAR X) (CADR X))))))))) (T (for ATM in PRTTYX do (printout NIL %,, "(" |.P2| (QUOTE PUTPROPS) %, |.P2| ATM) (SETQ PRTTYTEM (ADD1 (POSITION))) (for X on (GETPROPLIST ATM) by (CDDR X) unless (MEMB (CAR X) SYSPROPS) do (printout NIL .TAB PRTTYTEM .PPV (CAR X) %, .PPV (CADR X))) (PRIN1 (QUOTE ") "))))))) (P (* ; "Arbitrary expression to evaluate when loaded. Be sure to prettyprint as code") (for X in (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T)) do (PRINTDEF1 X T))) (INITVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (COND ((LISTP X) (OR (EQ (CAR X) COMMENTFLG) (PRETTYVAR1 (QUOTE RPAQ?) (CAR X) (CDR X) NIL T))) (T (PRETTYVAR1 (QUOTE RPAQ?) X NIL))))) (ADDVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR1 (QUOTE ADDTOVAR) (CAR (OR (LISTP X) (ERRORX (LIST 4 X)))) (CDR X) NIL T))) (APPENDVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR1 (QUOTE APPENDTOVAR) (CAR (OR (LISTP X) (ERRORX (LIST 4 X)))) (CDR X) NIL T))) (E (for X in (PRETTYCOM1 PRTTYCOM T) do (EVAL X))) (COMS (for X on (PRETTYCOM1 PRTTYCOM T) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X)))) (ORIGINAL (LET ((ORIGFLG T)) (DECLARE (SPECVARS ORIGFLG)) (for X on (PRETTYCOM1 PRTTYCOM T) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X))))) (BLOCKS (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T T)) (PRIN1 "(") (MAPRINT (QUOTE (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY)) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) (for X in PRTTYTEM do (PRINTDEF1 (CONS (QUOTE BLOCK%:) X))) (PRIN1 ") ")) ((*) (COND ((EQ (CADR PRTTYCOM) (QUOTE *)) (* ; "Form-feed if super-comment indicated. Use * no matter what current COMMENTFLG is.") (printout NIL .PAGE)) (T (RPTQ 3 (TERPRI)))) (COND ((AND (COND (FILEFLG FONTCHANGEFLG) (T (EQ FONTCHANGEFLG (QUOTE ALL)))) LAMBDAFONT) (CHANGEFONT LAMBDAFONT) (PRIN2 PRTTYCOM) (CHANGEFONT DEFAULTFONT)) (T (PRIN2 PRTTYCOM))) (RPTQ 2 (TERPRI))) (COND ((AND (LITATOM (CAR PRTTYCOM)) (fetch (FILEPKGTYPE GETDEF) of (CAR PRTTYCOM))) (* ; "If its the name of a type with a GETDEF, put out PUTDEF expressions.") (for X in (PRETTYCOM1 PRTTYCOM T T) do (printout NIL "(" |.P2| (QUOTE PUTDEF) %, |.P2| (KWOTE X) %, |.P2| (KWOTE (CAR PRTTYCOM)) %, .PPV (KWOTE (GETDEF X (CAR PRTTYCOM))) ")" T))) ((FIXSPELL (CAR PRTTYCOM) 70 FILEPKGCOMSPLST T PRTTYCOM) (SETQ PRTTYSPELLFLG T) (GO TOP)) (T (GO ERROR)))))) (RETURN PRTTYCOM) ERROR (ERROR "bad file package command" PRTTYCOM))) ) (PRETTYVAR (LAMBDA (VAR FLG) (* lmm "27-Aug-84 20:15") (* ; "I don't see what FLG is used for--rmk") (PROG (VAL TEM) (* ;; "Dumps value of VAR for reloading. If VAR is non-atomic, of form (var form) where VAR is to be dumped so as to be set to value of form, computed at LOAD time.") (COND ((LITATOM VAR) (AND (EQ (SETQ VAL (GETTOPVAL VAR)) (QUOTE NOBIND)) (printout T T "****WARNING: " |.P2| VAR " is unbound" T T)) (PRETTYVAR1 (QUOTE RPAQQ) VAR VAL)) ((LISTP VAR) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR)) (COND ((AND (EQ (CAR (SETQ TEM (LISTP (CAR (LISTP VAL))))) (QUOTE QUOTE)) (LISTP (CDR TEM))) (PRETTYVAR1 (QUOTE RPAQQ) VAR (CADR TEM))) ((EQ VAR COMMENTFLG) (* ; "don't print out comments")) ((OR (NULL VAL) (AND (LISTP VAL) (OR (NUMBERP (CAR VAL)) (EQ T (CAR VAL)) (NULL (CAR VAL))) (NULL (CDR VAL)))) (* ; "A minor optimization for RPAQQ's to suppresses unnecessary load-time eval's.") (PRETTYVAR1 (QUOTE RPAQQ) VAR (CAR VAL))) (T (PRETTYVAR1 (QUOTE RPAQ) VAR VAL NIL T)))) (T (ERROR "Bad variable specification" VAR))))) ) (PRETTYVAR1 (LAMBDA (OP VAR E DEF TAILFLG) (* ; "Edited 10-Feb-87 18:01 by Pavel") (* ;; "does printing for VAR, ADDVAR, and PROP commands. OP is the name of the function, VAR the operand, and E the rest of the expression to be printed, either as an element, or as a tail if TAILFLG=T. VAR is printed in LAMBDAFONT. If VAR is a list, each element is printed in LAMBDAFONT. This option is used to print both the name of the atom and its property for PROP commands.") (PROG ((LASTCOL (LINELENGTH)) TEM (*PRINT-ARRAY* T)) (* ; "This is supposed to be bound above here but isn't in some case I can't find. --Pavel") (TERPRI) (* ;; "because if you have a really bold font, it lines up the bottoms, but you can get crowded into the line above.") (COND ((AND (MEMB OP (QUOTE (RPAQQ RPAQ RPAQ?))) (EQ (TYPENAME (SETQ TEM (COND (TAILFLG (CAR E)) (T E)))) (QUOTE ARRAYP))) (* ;; "dump arrays and bitmaps specially. This really ought to be handled by having *PRINT-ARRAY* say how to dump these, so that only a single expression ends up on the file.") (* ;; "1 December 1986, Pavel: Well, I fixed bitmaps for this. Maybe I'll fix arrays as well...") (* ;; "10 February 1987, Pavel: ARRAYP's are now fixed as well, but not by using *PRINT-ARRAY*. Rather than invent another non-standard reader macro, I simply store the elements in a list and use a non-READing version of READARRAY.") (COND ((EQ OP (QUOTE RPAQQ)) (SETQQ OP RPAQ))) (printout NIL "(" |.P2| OP %, |.P2| VAR %,) (PRIN2 (BQUOTE (READARRAY-FROM-LIST (\, (ARRAYSIZE TEM)) (QUOTE (\, (ARRAYTYP TEM))) (\, (ARRAYORIG TEM)) (QUOTE (\, (PRINTARRAY-TO-LIST TEM)))))) (printout NIL (QUOTE %)) T)) ((ASSOC OP PRETTYPRINTMACROS) (OR TAILFLG (SETQ E (CONS E))) (PRINTDEF (CONS OP (COND ((LISTP VAR) (APPEND VAR E)) (T (CONS VAR E)))) 0 DEF)) (T (PRIN1 (QUOTE %()) (PRIN2 OP) (SPACES 1) (SETQ TEM (POSITION)) (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT PRETTYCOMFONT))) (COND ((LISTP VAR) (MAPRINT VAR NIL NIL NIL NIL (FUNCTION PRIN2))) (T (PRIN2 VAR))) (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT DEFAULTFONT))) (SPACES 1) (PRINTDEF E (COND ((OR (NLISTP E) (FITP E NIL NIL LASTCOL)) (POSITION)) (T TEM)) DEF TAILFLG) (PRIN1 (QUOTE %))))) (TERPRI))) ) (PRETTYCOM1 (LAMBDA (PRTYCOM PRTYFLG REMOVECOMMENTS) (* rmk%: "13-Feb-85 22:54") (PROG (PRTYX) (COND ((AND (EQ (CAR (LISTP (SETQ PRTYX (CDR PRTYCOM)))) (QUOTE *)) (CDR PRTYX)) (COND ((AND (LITATOM (SETQ PRTYX (CADR PRTYX))) PRTYFLG) (* ; "Checks to see if the variable is already being dumped and dumps it if not.") (PRETTYCOM PRTYX))) (SETQ PRTYX (COND (PRTYFLG (EVAL PRTYX)) ((LITATOM PRTYX) (AND (NEQ (SETQ PRTYX (GETTOPVAL PRTYX)) (QUOTE NOBIND)) PRTYX)) (T (RESETVARS (DWIMLOADFNSFLG) (RETURN (AND (ERSETQ (SETQ PRTYX (EVAL PRTYX))) PRTYX)))))))) (RETURN (if (AND REMOVECOMMENTS (LISTP PRTYX)) then (SUBSET PRTYX (FUNCTION (LAMBDA (X) (OR (NLISTP X) (NEQ (CAR X) COMMENTFLG))))) else PRTYX)))) ) (ENDFILE (LAMBDA (FILE) (* wt%: "10-SEP-78 13:54") (PRINT (QUOTE STOP) FILE) (CLOSEF FILE))) (MAKEDEFLIST (LAMBDA (X PROP FLG) (* ; "Edited 11-Feb-87 11:10 by bvm:") (for Z in X bind TEM do (COND ((AND (LITATOM Z) (SETQ TEM (SOME (GETPROPLIST Z) (FUNCTION (LAMBDA (X) (EQ X PROP))) (QUOTE CDDR)))) (PRETTYVAR1 (QUOTE PUTPROPS) (LIST Z PROP) (CADR TEM) (OR (EQ PROP (QUOTE EXPR)) (MEMB PROP MACROPROPS)))) ((NULL FLG) (* ; "PROP command") (EXEC-FORMAT "(no ~S property for ~S)~%%" PROP Z))))) ) (PP (NLAMBDA X (* lmm "15-Nov-86 00:54") (DECLARE (LOCALVARS . T)) (MAPC (NLAMBDA.ARGS X) (FUNCTION (LAMBDA (NAME) (for TYPE in (TYPESOF NAME NIL (QUOTE (FIELDS)) (QUOTE CURRENT)) do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME) (SHOWDEF NAME TYPE)))))) ) (PP* (NLAMBDA X (* lmm "14-Aug-84 19:11") (DECLARE (LOCALVARS . T)) (* ;; "Prettyprints definitions to terminal with comments not suppressed.") (LET ((**COMMENT**FLG NIL) (*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT)))) (DECLARE (SPECVARS **COMMENT**FLG *STANDARD-OUTPUT*)) (PRETTYPRINT (NLAMBDA.ARGS X)))) ) (PPT (NLAMBDA X (* lmm "14-Aug-84 19:12") (DECLARE (LOCALVARS . T)) (* ;; "Prettyprints definitions to terminal with clisp translations shown.") (LET ((*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT)))) (DECLARE (SPECVARS *STANDARD-OUTPUT*)) (RESETVARS ((PRETTYTRANFLG T)) (RETURN (PRETTYPRINT (NLAMBDA.ARGS X)))))) ) (PRETTYPRINT (LAMBDA (FNS PRETTYDEFLG FNSLST) (* ; "Edited 11-Feb-87 11:11 by bvm:") (* ;; "PRETTYDEFLG is supplied when called from PRINTFNS. it is either a paatial file map or T, so that it is also used as a flag for whether you are being called from prettydef.") (* ;; "Note that prettyprint does all of its printing to standard output file and using current readtable. it assumes that higher functions have set these appropriately, as is the case when called from prettydef, pp, pp*,") (RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPFONT) (DSPFONT) (GETSTREAM NIL (QUOTE OUTPUT)))) (PROG ((CLK (CLOCK 0)) (NEWADRLST (LISTP PRETTYDEFLG)) (FILEFLG (NOT (DISPLAYP (OUTPUT)))) FN DEF ADR LST SKIPPEDLST TEM) (* ; "NEWADRLST Corresponds to the current entry on NEWFILEMAP. Is in TCONC format.") (COND ((ATOM (SETQ LST FNS)) (SETQ LST (EVALV FNS)))) LP (COND ((NLISTP LST) (RETURN FNS)) ((AND FILEFLG (IGREATERP (CLOCKDIFFERENCE CLK) 30000)) (* ; "Every 30 seconds say what function we're working on") (SETQ CLK (CLOCK 0)) (PRIN2 (CAR LST) T T) (PRIN1 (QUOTE ", ") T))) (SETQ FN (CAR LST)) (TERPRI) (* ; "The initial TERPRI is not in map") (AND NEWADRLST (TCONC NEWADRLST (LIST FN (GETFILEPTR PRTTYFILE)))) (* ; "Address of start.") LP1 (SETQ DEF (VIRGINFN FN)) (AND PRETTYDEFLG (SELECTQ (ARGTYPE DEF) (1 (SETQ NLAMLST (CONS FN NLAMLST))) (2 (SETQ LAMALST (CONS FN LAMALST))) (3 (SETQ NLAMALST (CONS FN NLAMALST))) (NIL (SETQ LAM?LST (CONS FN LAM?LST))) NIL)) (* ; "So prettydef can add the appropriate DECLARE:") (COND ((NULL DEF) (COND ((AND (NULL PRETTYDEFLG) FN (BOUNDP FN)) (* ; "No fn definition, but is a variable. Only make this check when called via PP or PP*") (PRINTDEF (EVALV FN) 2)) (T (GO NOPRINT)))) ((NULL (EXPRP DEF)) (GO NOPRINT)) (T (AND ADDSPELLFLG (ADDSPELL FN)) (COND ((AND PRETTYDEFLG SOURCEFILE (NULL SOURCEFILENV) (NULL (SELECTQ REPRINTFNS (ALL T) ((T EXPRS) (EXPRP FN)) (AND (LISTP REPRINTFNS) (FMEMB FN REPRINTFNS)))) (PRETTYPRINT1 FN)) (* ; "Was a fn to be copied from old file, and we succeeded")) (T (* ; "Prettyprint afresh") (PRETTYPRINT3 FN DEF PRETTYDEFLG))))) DEFPRINTED (* ;;; "At this point we have prettyprinted FN one way or another") (AND NEWADRLST (RPLACD (CDADR NEWADRLST) (GETFILEPTR PRTTYFILE))) (* ; "Store end address") (TERPRI) (* ; "TERPRI is not included in map address") (SETQ LST (CDR LST)) (GO LP) NOPRINT (COND ((AND FILEFLG SOURCEFILE (PRETTYPRINT1 FN)) (GO DEFPRINTED)) ((AND (NULL PRETTYDEFLG) (SETQ TEM (EDITLOADFNS? FN))) (* ; "only make this check when called from PP or PP*") (LOADFNS FN TEM (QUOTE PROP)) (COND ((GETPROP FN (QUOTE EXPR)) (GO LP1))) (PRINT (CONS FN (QUOTE (not found))) T T)) ((AND DWIMFLG (NULL DEF) (SETQ TEM (MISSPELLED? FN 70 USERWORDS (AND PRETTYDEFLG T) LST)) (NEQ TEM FN)) (/RPLACA LST (SETQ FN TEM)) (AND NEWADRLST (FRPLACA (CADR NEWADRLST) FN)) (* ; "Fixes filemap.") (AND PRETTYDEFLG (SETQ PRTTYSPELLFLG T)) (GO LP1))) (EXEC-FORMAT "(~S not printable)~%%" FN) (AND LISPXHISTORY (LISPXPUT (QUOTE *ERROR*) FN NIL (CAAR LISPXHISTORY))) (COND (NEWADRLST (SETQ TEM (NLEFT (CAR NEWADRLST) 2)) (RPLACD TEM) (RPLACD NEWADRLST TEM))) LP3 (SETQ LST (CDR LST)) (GO LP)))) ) (PRETTYPRINT1 (LAMBDA (FN) (* bvm%: "30-Aug-86 17:25") (* ;;; "Like BRECOMPILE1. Obtains FN from SOURCEFILE. works whether the file has previously been mapped by PRETTYDEF, LOAD, or LOADFNS (or patially mapped)") (WITH-READER-ENVIRONMENT (OR SOURCEFILENV DESTINATIONENV) (PROG (ADR TEM) (COND ((NULL OLDFILEMAP) (GO DEFQLP)) ((PRETTYPRINT2 FN) (RETURN FN)) ((NULL (CAR OLDFILEMAP)) (RETURN NIL) (* ; "The entire file has been scanned.")) (T (GO FNLP) (* ; "Already inside of DEFINEQ."))) DEFQLP (* ; "Find DEFINEQ") (SELECTQ (SETQ TEM (RATOM SOURCEFILE)) ((STOP NIL) (* ; "End of file reached.") (SETQ OLDFILEMAP (CONS NIL OLDFILEMAP)) (* ; "Just to inform future calls to PRETTYPRINT1 not to bother scanning.") (RETURN NIL)) (%( (COND ((EQ (SETQ TEM (RATOM SOURCEFILE)) (QUOTE DEFINEQ)) (COND ((NULL OLDFILEMAP) (SETQ OLDFILEMAP (LIST T)) (* ;; "In case functionis found right off, OLDFILEMAP must not be left as NIL or else next call to PRETTYPRINT1 will not realize are alredy inside of DEFINEQ."))) (GO FNLP)) (T (SKREAD SOURCEFILE (QUOTE %())))) (SKREAD SOURCEFILE TEM)) (GO DEFQLP) FNLP (SELECTQ (SETQ TEM (RATOM SOURCEFILE)) (%) (* ; "End of DEFINEQ.") (GO DEFQLP)) ((%( %[) NIL) (SCANFILEHELP)) (SETQ ADR (SUB1 (GETFILEPTR SOURCEFILE))) (SETQ TEM (RATOM SOURCEFILE)) (SETFILEPTR SOURCEFILE ADR) (SKREAD SOURCEFILE) (COND ((EQ TEM FN) (PRETTYPRINT2 FN ADR (GETFILEPTR SOURCEFILE)) (* ; "copies the bytes.") (RETURN FN)) (T (SETQ OLDFILEMAP (CONS (CONS TEM (CONS ADR (GETFILEPTR SOURCEFILE))) OLDFILEMAP)) (* ;; "Note that this situation only occurs when (a) the entire file was not peviously scanned, e.g. if loaded with buildmapflg off, and (b) user is doing a remake, and (c) this functio was either dumped directly because it was changed, or else it has been deleted from the FNS. The function is added to OLDFILEMAP just in case it is out of order.") (GO FNLP)))))) ) (PRETTYPRINT2 (LAMBDA (FN FROM TO) (* bvm%: "30-Aug-86 18:13") (* ;; "Copies function from sourcefile to prettyfile. looking it up on the map when not already given address. returns nil if not there") (PROG (TEM) (COND (FROM) ((for X in OLDFILEMAP thereis (COND ((NLISTP X) NIL) ((EQ (CAR X) FN) (* ;; "occurs when remaking a file without a map, and a function is previously skipped that later is needed.") (SETQ TEM X)) ((LISTP (CDDR X)) (SETQ TEM (FASSOC FN (CDDR X)))))) (SETQ FROM (CADR TEM)) (SETQ TO (CDDR TEM))) (T (RETURN NIL))) (SETFILEPTR SOURCEFILE FROM) (RATOM SOURCEFILE) (* ;; "The RATOM skips the paren. the reason for the RATOM instead of simply setting file ptr to (ADD1 FROM) is that there may be font info there.") (COND ((NEQ FN (SETQ TEM (READ SOURCEFILE))) (* ; "Consistency check.") (LISPXPRINT (CONS FN TEM) T) (ERROR (QUOTE "filemap does not agree with contents of") SOURCEFILE T))) (if (NULL SOURCEFILENV) then (* ; "compatible environments, just copy characters") (COPYCHARS SOURCEFILE PRTTYFILE FROM TO) else (* ; "incompatible, have to read old def and reprettyprint") (SETQ TEM (READ SOURCEFILE)) (* ; "old definition") (WITH-READER-ENVIRONMENT DESTINATIONENV (PRETTYPRINT3 FN TEM T))) (* ; "Initial and final TERPRI's are done by callers; they are not in map.") (RETURN FN))) ) (PRETTYPRINT3 (LAMBDA (FN DEF PRETTYDEFLG) (* bvm%: "30-Aug-86 17:18") (LET (TEM) (AND (OR (SELECTQ CLISPIFYPRETTYFLG ((T EXPRS) (EXPRP FN)) (ALL T) (CHANGES (AND PRETTYDEFLG (MEMB FN CHANGES))) (MEMB FN CLISPIFYPRETTYFLG)) (AND (SUPERPRINTEQ (CAR (SETQ TEM (CADDR DEF))) COMMENTFLG) (EQ (CADR TEM) (QUOTE DECLARATIONS%:)) (MEMB (QUOTE CLISPIFY) TEM))) (SETQ DEF (CLISPIFY DEF))) (* ;; "If the function is stored on property list, only clispify if user specifically said MAKEFILE (file CLISPIFY), otherwise, assume that functions on property list have already been clispified") (COND ((AND LAMBDAFONT FONTCHANGEFLG) (PRIN1 (QUOTE %()) (* ;; "The font change is after the paren because of problems with updating filemaps when moving back and forth between -10 and -D systems--rmk") (CHANGEFONT LAMBDAFONT) (PRIN2 FN) (CHANGEFONT DEFAULTFONT) (TERPRI)) (T (PRIN1 (QUOTE %()) (PRINT FN))) (PRINTDEF DEF 2 (QUOTE FNS) NIL FNSLST) (PRIN1 (QUOTE %))) FN)) ) (PRINTDEF1 [LAMBDA (EXPR FORMFLG) (* ; "Edited 16-Apr-2018 21:35 by rmk:") (* ; "Edited 16-Apr-2018 10:14 by rmk:") (* ; "Edited 14-Apr-88 18:21 by bvm") (* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS") (* ;; "Used by MAKEFILE to print P, etc expressions. ") (TERPRI) (LET (STARTPOS ENDPOS) (IF (AND FORMFLG NEWFILEMAP (EQ (CAR EXPR) 'CL:DEFUN)) THEN (SETQ STARTPOS (GETFILEPTR PRTTYFILE))) (PRINTDEF EXPR NIL FORMFLG NIL FNSLST) [IF STARTPOS THEN (SETQ ENDPOS (GETFILEPTR PRTTYFILE)) (NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR) (CONS STARTPOS ENDPOS] (TERPRI]) (SUPERPRINTEQ (LAMBDA (X Y) (OR (EQ X Y) (AND Y (EQ (CDR (FASSOC X PRETTYEQUIVLST)) Y))))) (SUPERPRINTGETPROP (LAMBDA (ATM PROP) (* wt%: "17-SEP-79 15:57") (OR (GETPROP (CDR (FASSOC ATM PRETTYEQUIVLST)) PROP) (GETPROP ATM PROP))) ) (CHANGEFONT (LAMBDA (FONTCLASS FILE) (* lmm "17-Jan-86 20:59") (* ;; "for calls to changefont when not under prettyprin prettydef. This is only for non-D systems. For D, DSPFONT is moved'ed in.") (* ;; "Don't bother testing for FONTCHANGEFLG=ALL, because presumably the FONTCLASS will have a NULL entry if display printing isn't wanted. FONTCHANGEFLG=ALL tests are really only needed if something expensive can be avoided by advance knowledge.") (AND FONTCHANGEFLG FONTCLASS (DSPFONT FONTCLASS FILE))) ) ) (DEFINEQ (READARRAY (LAMBDA (SIZE TYPE ORIG) (* rrb " 4-JUL-80 17:07") (* ;; "type is one of: POINTER, FIXP, SMALLPOSP BYTE DOUBLEPOINTER or a number which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.") (PROG (X (A (ARRAY SIZE TYPE NIL ORIG)) M DELTA) LP (COND ((NEQ (READC) (QUOTE %()) (GO LP))) (SETQ M 1) (SETQ DELTA (SUB1 (OR ORIG 1))) LP1 (COND ((NOT (IGREATERP M SIZE)) (SETA A (IPLUS M DELTA) (READ)) (SETQ M (ADD1 M)) (GO LP1)) ((NULL (READ)) (* ;; "PRINTARRAY writes a NIL if there are no elements in the array for which the left half must be set using SETD, otherwise it writes a T.") (GO OUT))) (SETQ M (COND ((NUMBERP TYPE) (ADD1 TYPE)) ((EQ TYPE (QUOTE DOUBLEPOINTER)) 1) (T (SHOULDNT)))) LP2 (COND ((NOT (IGREATERP M SIZE)) (SETD A (IPLUS M DELTA) (READ)) (SETQ M (ADD1 M)) (GO LP2))) OUT (READ) (* ; "Reads the final right parentheses surrounding the elements of the array.") (RETURN A))) ) (PRINTARRAY (LAMBDA (V) (* bvm%: " 3-Oct-86 12:57") (* ; "Used by prettydef. Included in ABASIC because it uses LOC and VAG on the 10") (PROG (A N M TYPE FLG DOUBLEFLG ORIG) (COND ((AND (LITATOM V) (ARRAYP (SETQ A (EVALV V (QUOTE PRINTARRAY))))) (PRINT (BQUOTE (SETQ (\, V) (READARRAY (\, (SETQ N (ARRAYSIZE A))) (QUOTE (\, (SETQ TYPE (ARRAYTYP A)))) (\, (SETQ ORIG (ARRAYORIG A)))))))) ((ARRAYP V) (* ; "Just dumps the element expression--assumes that READARRAY has already been written") (SETQ A V) (SETQ N (ARRAYSIZE A)) (SETQ TYPE (ARRAYTYP A)) (SETQ ORIG (ARRAYORIG A))) (T (RETURN (HELP V "not array")))) (PRIN1 (QUOTE %()) (SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER)) (NUMBERP TYPE))) (* ; "note if this array has different ELTD.") (SETQ M 1) LP (COND ((NOT (IGREATERP M N)) (COND ((OR (EQ TYPE (QUOTE POINTER)) DOUBLEFLG) (PRINT (ELT A (SUB1 (IPLUS M ORIG))))) (T (* ; "changed from PRINT to PRIN2 so would look better in file.") (PRIN2 (ELT A (SUB1 (IPLUS M ORIG)))) (SPACES 1))) (* ;; "check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out avoids lots of NILs.") (AND DOUBLEFLG (COND ((NUMBERP TYPE) (* ; "check for M being in the double pointer part of the array") (IGREATERP M TYPE)) (T T)) (ELTD A (SUB1 (IPLUS M ORIG))) (SETQ FLG T)) (SETQ M (ADD1 M)) (GO LP)) ((NULL (PRINT FLG)) (* ; "if FLG is NULL, there are non-NIL double word entries.") (GO OUT))) (SETQ M (COND ((EQ TYPE (QUOTE DOUBLEPOINTER)) (* ; "all entries are double") 1) ((NUMBERP TYPE) (* ; "first TYPE elements in the array are numbers") (ADD1 TYPE)))) LP1 (COND ((NOT (IGREATERP M N)) (PRINT (ELTD A (SUB1 (IPLUS M ORIG)))) (SETQ M (ADD1 M)) (GO LP1))) OUT (PRIN1 (QUOTE %))) (RETURN A))) ) (READARRAY-FROM-LIST (LAMBDA (SIZE TYPE ORIG ELEMENTS) (* ; "Edited 10-Feb-87 17:59 by Pavel") (* ;;; "This is not written in the most straightforward way possible. Rather, in order to minimize the possibility of destabilization, we have kept this as much like READARRAY as possible. In essence, the only change is to use POP instead of READ.") (* ;; "type is one of: POINTER, FIXP, SMALLPOSP BYTE DOUBLEPOINTER or a number which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.") (PROG (X (A (ARRAY SIZE TYPE NIL ORIG)) M DELTA) LP (SETQ M 1) (SETQ DELTA (SUB1 (OR ORIG 1))) LP1 (COND ((NOT (IGREATERP M SIZE)) (SETA A (IPLUS M DELTA) (pop ELEMENTS)) (SETQ M (ADD1 M)) (GO LP1)) ((NULL (pop ELEMENTS)) (* ;; "PRINTARRAY writes a NIL if there are no elements in the array for which the left half must be set using SETD, otherwise it writes a T.") (GO OUT))) (SETQ M (COND ((NUMBERP TYPE) (ADD1 TYPE)) ((EQ TYPE (QUOTE DOUBLEPOINTER)) 1) (T (SHOULDNT)))) LP2 (COND ((NOT (IGREATERP M SIZE)) (SETD A (IPLUS M DELTA) (pop ELEMENTS)) (SETQ M (ADD1 M)) (GO LP2))) OUT (RETURN A))) ) (PRINTARRAY-TO-LIST (LAMBDA (V) (* ; "Edited 10-Feb-87 18:09 by Pavel") (* ;;; "This code is not written in the most straighforward way possible. Rather, to minimize the possibility of destabilization, we attempt to make it as much like PRINTARRAY as we can. In essence, the only changes are to PUSH the elements onto RESULT instead of printing them. At the end, we return the reversal of RESULT.") (PROG ((RESULT NIL) A N M TYPE FLG DOUBLEFLG ORIG) (COND ((ARRAYP V) (SETQ A V) (SETQ N (ARRAYSIZE A)) (SETQ TYPE (ARRAYTYP A)) (SETQ ORIG (ARRAYORIG A))) (T (RETURN (HELP V "not array")))) (SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER)) (NUMBERP TYPE))) (* ; "note if this array has different ELTD.") (SETQ M 1) LP (COND ((NOT (IGREATERP M N)) (push RESULT (ELT A (SUB1 (IPLUS M ORIG)))) (* ;; "check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out avoids lots of NILs.") (AND DOUBLEFLG (COND ((NUMBERP TYPE) (* ; "check for M being in the double pointer part of the array") (IGREATERP M TYPE)) (T T)) (ELTD A (SUB1 (IPLUS M ORIG))) (SETQ FLG T)) (SETQ M (ADD1 M)) (GO LP))) (push RESULT FLG) (COND ((NULL FLG) (* ; "if FLG is NULL, there are non-NIL double word entries.") (GO OUT))) (SETQ M (COND ((EQ TYPE (QUOTE DOUBLEPOINTER)) (* ; "all entries are double") 1) ((NUMBERP TYPE) (* ; "first TYPE elements in the array are numbers") (ADD1 TYPE)))) LP1 (COND ((NOT (IGREATERP M N)) (push RESULT (ELTD A (SUB1 (IPLUS M ORIG)))) (SETQ M (ADD1 M)) (GO LP1))) OUT (RETURN (REVERSE RESULT)))) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS CHANGFONT MACRO (= . DSPFONT)) ) ) (* ; "COPYRIGHT") (DEFINEQ (PRINTCOPYRIGHT [LAMBDA (FILENAME) (* ; "Edited 31-Aug-99 09:06 by rmk:") (* ; "Edited 31-Aug-99 09:01 by rmk:") (* edited%: " 1-Jan-85 20:16") (* ;;; "CALLED BY PRETTYDEF TO PUT a copyright notice on a file. The globalvar COPYRIGHTOWNERS is used to determine the possible copyright owners when it is determined the file doesn't have a copyright yet and has never been asked if the programmer wanted one. The whole copyright mechanism can be turned off by setting COPYRIGHTFLG to NEVER -- originaly NIL. If the file is copyrighted, any year the file is editted the new year is tacked on to the list of copyright years. The copyright notice comes immediately after the FILECREATED expression * *") (PROG [(OWNER (GETPROP FILENAME 'COPYRIGHT] (AND [OR OWNER (AND COPYRIGHTFLG (SETQ OWNER (ASKUSER (if (EQ COPYRIGHTFLG 'DEFAULT) then 0 else DWIMWAIT) (CONSTANT (CHARACTER (CHARCODE LF))) (CONCAT "Copyright owner for file " FILENAME ": ") (NCONC [MAPCAR COPYRIGHTOWNERS (FUNCTION (LAMBDA (X) (LIST (CAR X) "" 'EXPLAINSTRING (CONCAT (CAR X) " - " (CADR X)) 'RETURN (CADR X) 'CONFIRMFLG T] (CONS (if (SETQ OWNER (ASSOC DEFAULTCOPYRIGHTOWNER COPYRIGHTOWNERS)) then (LIST (CONSTANT (CHARACTER (CHARCODE LF))) (CONCAT DEFAULTCOPYRIGHTOWNER " ") 'EXPLAINSTRING (CONCAT " - " (CADR OWNER) " [Default]") 'NOECHOFLG T 'RETURN (CADR OWNER)) else '(% "No copyright notice now " EXPLAINSTRING " - no copyright notice now [Default]" NOECHOFLG T RETURN NIL)) DEFAULTCOPYRIGHTKEYLST)) T T)) (/PUTPROP FILENAME 'COPYRIGHT (SETQ OWNER (LIST OWNER] (COND ((NEQ (CAR OWNER) 'NONE) (PROG ((CURRENTYEAR (SUBATOM (DATE (DATEFORMAT YEAR.LONG NO.TIME)) -4 -1))) (OR (MEMBER CURRENTYEAR (CDR OWNER)) (NCONC1 OWNER CURRENTYEAR))) (PRINTCOPYRIGHT1 OWNER]) (PRINTCOPYRIGHT1 [LAMBDA (OWNER) (* ; "Edited 21-Feb-2021 10:58 by rmk:") (* ; "Edited 6-Apr-90 10:36 by jds") (PROG ((DATES (CDR OWNER)) (SEMICOLON (AND (READTABLEPROP *READTABLE* 'COMMONLISP) "; ")) (PRIVATE NIL)) (COND ((EQ (CAR DATES) T) (SETQ PRIVATE T) (pop DATES))) (COND (SEMICOLON (* ; "do CommonLisp style comment") (PRIN1 SEMICOLON)) (T (* ; "Print IL-style comment, with a ; in it so the pretty printer will render it as a CL-style comment.") (printout NIL "(* ; %"" T))) (PRIN3 "Copyright (c) ") [for Y START END on DATES do (* ;  "print years of copyright, e.g., 1985, 1986. Print intervals for successive years") (SETQ START (SETQ END (CAR Y))) (FOR NEXT IN (CDR Y) WHILE (EQ (ADD1 END) NEXT) DO (SETQ END NEXT) (POP Y)) (PRIN3 START) (CL:UNLESS (EQ START END) (PRIN3 "-") (PRIN3 END)) (COND ((CDR Y) (PRIN3 ", "] (PRIN3 " by ") (PRIN3 (CAR OWNER)) (PRIN3 ".") (AND COPYRIGHTSRESERVED (PRIN3 " All rights reserved.")) (TERPRI) [COND (PRIVATE (for LINE in (CONS (CONCAT "The following program was created in " (CAR DATES) " but has not been published") '( "within the meaning of the copyright law, is furnished under license," "and may not be used, copied and/or disclosed except in accordance" "with the terms of said license.")) do (COND (SEMICOLON (PRIN1 SEMICOLON))) (PRIN3 LINE) (TERPRI] (COND ((NOT SEMICOLON) (PRIN3 "%")") (TERPRI))) (TERPRI]) (SAVECOPYRIGHT (LAMBDA (FILENAME) (* lmm "25-DEC-82 16:48") (* ;; "Called from PRETTYDEF to save copyright info on end of file") (AND (NEQ COPYRIGHTFLG (QUOTE NEVER)) (PROG (X) (COND ((SETQ X (GETPROP FILENAME (QUOTE COPYRIGHT))) (PRINT (LIST (QUOTE PUTPROPS) FILENAME (QUOTE COPYRIGHT) X))))))) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T) (NOLINKFNS PRINTCOPYRIGHT1)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER COPYRIGHTSRESERVED) ) (RPAQ? COPYRIGHTFLG ) (RPAQ? DEFAULTCOPYRIGHTOWNER ) (RPAQ? COPYRIGHTPRETTYFLG T) (RPAQ? COPYRIGHTOWNERS ) (RPAQ? DEFAULTCOPYRIGHTKEYLST '((NONE " " EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN 'NONE) [%[ "owner: " EXPLAINSTRING "[ - new copyright owner -- type one line of text" NOECHOFLG T KEYLST (( " " RETURN (SUBSTRING (CADR ANSWER) 2 -2] (%] "No copyright notice now " EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL))) (RPAQ? COPYRIGHTSRESERVED T) (RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (RPAQ? *DEFAULT-MAKEFILE-ENVIRONMENT* ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG *DEFAULT-MAKEFILE-ENVIRONMENT* *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*) ) (RPAQ? COMMENTFLG '*) (RPAQ? **COMMENT**FLG '" **COMMENT** ") (RPAQ? PRETTYFLG T) (RPAQ? %#RPARS 4) (RPAQ? CLISPIFYPRETTYFLG ) (RPAQ? PRETTYTRANFLG ) (RPAQ? FONTCHANGEFLG ) (RPAQ? CHANGECHARTABSTR ) (RPAQ? PRETTYTABFLG T) (RPAQ? DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST)) (RPAQ? AVERAGEVARLENGTH 4) (RPAQ? AVERAGEFNLENGTH 5) (RPAQ? %#CAREFULCOLUMNS 0) (RPAQ? CHANGECHAR '%|) (RPAQ? ENDLINEUSERFN ) (RPAQ? PRETTYDEFMACROS ) (RPAQ? PRETTYPRINTMACROS ) (RPAQ? PRETTYEQUIVLST ) (RPAQ? PRETTYPRINTYPEMACROS ) (RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *)) (RPAQ? SYSPROPS '(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS AMAC ARGNAMES BLKLIBRARYDEF BROADSCOPE CLISPCLASS CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE EDIT-SAVE EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP FILEHISTORY FILEMAP FILETYPE GLOBALVAR HISTORY I.S.OPR I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS OLDVALUE OPD SETFN SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET TRYHARDER)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT) (SPECVARS FNSLST FILEFLG)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG PRETTYHEADER FILERDTBL PRETTYEQUIVLST PRETTYTRANFLG CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS COMMENTFLG) ) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT LAMBDAFONT PRETTYCOMFONT COMMENTFONT **COMMENT**FLG PRETTYPRINTMACROS)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILESLOAD (IMPORT) FILEPKG) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPT PP* PP) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS PRETTY COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 1999 2018 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5927 40668 (PRETTYDEF 5937 . 14200) (PRETTYDEFCOMS 14202 . 14884) (PRETTYDEF0 14886 . 15077) (PRETTYDEF1 15079 . 16842) (PRINTDATE 16844 . 18080) (PRINTDATE1 18082 . 19287) (PRINTFNS 19289 . 19858) (PRETTYCOM 19860 . 26201) (PRETTYVAR 26203 . 27241) (PRETTYVAR1 27243 . 29461) (PRETTYCOM1 29463 . 30167) (ENDFILE 30169 . 30265) (MAKEDEFLIST 30267 . 30671) (PP 30673 . 30949) (PP* 30951 . 31264) (PPT 31266 . 31585) (PRETTYPRINT 31587 . 34739) (PRETTYPRINT1 34741 . 36627) (PRETTYPRINT2 36629 . 37945) (PRETTYPRINT3 37947 . 38902) (PRINTDEF1 38904 . 39912) (SUPERPRINTEQ 39914 . 40008) ( SUPERPRINTGETPROP 40010 . 40154) (CHANGEFONT 40156 . 40666)) (40669 46015 (READARRAY 40679 . 41605) ( PRINTARRAY 41607 . 43347) (READARRAY-FROM-LIST 43349 . 44454) (PRINTARRAY-TO-LIST 44456 . 46013)) ( 46142 53355 (PRINTCOPYRIGHT 46152 . 49924) (PRINTCOPYRIGHT1 49926 . 53050) (SAVECOPYRIGHT 53052 . 53353))))) STOP \ No newline at end of file diff --git a/sources/PRETTY.LCOM b/sources/PRETTY.LCOM index 0e727c762c855adf59011dd3b187efd7074ccd7e..9bdeb6e7ce2e49cccf6978aa9c9005cbe34b55dd 100644 GIT binary patch delta 971 zcmaJ=&u`LT7^X$D!GvsVUi`7WehUepkbYlV+OlN2u}&I+lCGIqOk^7nz^RxG55$=L z3obPtOm^{Z!bB3Y%n(n;i&y;{whMO;`n82^2eTgD@9FcrKfk{Hb3atvBP(D&?n@*8EQ6<#wsEGhZ-N(_Bl;VQ%k`_oem1nxWm# zn0x){f^wE5kw_pYZ!{}qK=>Swg_M9(f`X!f$g-AI(}ucWs!M?W*Maqz3G)}W00B`V z0)|p;<9W5R1I3oWA5K+0^zqx~^GL%!CKfMen0o(h{V>CR(Yh^%tT`UN zn$Py=Ig|r46WEt82EE<2N$b`K+5K?fdGDwh#yQ4pe+OM_zjh+p@0en!INsBPZ0+cg zw>zhgyGiwNJ=E`9JdBD-!tyX0Cta1Us31XF&!-nmz(gF@!B`o_aBfFDC_^A82U=1b z08wxP%d}aV&K-bGa{9>&hF+jsiaD9q8f^KBp{}ULDqUEc%;ofaR$H;XfXE7W4wI)PLQOeOBN0AuJK^V~rTu1QV*t%lh5{^a#c`Y0G2ewu0)c^nh delta 873 zcmZ`%U279T6wM~pCeeV>f}x0BM^c(#!`|85*=z!(G1;0WpQc+;e9|T~(LhR41qJC} zXjq@bU*J=;MnshQ7sLmB_RWImtMtX$NwyZH3%hgX&N=6vVei4d^krY#xiO1uF}vAY zq%x*}Vp`GDC=c$jxlX&kx!&zHm-^iYz4c~)sa7{_`&Kf;1|O6_-dq{{zED4+O(v5B z8h5su4Iuw`qLD@<@yNo8RWfsRGi#gq|46*CY!DbcxqRvP))3K{hKe(kqHYA|lLSGO z(>ymCgU9p7ht_s8{_9hQ1_|CiZ)dNT%tRcdb0;L9wCrEo@bM??eqK*^-Q_HuDoE{L zPuuSb{g0vfV7R{$rb9I>%IN1E=Ps?b5SrRexWF9Q_Oc@w%Apt9 Date: Sun, 21 Feb 2021 17:34:42 -0800 Subject: [PATCH 11/31] WHEELSCROLL: a little tuning, plus a WHEELSCROLL.TXT file --- lispusers/WHEELSCROLL | 2 +- lispusers/WHEELSCROLL.LCOM | Bin 2587 -> 3526 bytes lispusers/WHEELSCROLL.TXT | Bin 0 -> 1415 bytes 3 files changed, 1 insertion(+), 1 deletion(-) create mode 100644 lispusers/WHEELSCROLL.TXT diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL index 5cb1b473..baf31632 100644 --- a/lispusers/WHEELSCROLL +++ b/lispusers/WHEELSCROLL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "17-Feb-2021 22:37:01"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;31 5760 changes to%: (FNS WHEELSCROLL) previous date%: "17-Feb-2021 22:22:29" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;28) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME) (INITVARS (WHEELSCROLLDELTA 10) (WHEELSCROLLSETTLETIME 50)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (DIRECTION DELTA) (* ; "Edited 17-Feb-2021 22:35 by rmk:") (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. Here we try to detect and ignore wheel motions in the first case, we don't yet have the information to solve the second. (This should not be an issue with a trackpad)") (* ;; "") (* ;; "Below we ignore a motion interrupt if it is received when a mouse button is down. We also ignore if the MIDDLE shows up within an interval of WHEELSCROLLSETTLETIME milliseconds.") (CL:WHEN (LET ((W (WHICHW))) (* ;; "Returns the window that should be wheel scrolled, skipping windows that have no SCROLLFN or are pop-up scrollbar window for some other window. ") (* ;; "The behavior of pop-up scrollbars (via IN/SCROLL/BAR? in WINDOWSCROLL) is inconsistent with a direct call to SCROLLW in that SCROLLW uses SCROLLBYREPAINTFN for a window without a SCROLLFN while the pop-up does nothing. We implement th pop-up behavior, otherwise odd windows like those holding menus would scroll in a funky way.") (CL:WHEN [AND W (WINDOWPROP W 'SCROLLFN) (NOT (WINDOWPROP W (CL:IF (EQ DIRECTION 'VERTICAL) 'VERTICALSCROLLBARFOR 'HORIZONTALSCROLLBARFOR)] (CL:WHEN [OR T (AND (MOUSESTATE UP) (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME] (* ;; "Always scroll from the MOUSE process. Need the KWOTE because PROCESS.EVAL uses CL:EVAL which doesn't like raw windows") [PROCESS.EVAL (FIND.PROCESS 'MOUSE) (CL:IF (EQ DIRECTION 'VERTICAL) `(SCROLLW ,(KWOTE W) 0 ,DELTA) `(SCROLLW ,(KWOTE W) ,DELTA 0))]))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I) (CADR I) (CADDR I)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME) ) (RPAQ? WHEELSCROLLDELTA 10) (RPAQ? WHEELSCROLLSETTLETIME 50) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1046 5231 (ENABLEWHEELSCROLL 1056 . 1481) (WHEELSCROLL 1483 . 3887) ( INSTALL-WHEELSCROLL 3889 . 4952) (LISPINTERRUPTS.WHEELSCROLL 4954 . 5229))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Feb-2021 09:39:06"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42 6734 changes to%: (VARS WHEELSCROLLCOMS) (FNS WHEELSCROLL) previous date%: "20-Feb-2021 17:34:35" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;39) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) (INITVARS (WHEELSCROLLDELTA 20) (WHEELSCROLLSETTLETIME 50) (\WHEELSCROLLINPROGRESS NIL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:") (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)") (* ;; "") (CL:WHEN (MOUSESTATE UP) (* ;  "Ignore interrupt if a button is down") [LET ((W (WHICHW))) (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within  the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME))) (CL:WHEN W (* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ") (IF (WINDOWPROP W 'SCROLLFN) THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE) (CL:IF (EQ DIRECTION 'VERTICAL) `(WHEELSCROLL.DOIT ,(KWOTE W) 0 ,DELTA) `(WHEELSCROLL.DOIT ,(KWOTE W) ,DELTA 0))] ELSEIF (EQ DIRECTION 'VERTICAL) THEN (* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.") (CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR) (\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA)) (GETMOUSESTATE)) ELSEIF (EQ DIRECTION 'HORIZONTAL) THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR) (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX) LASTMOUSEY) (GETMOUSESTATE))))])]) (WHEELSCROLL.DOIT [LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:") (* ;; "This does the actual wheel scrolling, runing in the mouse process.") (* ;; "There have been instances where the window gets garbled as the wheel moves. The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.") (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.") (CL:UNLESS \WHEELSCROLLINPROGRESS (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I) (CADR I) (CADDR I)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) ) (RPAQ? WHEELSCROLLDELTA 20) (RPAQ? WHEELSCROLLSETTLETIME 50) (RPAQ? \WHEELSCROLLINPROGRESS NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1187 6142 (ENABLEWHEELSCROLL 1197 . 1622) (WHEELSCROLL 1624 . 4160) (WHEELSCROLL.DOIT 4162 . 4798) (INSTALL-WHEELSCROLL 4800 . 5863) (LISPINTERRUPTS.WHEELSCROLL 5865 . 6140))))) STOP \ No newline at end of file diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM index f3c48249f5b7fd0308ab6d52cb58f4996952a6cd..97812037d1609f8a787cad5ce2aae88c1e6bf51a 100644 GIT binary patch literal 3526 zcmb_eOK;mo5TQNyuvrOnL}OGymN4f2O0*DO3ffO%ftg79rhJh+VTu&8}wO%>nPr zU?`O>8y@fPJ%7?ag5wcdrEfb?3~9xl-7EB@jBi5VD;=;>toLS>}>UySK8lV-KVJ(>;3vl`$I_nx^?=U@SLDF z#OK9nR=ip7^hR%R@td{w`nqK7XEINn{mjcN7xeqxk z@o?S)wc`vR2bg+lEb=w1ZAe;{-bmm{t{b8=WW)qA-Y=h`ebU zd{vkEZqUV*Q5XdwU}u=yORB|%y`)@PvX}52iGl`=;{x4wJSdxhz0xg=nLI;wnICr| zDo+Ij+HJ8$s|%QVyUhobLzn}PsbyjndrmAZ+QHPTOv(FTk|MN%h&>4W#2L4{x)U{n z2(2k8BJ6m|#vLRrRSzi>*rrj!8gp7mX(|9>6=ACrpi>E{s2!u=1}p($SYvUev?wiC zCMRHT0udqHGDT7EBuU`Myqt(#1l`EZB)>Sr!RAe58Td|{Ld@K6un6vm zf)Ij+M;*Tt=FuJP_zpC&P{z)0^6I&d9249fteMZXRV^iwaUjwu+={MaHfq>1&{BDg zbUE6XBFGQ}j4*B3RXP^)5x{1I34o$SjwWMVOrVezeP5uLC=r*P(zMlw z2t@n+YXPq(iZZjG!IBmXL5qhdm-8<_Os(xBY-~RKAaRa#5N}_*?QOiF6R@m>07=(k z=flF7n26anuZ56H%*N!s!XKFXn4w-?@z~TQ3?qR}ZF*&kSt9C$Ni1T70|QG6lUV~D z^DKp3Zt8$>dlC#0z;p4b&|5ESy%g_*sn!bqR#GCqa+z@7>CKkRfPGwmT`eOs;QYqQ z>gzwbN2^tkIC$hbzPv-Q8PtQ0?}kt+!UT1rt`d z*48{9Z%#hKEDjN>iHtS0w!1^f^6O)scB-ol_KCj|vL?_(ZK81~RhiWX-VpCt<> zOHF)6(bdsJ(O2ZMljA6vu4?qO`FTL>F8UJq1;AhM2pv9XFXU?pbHa^|f{qR~14EIBGy@qpF>{ zWa+|2WFZDNW(H_rVn<@(6R@x|^doR~s;EVrPIvG9?*IPp>AtVMUwyN+ik+rEeBLC8 zU?8MpIvs?kgI&eM({KHqE02a@)FB(33^P#cSF5nuv9Z|ohN}BPNWGZ4UAhU^L<{R9 zwq|0mofd)@qru_+@EA_U>mAVjC;>J9CD;BPNtBZI^oS{BW45axSw{Km8xJN^S(20` zNvylF#Ig^crL#Ll_M`UYls(=r!i%@%byl9s1(`i7<5GC3Ij@(9W#{*@mlq$+>erPy z7-`xoccgv#|NBH@Lg0=IS54DO_v)xB>DWTB9dnN+i9!2r2zDF%Alfu8Ay^KiBIl_9 z+kiLVX%Hp7n9dtMeHwQIuV`q& z7Vjk#ECP(j!5)vgZa6Q0;>JFY!E7z$*Ene}xabeqB%q^4LlqMWi?Eq8O6N|qXlbm> nelFjZ^FJ%KTNpJ!&#RUDH^r^yLFHk7Q28z6oU7~kJN40Dy%Uxf diff --git a/lispusers/WHEELSCROLL.TXT b/lispusers/WHEELSCROLL.TXT new file mode 100644 index 0000000000000000000000000000000000000000..8cab8ba864d0260197d41a26ba0c4cd0083c3fcb GIT binary patch literal 1415 zcmZ`(T~FIE6b)<>+N3=0{XVu*`KrVVZ(ZpIT7U_Vx>q;3X{;u8WIILOPusuRFJR|7 z1v-gUZR6PYh+2Bz& zy}c#`)K(QNxmQ76gIz8qUH}+8$`XCkbTGS_e92}z1?cu>NHow!2aU~d=#7wv;ZO+T zEdc`Ew~Xp&lv@*o6}(|%LfBe4Enva@s}L8n>|wIoW_&VCKT1v0H4An?NUhZ-2=r&7 zOR&W%uPCoIxIu{2k8~apUFv0p#I>qB_O#S%rc(KUsa_wz6grx==7x<(W6gP*X7C9) z&KU_F>Z};BoiZK-fGvD~OfF98=_yHU;+_(D9g{#=vkN*`^=tiJju%k91EeY_H+MdcAr5GJWnZCrqXz)oH%cm*5vbT&ST&CbTBqc{ka zMbJ(}Y|L;P1X7;BFgw?^!gHly6|=T0R7KMl)~N6OHq@J|YzS|{%f2T{_8KVyvIUb~ z8tbAFr=4@)oeVF*y{N+~bdJx7=Hg=M+32Fc{uW&bAYObcN;Gn0BV38;j}O)gZXJ7% z6;Y#4J=~^pS#lm|@PFoqLJ+o=>q6X6Z;z`;zT+z@Iw$^?#@o_6<`{IXuzZa6BIXdn zY Date: Sun, 21 Feb 2021 17:47:34 -0800 Subject: [PATCH 12/31] TABLEBROWSER uses newer TABLEBROWSERDECLS, older TBDECLS is deprecated TABLEBROWSER uses newer TABLEBROWSERDECLS, older TBDECLS is deprecated --- library/TABLEBROWSER | 2 +- library/TABLEBROWSER.LCOM | Bin 27980 -> 28318 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/library/TABLEBROWSER b/library/TABLEBROWSER index 090b2b1b..f9abe13e 100644 --- a/library/TABLEBROWSER +++ b/library/TABLEBROWSER @@ -1 +1 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Dec-2018 17:25:13"  {DSK}kaplan>Local>medley3.5>lispcore>library>TABLEBROWSER.;3 57302 changes to%: (FNS TB.REDISPLAY.ITEMS) previous date%: "26-Jun-99 00:30:27" {DSK}kaplan>Local>medley3.5>lispcore>library>TABLEBROWSER.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993, 1994, 1995, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TABLEBROWSERCOMS) (RPAQQ TABLEBROWSERCOMS ((COMS (* ; "Entries") (FNS TB.MAKE.BROWSER TB.REPLACE.ITEMS) (FNS TB.DELETE.ITEM TB.UNDELETE.ITEM TB.INSERT.ITEM TB.REMOVE.ITEM TB.NORMALIZE.ITEM TB.REDISPLAY.ITEMS TB.SELECT.ITEM TB.UNSELECT.ITEM TB.UNSELECT.ALL.ITEMS) (FNS TB.NUMBER.OF.ITEMS TB.NTH.ITEM TB.COLLECT.ITEMS TB.MAP.ITEMS TB.MAP.DELETED.ITEMS TB.MAP.SELECTED.ITEMS TB.FIND.ITEM TB.ITEM.SELECTED? TB.ITEM.DELETED?) (FNS TB.CLEAR.LINE TB.USERDATA TB.WINDOW)) (COMS (* ; "Display") (FNS TB.REPAINTFN TB.RESHAPEFN TB.SCROLLFN TB.DISPLAY.LINES TB.PRINT.LINE TB.FIRST.VISIBLE.ITEM# TB.LAST.VISIBLE.ITEM# TB.ITEM.VISIBLE? TB.ITEM.FROM.YCOORD TB.BOTTOM.OF.ITEM TB.SHOW.DELETION TB.SHOW.SELECTION TB.UPDATE.DISPLAY TB.ITEM.UPDATABLE?)) (COMS (* ; "Selection") (FNS TB.BUTTONEVENTFN TB.DO.UNLESS.BUSY TB.DO.ITEM.SELECTION TB.CONTIGUOUS.SELP TB.DECONSIDERRANGE TB.CONSIDERRANGE TB.DESELECTRANGE TB.RECONSIDERRANGE TB.SELECTRANGE TB.UNDOSELECTION TB.FIND.SELECTED.ITEM TB.REV.FIND.SELECTED.ITEM) (FNS TB.COPYBUTTONEVENTFN TB.SHOW.COPY.SELECTION)) (COMS (* ; "Misc state change") (FNS TB.BROWSER.BUSY TB.CLOSE/SHRINK TB.CLOSEFN TB.FINISH.CLOSE TB.FLUSH.WINDOW TB.SET.FONT TB.SHRINKFN TB.EXPANDFN TB.FIND.PREVIOUS.TAIL TB.RENUMBER.TAIL)) (COMS (* ; "Misc") (FNS TB.PROCESS) (INITVARS (TB.DELETEDLINEHEIGHT 1)) (VARS TB.SELECTION.BITMAP) (CURSORS TB.CROSSCURSOR) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TBDECLS) (CONSTANTS * TOCSTATES) (MACROS .COPYKEYDOWNP.) (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) (LOCALVARS . T))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TB.USERDATA))) (INITRECORDS TABLEBROWSER TABLEITEM) (SYSRECORDS TABLEBROWSER TABLEITEM))) (* ; "Entries") (DEFINEQ (TB.MAKE.BROWSER (LAMBDA (ITEMS WINDOWSPEC PROPS) (* ; "Edited 28-Jan-88 04:37 by bvm") (* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") (PROG ((LINESPERITEM 1) FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA WINDOW USERPROPS BROWSER ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (DECLARE (SPECVARS FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS)) (* ; "For SET below") (for TAIL on PROPS by (CDDR TAIL) do (SELECTQ (CAR TAIL) ((FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (SET (CAR TAIL) (CADR TAIL))) (push USERPROPS (LIST (CAR TAIL) (CADR TAIL))))) (SETQ WINDOW (DECODE.WINDOW.ARG WINDOWSPEC NIL NIL TITLE)) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) (SETQ BROWSER (create TABLEBROWSER TBWINDOW _ WINDOW TBFONT _ FONT TBLOCK _ (CREATE.MONITORLOCK (OR (WINDOWPROP WINDOW (QUOTE TITLE)) "Table Browser")) TB#LINESPERITEM _ (OR LINESPERITEM 1) TBBASELINE _ (OR BASELINE 0) TBCOLUMNS _ COLUMNS TBPRINTFN _ PRINTFN TBCOPYFN _ COPYFN TBCLOSEFN _ CLOSEFN TBAFTERCLOSEFN _ AFTERCLOSEFN TBUSERDATA _ USERDATA TBHEADINGWINDOW _ HEADINGWINDOW TBLINETHICKNESS _ (OR LINETHICKNESS TB.DELETEDLINEHEIGHT)))) (if ITEMHEIGHT then (* ; "User explicitly controlling height variables.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with ITEMHEIGHT) (replace (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER with T)) (DSPLEFTMARGIN TB.LEFT.MARGIN WINDOW) (TB.REPLACE.ITEMS BROWSER ITEMS) (WINDOWPROP WINDOW (QUOTE SCROLLFN) (FUNCTION TB.SCROLLFN)) (WINDOWPROP WINDOW (QUOTE REPAINTFN) (FUNCTION TB.REPAINTFN)) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE COPYBUTTONEVENTFN) (FUNCTION TB.COPYBUTTONEVENTFN)) (for PROP in (QUOTE (CLOSEFN SHRINKFN RESHAPEFN)) do (* ;; "This used to be (progn (windowaddprop window 'closefn (function tb.closefn)) (windowaddprop window 'shrinkfn (function tb.shrinkfn)) (windowaddprop window 'reshapefn (function tb.reshapefn))). However, we want to be careful to put our stuff on before any attached window stuff, so that we can reject a CLOSE, for example, before CLOSEATTACHEDWINDOWS has already closed them. Could always put on front, but it's probably better to put our functions after any the user might have explicitly put there already.") (LET ((OLDP (WINDOWPROP WINDOW PROP)) (FN (PACK* "TB." PROP))) (if (NULL OLDP) then (SETQ OLDP (LIST FN)) else (for TAIL on (OR (LISTP OLDP) (SETQ OLDP (LIST OLDP))) do (if (EQ (CAR TAIL) FN) then (* ; "Window already has our fn!") (RETURN) elseif (STRPOS "ATTACHED" (CAR TAIL)) then (* ; "Insert before this attached window hacker") (RETURN (ATTACH FN TAIL))) finally (* ; "Put at end") (NCONC1 OLDP FN))) (WINDOWPROP WINDOW PROP OLDP))) (replace (TABLEBROWSER TBREADY) of BROWSER with T) (RETURN BROWSER))) ) (TB.REPLACE.ITEMS (LAMBDA (BROWSER NEWITEMS) (* ; "Edited 27-Jan-88 16:27 by bvm") (* ;; "Completely replace the current items with the specified items") (LET ((N 0) FIRSTSEL) (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (for ITEM in NEWITEMS do (* ; "Number the items") (freplace TI# of (\DTEST ITEM (QUOTE TABLEITEM)) with (add N 1))) (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL) (freplace (TABLEBROWSER TBITEMS) of BROWSER with NEWITEMS) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with N) (freplace (TABLEBROWSER TB#DELETED) of BROWSER with (for ITEM in NEWITEMS count (ffetch TIDELETED of ITEM))) (COND ((SETQ FIRSTSEL (TB.FIND.SELECTED.ITEM BROWSER 1 N)) (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with FIRSTSEL) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL N))) (T (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with (ADD1 N)) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with 0))) (TB.SET.FONT BROWSER) (LET ((REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER)))) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) ) (DEFINEQ (TB.DELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((NOT (ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM)))) (freplace (TABLEITEM TIDELETED) of ITEM with T) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 1) (if (TB.ITEM.UPDATABLE? BROWSER ITEM T) then (TB.SHOW.DELETION BROWSER ITEM (ffetch (TABLEBROWSER TBWINDOW) of BROWSER) (QUOTE REPLACE)))))) ) (TB.UNDELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM))) (freplace (TABLEITEM TIDELETED) of ITEM with NIL) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) -1) (COND ((TB.ITEM.UPDATABLE? BROWSER ITEM T) (LET ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE ERASE)) (* ; "reprint the line sans deletion mark") (TB.PRINT.LINE BROWSER ITEM WINDOW (ffetch (TABLEBROWSER TBPRINTFN) of BROWSER)))))))) ) (TB.INSERT.ITEM (LAMBDA (BROWSER NEWITEM BEFOREITEM) (* ; "Edited 27-Jan-88 16:08 by bvm") (* ;;; "Inserts NEWITEM in TABLEBROWSER before item BEFOREITEM or at the end if BEFOREITEM is NIL") (LET ((LASTITEM# (ffetch (TABLEBROWSER TB#ITEMS) of (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))))) BEFORE# TAIL N) (SETQ NEWITEM (\DTEST NEWITEM (QUOTE TABLEITEM))) (if BEFOREITEM then (SETQ BEFORE# (OR (FIXP BEFOREITEM) (ffetch TI# of (\DTEST BEFOREITEM (QUOTE TABLEITEM))))) (COND ((OR (> BEFORE# LASTITEM#) (< BEFORE# 1)) (* ; "Check for bad values") (\ILLEGAL.ARG BEFOREITEM))) else (SETQ BEFORE# (ADD1 LASTITEM#))) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (if (EQ BEFORE# 1) then (* ; "Goes at the beginning (or at the end of a null list)") (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CONS NEWITEM (ffetch (TABLEBROWSER TBITEMS) of BROWSER)))) else (* ; "Somewhere else--find the tail") (SETQ TAIL (if (NULL BEFOREITEM) then (* ; "Insert at end") (FLAST (OR (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER) (ffetch (TABLEBROWSER TBITEMS) of BROWSER))) else (TB.FIND.PREVIOUS.TAIL BROWSER BEFORE#))) (RPLACD TAIL (SETQ TAIL (CONS NEWITEM (CDR TAIL))))) (* ;; "Now (CAR TAIL) is the new item") (TB.RENUMBER.TAIL BROWSER TAIL BEFORE#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (ADD1 LASTITEM#)) (COND ((ffetch TIDELETED of NEWITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) 1))) (* ;; "Update first & last selected item if they fall after the insertion, or if the new item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((ffetch TISELECTED of NEWITEM) BEFORE#) (T (ADD1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBLASTSELECTEDITEM of BROWSER with (ADD1 N))) ((ffetch TISELECTED of NEWITEM) (freplace TBLASTSELECTEDITEM of BROWSER with BEFORE#))) (TB.UPDATE.DISPLAY BROWSER BEFORE# (QUOTE INSERT)))) ) (TB.REMOVE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:09 by bvm") (* ;;; "Removes ITEM from TABLEBROWSER") (LET ((LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (ITEM# (ffetch TI# of (\DTEST ITEM (QUOTE TABLEITEM)))) N TAIL) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (COND ((EQ ITEM# 1) (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CDR (ffetch (TABLEBROWSER TBITEMS) of BROWSER))))) (T (RPLACD (SETQ TAIL (TB.FIND.PREVIOUS.TAIL BROWSER ITEM#)) (SETQ TAIL (CDDR TAIL))))) (TB.RENUMBER.TAIL BROWSER TAIL ITEM#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (SUB1 LASTITEM#)) (COND ((ffetch TIDELETED of ITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) -1))) (* ;; "Update first & last selected item if they fall after the deletion or if the old item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the first selected, so look for next one after it") (OR (TB.FIND.SELECTED.ITEM BROWSER ITEM#) LASTITEM#)) (T (* ; "Item numbers are decremented") (SUB1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBLASTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the last selected, so look for next one before it") (OR (TB.REV.FIND.SELECTED.ITEM BROWSER NIL (SUB1 ITEM#)) 0)) (T (SUB1 N)))))) (TB.UPDATE.DISPLAY BROWSER ITEM# (QUOTE REMOVE)))) ) (TB.NORMALIZE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:22 by bvm") (* ;; "Scroll, if necessary, so that ITEM is visible in browser.") (LET* ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM)) (CLIP (DSPCLIPPINGREGION NIL WINDOW))) (COND ((OR (> (fetch (REGION BOTTOM) of CLIP) BOT) (< (fetch (REGION PTOP) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (* ; "Scroll so that item's midline is at midline of window") (SCROLLBYREPAINTFN WINDOW 0 (- (+ (fetch (REGION BOTTOM) of CLIP) (IQUOTIENT (fetch (REGION HEIGHT) of CLIP) 2)) (+ BOT (IQUOTIENT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) 2)))))))) ) (TB.REDISPLAY.ITEMS [LAMBDA (BROWSER FIRSTITEM LASTITEM) (* ; "Edited 1-Dec-2018 17:25 by rmk:") (* ; "Edited 2-Feb-88 11:53 by bvm:") (* ;; "Force redisplay of all items from FIRSTITEM to LASTITEM, e.g., because their content or format changed. We'll only redisplay the visible ones, of course. Also, if browser isn't open, we'll save the change until browser is expanded") (LET [(REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER 'TABLEBROWSER] (if (AND (NULL FIRSTITEM) (NULL LASTITEM)) then (* ; "We're being told to redisplay the whole browser, so recompute the extent while we're at it (it might have gotten smaller).") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0)) (SETQ FIRSTITEM (IMAX [COND ((NULL FIRSTITEM) 1) ((FIXP FIRSTITEM)) (T (ffetch TI# of (\DTEST FIRSTITEM 'TABLEITEM] (TB.FIRST.VISIBLE.ITEM# BROWSER REGION))) (SETQ LASTITEM (IMIN [COND ((NULL LASTITEM) (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) ((FIXP LASTITEM)) (T (ffetch TI# of (\DTEST LASTITEM 'TABLEITEM] (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (if (AND (>= LASTITEM FIRSTITEM) (TB.ITEM.UPDATABLE? BROWSER FIRSTITEM)) then (* ;; "RMK: For whatever reason, on an FB recompute, this gets called after the items have first been displayed but not in proper alignment. This redisplays them to get the alignment, but the window is garbled if the old stuff isn't cleared first. So, added the CLEARW") (CLEARW (ffetch (TABLEBROWSER TBWINDOW) of BROWSER)) (TB.DISPLAY.LINES BROWSER FIRSTITEM LASTITEM]) (TB.SELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (LET ((N (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))) (TB.SELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N T) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE REPLACE))))) ) (TB.UNSELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:09 by bvm") (if (ffetch (TABLEITEM TISELECTED) of (\DTEST ITEM (QUOTE TABLEITEM))) then (LET ((N (ffetch (TABLEITEM TI#) of ITEM))) (TB.DESELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE ERASE)))))) ) (TB.UNSELECT.ALL.ITEMS (LAMBDA (BROWSER) (* ; "Edited 29-Jan-88 12:14 by bvm") (* ;; "User entry for unselecting all items in the browser. ") (LET ((START (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (END (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER))) (if (<= START END) then (for I from START to END bind (UPDATABLE _ (TB.ITEM.UPDATABLE? BROWSER START)) ITEM when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) do (freplace TISELECTED of ITEM with NIL) (if UPDATABLE then (TB.SHOW.SELECTION BROWSER I (QUOTE ERASE)))) (freplace TBFIRSTSELECTEDITEM of BROWSER with (ADD1 (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (freplace TBLASTSELECTEDITEM of BROWSER with 0)))) ) ) (DEFINEQ (TB.NUMBER.OF.ITEMS (LAMBDA (BROWSER TYPE) (* ; "Edited 27-Jan-88 16:16 by bvm") (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (SELECTQ TYPE (NIL (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (DELETED (ffetch (TABLEBROWSER TB#DELETED) of BROWSER)) (SELECTED (for I from (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER) to (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER) count (ffetch (TABLEITEM TISELECTED) of (TB.NTH.ITEM BROWSER I)))) (\ILLEGAL.ARG TYPE))) ) (TB.NTH.ITEM (LAMBDA (BROWSER N) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;; "Return the Nth item of BROWSER, or NIL if N is out of range.") (* ;; "Browser items are currently stored as a simple list. To make most accesses reasonable, we save a hint to a recent tail of the list to speed up the search.") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET (TAIL TAILN) (if (AND (> N 0) (OR (AND (SETQ TAIL (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER)) (>= N (SETQ TAILN (ffetch (TABLEITEM TI#) of (CAR TAIL))))) (PROG1 (SETQ TAIL (ffetch (TABLEBROWSER TBITEMS) of BROWSER)) (* ; "Item is not in hint tail, have to search whole list") (SETQ TAILN 1)))) then (while (< TAILN N) do (if (NULL (SETQ TAIL (CDR TAIL))) then (* ; "Greater than last item. I could have done a comparison against #items, but it is rare to ask for this (and we never do internally).") (RETURN NIL)) (add TAILN 1) finally (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL) (* ; "Store away the new hint. This makes ascending iterations constant time, rather than n^2.") (RETURN (CAR TAIL)))))) ) (TB.COLLECT.ITEMS (LAMBDA (BROWSER PREDFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) collect ITEM when (OR (NULL PREDFN) (CL:FUNCALL PREDFN BROWSER ITEM)))) ) (TB.MAP.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEMS (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (COND (ITEMS (for ITEM in ITEMS do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (CL:FUNCALL NULLFN BROWSER))))) ) (TB.MAP.DELETED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each deleted item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (COND ((NEQ (ffetch TB#DELETED of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 0) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of BROWSER) when (ffetch TIDELETED of ITEM) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing deleted") (CL:FUNCALL NULLFN BROWSER)))) ) (TB.MAP.SELECTED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:19 by bvm") (* ;;; "Apply MAPFN to each selected item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEM# (SUB1 (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (LASTITEM# (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER)) ITEM) (COND ((< ITEM# LASTITEM#) (until (> (add ITEM# 1) LASTITEM#) when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#))) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing selected") (CL:FUNCALL NULLFN BROWSER))))) ) (TB.FIND.ITEM (LAMBDA (BROWSER PREDFN FIRST# LAST# BACKWARDSFLG) (* ; "Edited 27-Jan-88 16:20 by bvm") (* ;;; "Returns the first item in the designated range satisfying (PREDFN browser item); range defaults to whole browser") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET ((LO (COND (FIRST# (IMAX FIRST# 1)) (T 1))) (HI (COND (LAST# (IMIN LAST# (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (T (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)))) I END INCREMENT ITEM) (COND ((<= LO HI) (COND (BACKWARDSFLG (SETQ I (ADD1 HI)) (SETQ END LO) (SETQ INCREMENT -1)) (T (SETQ I (SUB1 LO)) (SETQ END HI) (SETQ INCREMENT 1))) (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (when (CL:FUNCALL PREDFN BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER (add I INCREMENT)))) do (RETURN ITEM) repeatuntil (EQ I END)))))) ) (TB.ITEM.SELECTED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TISELECTED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) (TB.ITEM.DELETED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TIDELETED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) ) (DEFINEQ (TB.CLEAR.LINE (LAMBDA (BROWSER ITEM LEFT WIDTH) (* ; "Edited 22-Jan-88 16:06 by bvm") (* ;;; "Clears the contents of ITEM's line starting at xpos LEFT for width WIDTH. Defaults to whole line") (BLTSHADE WHITESHADE (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (OR LEFT 0) (TB.BOTTOM.OF.ITEM BROWSER ITEM) WIDTH (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (QUOTE REPLACE))) ) (TB.USERDATA (CL:LAMBDA (BROWSER &OPTIONAL (NEWDATA NIL NEWP)) (* ; "Edited 27-Jan-88 16:25 by bvm") (PROG1 (ffetch (TABLEBROWSER TBUSERDATA) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (COND (NEWP (freplace (TABLEBROWSER TBUSERDATA) of BROWSER with NEWDATA))))) ) (TB.WINDOW (LAMBDA (BROWSER) (* ; "Edited 27-Jan-88 16:25 by bvm") (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) ) ) (* ; "Display") (DEFINEQ (TB.REPAINTFN (LAMBDA (WINDOW REGION) (* bvm%: "10-Sep-85 13:00") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (AND (NEQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (T (TB.BROWSER.BUSY BROWSER))))))) ) (TB.RESHAPEFN (LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 22-Jan-88 10:21 by bvm") (RESETLST (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (REGION (DSPCLIPPINGREGION NIL WINDOW)) ITEM#) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (* ; "Browser is busy, have to wait until it is ready. But don't tie up mouse!") (ALLOW.BUTTON.EVENTS) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) NIL T)) ((NOT (fetch (TABLEBROWSER TBREADY) of BROWSER)) (* ; "Browser not functional") (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION)))) (SETQ ITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER REGION)) (TB.SET.FONT BROWSER) (WYOFFSET (TIMES (SUB1 ITEM#) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) WINDOW) (TB.DISPLAY.LINES BROWSER ITEM# (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) (TB.SCROLLFN (LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* ; "Edited 22-Jan-88 17:32 by bvm") (* ;; "only scroll if can get the monitor lock") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HW) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG) (if (AND (EQ DY 0) (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER))) then (* ; "Horizontally scroll the header window together with it.") (SCROLLW HW DX DY CONTINUOUSFLG))) (T (TB.BROWSER.BUSY BROWSER)))))) ) (TB.DISPLAY.LINES (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 25-Jan-88 18:34 by bvm") (for ITEM# from (IMAX FIRST# 1) to (IMIN LAST# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) bind (WINDOW _ (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (MAXXPOS _ (fetch (TABLEBROWSER TBMAXXPOS) of BROWSER)) (PRINTFN _ (fetch (TABLEBROWSER TBPRINTFN) of BROWSER)) EXTENTCHANGED ITEM HERE EXTENT HWINDOW do (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#)) (TB.PRINT.LINE BROWSER ITEM WINDOW PRINTFN) (* ; "keep track of maximum width printed to, so window's EXTENT is always right") (COND ((< MAXXPOS (SETQ HERE (DSPXPOSITION NIL WINDOW))) (SETQ MAXXPOS HERE) (SETQ EXTENTCHANGED T))) finally (COND (EXTENTCHANGED (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with MAXXPOS) (replace (REGION WIDTH) of (SETQ EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) with MAXXPOS) (WINDOWPROP WINDOW (QUOTE EXTENT) EXTENT) (if (SETQ HWINDOW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Update heading window extent, too. Width has to account for the difference, if any, in borders.") (replace (REGION WIDTH) of (SETQ EXTENT (WINDOWPROP HWINDOW (QUOTE EXTENT))) with (+ MAXXPOS (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HWINDOW (QUOTE BORDER))))))))))) ) (TB.PRINT.LINE (LAMBDA (BROWSER ITEM WINDOW PRINTFN) (* ; "Edited 22-Jan-88 17:16 by bvm") (MOVETO TB.LEFT.MARGIN (+ (TB.BOTTOM.OF.ITEM BROWSER ITEM) (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) WINDOW) (* ; "Move to item's baseline") (POSITION WINDOW 0) (CL:FUNCALL PRINTFN BROWSER ITEM WINDOW) (TB.SHOW.SELECTION BROWSER ITEM (COND ((fetch (TABLEITEM TISELECTED) of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))) (COND ((fetch (TABLEITEM TIDELETED) of ITEM) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE REPLACE))))) ) (TB.FIRST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 16:59 by bvm") (* ;; "Computes number of the first item in TABLEBROWSER that is visible in REGION") (IMAX 1 (ADD1 (IQUOTIENT (- (ffetch (TABLEBROWSER TBORIGIN) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (fetch (REGION PTOP) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))))) ) (TB.LAST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 17:00 by bvm") (* ;; "Computes number of the last item in TABLEBROWSER that is visible in REGION") (IMIN (ffetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (CL:CEILING (- (ffetch (TABLEBROWSER TBORIGIN) of BROWSER) (fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) ) (TB.ITEM.VISIBLE? (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:12 by bvm") (* ;;; "True if any part of ITEM is visible in window of BROWSER") (LET ((CLIP (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM))) (* ;; "Check bottom of line is below top, and top of line is above the bottom") (AND (< BOT (fetch (REGION PTOP) of CLIP)) (< (fetch (REGION BOTTOM) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))))) ) (TB.ITEM.FROM.YCOORD (LAMBDA (BROWSER YPOS) (* ; "Edited 22-Jan-88 16:41 by bvm") (LET ((N (CL:CEILING (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) YPOS) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (TB.NTH.ITEM BROWSER (COND ((<= N 0) 1) (T (IMIN N (fetch (TABLEBROWSER TB#ITEMS) of BROWSER))))))) ) (TB.BOTTOM.OF.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:11 by bvm") (* ;; "Returns the y position of the bottom of specified item (number or tableitem). Add the font descent to get the baseline of the first line.") (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) (TIMES (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (OR (FIXP ITEM) (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))))) ) (TB.SHOW.DELETION (LAMBDA (BROWSER ITEM WINDOW OPERATION) (* ; "Edited 27-Jan-88 17:00 by bvm") (* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that ITEM is deleted") (LET ((THICKNESS (fetch (TABLEBROWSER TBLINETHICKNESS) of BROWSER)) (BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER))) (BLTSHADE BLACKSHADE WINDOW TB.LEFT.MARGIN (PROGN (* ;; "Center the deletion line between the baseline and the top of the item") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE THICKNESS) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL THICKNESS OPERATION))) ) (TB.SHOW.SELECTION (LAMBDA (BROWSER ITEM OPERATION) (* ; "Edited 27-Jan-88 15:42 by bvm") (* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that ITEM is selected") (LET ((BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) (BM TB.SELECTION.BITMAP)) (BITBLT BM 0 0 (fetch (TABLEBROWSER TBWINDOW) of BROWSER) 0 (PROGN (* ;; "Center the selection bitmap between the baseline and the top of the item, rounding down slightly on the grounds that the top pixel of the line tends to be blank, so the center of gravity is lower than it might be.") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE (fetch BITMAPHEIGHT of BM)) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL NIL (QUOTE INPUT) OPERATION))) ) (TB.UPDATE.DISPLAY (LAMBDA (BROWSER FROMITEM# TYPE) (* ; "Edited 11-Feb-88 11:34 by bvm") (* ;;; "Updates the display window appropriately after a TYPE operation (REMOVE or INSERT) on TABLEBROWSER that affects items starting at FROMITEM#") (PROG ((WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) (LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (ITEMHEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) (ITEMBOTTOM (TB.BOTTOM.OF.ITEM BROWSER FROMITEM#)) DELTA HEIGHT LAST# CLIP WBOTTOM EXTENTBOTTOM) (* ; "YPOS is the bottom of the line corresponding to FROMITEM#") (add (fetch (REGION HEIGHT) of EXTENT) (SETQ DELTA (SELECTQ TYPE (REMOVE (- ITEMHEIGHT)) (INSERT ITEMHEIGHT) (SHOULDNT)))) (SETQ CLIP (DSPCLIPPINGREGION NIL WINDOW)) (COND ((>= ITEMBOTTOM (fetch (REGION PTOP) of CLIP)) (* ; "Changed item above top of window, so no visible change -- just cheat the origin appropriately") (add (fetch (TABLEBROWSER TBORIGIN) of BROWSER) DELTA)) (T (* ; "Changed item visible or below bottom of window, so bottom of extent changes") (replace (REGION BOTTOM) of EXTENT with (SETQ EXTENTBOTTOM (- (fetch (REGION BOTTOM) of EXTENT) DELTA))) (COND ((<= (+ ITEMBOTTOM ITEMHEIGHT) (SETQ WBOTTOM (fetch (REGION BOTTOM) of CLIP))) (* ; "Below bottom of window, so we're done")) ((TB.ITEM.UPDATABLE? BROWSER FROMITEM#) (* ; "If window is visible, update it now") (SELECTQ TYPE (INSERT (* ; "Push everything from line FROMITEM# down one line, then redisplay item FROMITEM#") (BITBLT WINDOW 0 (+ WBOTTOM ITEMHEIGHT) WINDOW 0 WBOTTOM NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER FROMITEM# FROMITEM#)) (REMOVE (* ; "Pull everything below line FROMITEM# up one line, then redisplay last visible item(s)") (BITBLT WINDOW 0 WBOTTOM WINDOW 0 (+ WBOTTOM ITEMHEIGHT) NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER (SETQ LAST# (+ FROMITEM# (IQUOTIENT (- ITEMBOTTOM WBOTTOM) ITEMHEIGHT))) (ADD1 LAST#)) (* ; "May have to display two lines if the bottom line of window was a half line") (COND ((> EXTENTBOTTOM WBOTTOM) (* ; "Clear everything below the extent") (BLTSHADE WHITESHADE WINDOW 0 WBOTTOM NIL (- EXTENTBOTTOM WBOTTOM) (QUOTE REPLACE))))) (SHOULDNT)))))))) ) (TB.ITEM.UPDATABLE? (LAMBDA (BROWSER ITEM ONLYIFVISIBLE) (* ; "Edited 29-Jan-88 12:08 by bvm") (* ;;; "True if window of BROWSER is open. If false, we update the TBUPDATEFROMHERE field, denoting that we should repaint window when it is opened. If ONLYIFVISIBLE is true, we do nothing and return NIL if the item is not currently visible.") (OR (FIXP ITEM) (SETQ ITEM (fetch TI# of ITEM))) (COND ((AND ONLYIFVISIBLE (NOT (TB.ITEM.VISIBLE? BROWSER ITEM))) (* ; "Item not visible, so no need to change display") NIL) ((OPENWP (fetch (TABLEBROWSER TBWINDOW) of BROWSER))) (T (LET ((OLDN (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER))) (COND ((OR (NULL OLDN) (< ITEM OLDN)) (* ; "Mark browser for display update after being unshrunk") (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with ITEM)))) NIL))) ) ) (* ; "Selection") (DEFINEQ (TB.BUTTONEVENTFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 15:23") (TOTOPW WINDOW) (LET (FN) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (TB.DO.UNLESS.BUSY WINDOW (FUNCTION TB.DO.ITEM.SELECTION))) ((LASTMOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((AND (LASTMOUSESTATE (ONLY MIDDLE)) (SETQ FN (fetch (TABLEBROWSER TBTITLEEVENTFN) of (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))))) (TB.DO.UNLESS.BUSY WINDOW FN))))) ) (TB.DO.UNLESS.BUSY (LAMBDA (WINDOW FN) (* ; "Edited 20-Jan-88 23:30 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (COND ((AND (fetch (TABLEBROWSER TBREADY) of BROWSER) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (CL:FUNCALL FN WINDOW BROWSER)))))) ) (TB.DO.ITEM.SELECTION (LAMBDA (WINDOW) (* ; "Edited 20-Jan-88 22:17 by bvm") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS) (SPECVARS SELECTIONSTATE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION FIRST# LAST# FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE NEWSELECTION OLDSELECTION SEL# OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS ITEM LASTX LASTY) (COND ((EQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (* ; "Nothing to select") (RETURN))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ LAST# (fetch TBLASTSELECTEDITEM of BROWSER)) (SETQ FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER)) (SETQ FIRSTVISIBLE# (TB.FIRST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (SETQ LASTVISIBLE# (TB.LAST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (* ; "Forget what we were doing") (SETQ OLDSELECTION))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Make selection permanent") (AND OLDSELECTION (SETQ OLDSEL# (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.REPLACING (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (replace TISELECTED of OLDSELECTION with T) (replace TBFIRSTSELECTEDITEM of BROWSER with (replace TBLASTSELECTEDITEM of BROWSER with OLDSEL#))) (TS.ADDING (TB.SELECTRANGE BROWSER OLDSEL# OLDSEL# T)) (TS.REMOVING (TB.DESELECTRANGE BROWSER OLDSEL# OLDSEL#)) (TS.EXTENDING.HI (TB.SELECTRANGE BROWSER (ADD1 LAST#) OLDSEL# CTRLDOWN)) (TS.EXTENDING.LO (TB.SELECTRANGE BROWSER OLDSEL# (SUB1 FIRST#) CTRLDOWN)) (TS.SHRINKING.HI (TB.DESELECTRANGE BROWSER (ADD1 OLDSEL#) LAST#)) (TS.SHRINKING.LO (TB.DESELECTRANGE BROWSER FIRST# (SUB1 OLDSEL#))) NIL) (RETURN)) ((AND NIL (* ; "In a special column")) (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (SETQ OLDSELECTION)))) ((OR (NEQ (SETQ NEWSELECTION (TB.ITEM.FROM.YCOORD BROWSER LASTY)) OLDSELECTION) (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) (* ; "Something changed") (COND ((AND (fetch TIUNSELECTABLE of NEWSELECTION) (NOT (LASTMOUSESTATE RIGHT))) (* ; "Can't select that item, so revert to idle") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION)))) ((AND (LASTMOUSESTATE (OR LEFT MIDDLE)) (SHIFTDOWNP (QUOTE CTRL))) (* ; "Deselect this item") (SELECTC SELECTIONSTATE (TS.REMOVING (* ; "we were deselecting, so reselect that guy") (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE REPLACE))) (TS.IDLE (* ; "nothing going on")) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((fetch TISELECTED of NEWSELECTION) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE ERASE)) TS.REMOVING) (T TS.IDLE)))) ((LASTMOUSESTATE LEFT) (* ; "Set (change) the selection to this single item") (COND ((EQ SELECTIONSTATE TS.REPLACING) (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (T (TB.DECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.REPLACING))) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE))) ((LASTMOUSESTATE MIDDLE) (* ; "Add this item to the selection") (SELECTC SELECTIONSTATE (TS.ADDING (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (TS.IDLE) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((NOT (fetch TISELECTED of NEWSELECTION)) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE)) TS.ADDING) (T TS.IDLE)))) ((LASTMOUSESTATE RIGHT) (* ; "Extend: either up or down, or shrink a selection. This is messy") (SETQ SEL# (fetch TI# of NEWSELECTION)) (SETQ OLDSEL# (AND OLDSELECTION (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.EXTENDING.HI (COND ((> SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE (ADD1 OLDSEL#) SEL# CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE (ADD1 (COND ((> SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#))) OLDSEL#)))) (TS.EXTENDING.LO (COND ((< SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE SEL# (SUB1 OLDSEL#) CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE OLDSEL# (SUB1 (COND ((< SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#))))))) (TS.SHRINKING.HI (COND ((>= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (ADD1 OLDSEL#) (COND ((< SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#)))) ((>= SEL# FIRST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE (ADD1 SEL#) OLDSEL#)) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (TS.SHRINKING.LO (COND ((<= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (COND ((> SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#)) (SUB1 OLDSEL#))) ((<= SEL# LAST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (COND ((<= FIRST# LAST#) (* ; "Something is already selected, so we can think about extending.") (COND ((NEQ SELECTIONSTATE TS.IDLE) (* ; "Cancel any selection we were thinking about") (TB.UNDOSELECTION))) (SETQ CTRLDOWN (SHIFTDOWNP (QUOTE CTRL))) (SETQ SELECTIONSTATE (COND ((> SEL# LAST#) (TB.CONSIDERRANGE (ADD1 LAST#) SEL# CTRLDOWN) TS.EXTENDING.HI) ((< SEL# FIRST#) (TB.CONSIDERRANGE SEL# (SUB1 FIRST#) CTRLDOWN) TS.EXTENDING.LO) ((> SEL# (LRSH (+ LAST# FIRST#) 1)) (* ; "we are closer to the high end, but inside. Shrink from the top, but only if we are pointing at a contigous selection") (if (TB.CONTIGUOUS.SELP BROWSER SEL# (SUB1 LAST#)) then (TB.DECONSIDERRANGE (ADD1 SEL#) LAST#) TS.SHRINKING.HI else TS.IDLE)) (T (* ; "We are closer to the low end, so shrink from bottom") (if (TB.CONTIGUOUS.SELP BROWSER (ADD1 FIRST#) SEL#) then (TB.DECONSIDERRANGE FIRST# (SUB1 SEL#)) TS.SHRINKING.LO else TS.IDLE))))))))) (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ OLDSELECTION NEWSELECTION)))))) ) (TB.CONTIGUOUS.SELP (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:16 by bvm") (* ;; "true if all the elements of ITEMS from FIRST# to LAST# are selected (or deleted or unselectable)") (for I from FIRST# to LAST# bind ITEM always (OR (fetch TISELECTED of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) (fetch TIDELETED of ITEM) (fetch TIUNSELECTABLE of ITEM)))) ) (TB.DECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as unselected.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) do (TB.SHOW.SELECTION BROWSER (TB.NTH.ITEM BROWSER I) (QUOTE ERASE)))) ) (TB.CONSIDERRANGE (LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as selected. Deleted items are not selected unless EVENIFDELETED is true") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (TB.SHOW.SELECTION BROWSER ITEM (QUOTE REPLACE)))))) ) (TB.DESELECTRANGE (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as unselected. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified--use TB.UNSELECT.ALL.ITEMS to do both") (LET ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER))) (if (< FIRST# FIRSTSEL) then (SETQ FIRST# FIRSTSEL)) (if (> LAST# LASTSEL) then (SETQ LAST# LASTSEL)) (if (<= FIRST# LAST#) then (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (COND ((EQ FIRST# FIRSTSEL) (replace TBFIRSTSELECTEDITEM of BROWSER with (COND ((TB.FIND.SELECTED.ITEM BROWSER (ADD1 LAST#) LASTSEL)) (T (replace TBLASTSELECTEDITEM of BROWSER with 0) (* ; "Null selection indicated by first GT last.") (ADD1 (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)))))) ((EQ LAST# LASTSEL) (replace TBLASTSELECTEDITEM of BROWSER with (OR (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL (SUB1 FIRST#)) 1))))))) ) (TB.RECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (TB.SHOW.SELECTION BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((fetch TISELECTED of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))))) ) (TB.SELECTRANGE (LAMBDA (BROWSER FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:10 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified") (PROG ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER)) ITEM) (for I from FIRST# to LAST# do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (replace TISELECTED of ITEM with T)))) (COND ((OR (> FIRSTSEL LASTSEL) (< FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER))) (replace TBFIRSTSELECTEDITEM of BROWSER with FIRST#))) (COND ((OR (> FIRSTSEL LASTSEL) (> LAST# (fetch TBLASTSELECTEDITEM of BROWSER))) (replace TBLASTSELECTEDITEM of BROWSER with LAST#))))) ) (TB.UNDOSELECTION (LAMBDA NIL (* bvm%: " 6-Sep-85 15:04") (* ;;; "Restore browser to state before any selections were attempted") (DECLARE (USEDFREE FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE)) (TB.RECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.IDLE)) ) (TB.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR FIRST# 1) to (OR LAST# (fetch TB#ITEMS of BROWSER)) suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) (TB.REV.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR LAST# (fetch TB#ITEMS of BROWSER)) to (OR FIRST# 1) by -1 suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) ) (DEFINEQ (TB.COPYBUTTONEVENTFN (LAMBDA (WINDOW) (* ; "Edited 22-Jan-88 12:08 by bvm") (* ;;; "copy select an item from the window.") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION COPYFN CURRENTITEM NEWITEM LASTX LASTY) (COND ((OR (NULL (SETQ COPYFN (fetch (TABLEBROWSER TBCOPYFN) of BROWSER))) (NULL (fetch (TABLEBROWSER TBITEMS) of BROWSER))) (RETURN (TOTOPW WINDOW)))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) LP (TOTOPW WINDOW) (COND ((AND (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW))) (TB.ITEM.FROM.YCOORD BROWSER LASTY))) (fetch TIUNCOPYSELECTABLE of NEWITEM)) (SETQ NEWITEM NIL))) (COND ((NEQ CURRENTITEM NEWITEM) (COND (CURRENTITEM (* ; "turn off old selection.") (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))) (COND ((SETQ CURRENTITEM NEWITEM) (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))))) (* ; "wait for a button up or move out of region") LP2 (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (CURRENTITEM (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM) (CL:FUNCALL COPYFN BROWSER CURRENTITEM))) (RETURN)) ((MOUSESTATE UP) (* ; "button up, no action") (GO LP2)) (T (GO LP))))) ) (TB.SHOW.COPY.SELECTION (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:38 by bvm") (* ;;; "underline this item in browser") (BLTSHADE GRAYSHADE (fetch (TABLEBROWSER TBWINDOW) of BROWSER) TB.LEFT.MARGIN (TB.BOTTOM.OF.ITEM BROWSER ITEM) NIL 2 (QUOTE INVERT))) ) ) (* ; "Misc state change") (DEFINEQ (TB.BROWSER.BUSY (LAMBDA (BROWSER) (* bvm%: " 8-Sep-85 16:42") (RESETFORM (CURSOR TB.CROSSCURSOR) (BLOCK 1000)))) (TB.CLOSE/SHRINK (LAMBDA (WINDOW FLG) (* ; "Edited 20-Jan-88 23:36 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HOW?) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (COND ((AND (SETQ HOW? (fetch (TABLEBROWSER TBCLOSEFN) of BROWSER)) (SETQ HOW? (CL:FUNCALL HOW? BROWSER WINDOW FLG))) (COND ((NEQ HOW? (QUOTE DON'T)) (TB.PROCESS (BQUOTE ((\, HOW?) (QUOTE (\, BROWSER)) (QUOTE (\, WINDOW)) (QUOTE (\, FLG)))) (QUOTE TB.UPDATE)))) (QUOTE DON'T)) (T (TB.FINISH.CLOSE BROWSER WINDOW FLG T) NIL))) (T (printout PROMPTWINDOW T "Browser is busy, can't close") (QUOTE DON'T)))))) ) (TB.CLOSEFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:25") (TB.CLOSE/SHRINK WINDOW (QUOTE CLOSE)))) (TB.FINISH.CLOSE (LAMBDA (BROWSER WINDOW CLOSEFLG DONTCLOSE) (* bvm%: " 9-Sep-85 00:42") (* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge. DONTCLOSE is true if neither occurred, in which case we are being called directly from the CLOSEFN and should not close/shrink the window ourselves") (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (SELECTQ CLOSEFLG (CLOSE (SETQ WINDOW (TB.FLUSH.WINDOW BROWSER WINDOW)) (OR DONTCLOSE (CLOSEW WINDOW))) (SHRINK (WINDOWADDPROP WINDOW (QUOTE EXPANDFN) (FUNCTION TB.EXPANDFN)) (WINDOWDELPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN)) (OR DONTCLOSE (SHRINKW WINDOW))) NIL))) ) (TB.FLUSH.WINDOW (LAMBDA (BROWSER WINDOW) (* ; "Edited 20-Jan-88 22:42 by bvm") (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION TB.CLOSEFN)) (ERSETQ (LET ((FN (fetch (TABLEBROWSER TBAFTERCLOSEFN) of BROWSER))) (AND FN (CL:FUNCALL FN BROWSER WINDOW)))) (replace (TABLEBROWSER TBITEMS) of BROWSER with (replace (TABLEBROWSER TBWINDOW) of BROWSER with (replace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL))) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) NIL) (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))))) ) (TB.SET.FONT (LAMBDA (BROWSER FONT) (* ; "Edited 10-Feb-88 11:07 by bvm:") (* ;;; "Sets/changes font of TABLEBROWSER to be FONT. Clears window. Caller is responsible for repainting window") (LET ((FONTGIVEN FONT) (WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) WIDTH HEIGHT ASCENT TOTALHEIGHT ORIGIN FN EXTENT HW) (CLEARW WINDOW) (SETQ FONT (FONTCREATE (OR FONT (fetch (TABLEBROWSER TBFONT) of BROWSER) (DSPFONT NIL WINDOW)))) (DSPFONT FONT WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (LINELENGTH T WINDOW) (replace (TABLEBROWSER TBFONT) of BROWSER with FONT) (replace (TABLEBROWSER TBFONTHEIGHT) of BROWSER with (SETQ HEIGHT (FONTPROP FONT (QUOTE HEIGHT)))) (if (NOT (fetch (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER)) then (* ; "Compute item heights. Don't do this if user gave an explicit height.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with (SETQ HEIGHT (TIMES HEIGHT (fetch (TABLEBROWSER TB#LINESPERITEM) of BROWSER)))) (replace (TABLEBROWSER TBFONTASCENT) of BROWSER with (SETQ ASCENT (FONTPROP FONT (QUOTE ASCENT)))) (replace (TABLEBROWSER TBBASELINE) of BROWSER with (- HEIGHT ASCENT)) else (SETQ HEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))) (replace (TABLEBROWSER TBORIGIN) of BROWSER with (SETQ ORIGIN (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL WINDOW)))) (SETQ TOTALHEIGHT (TIMES (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) HEIGHT)) (WINDOWPROP WINDOW (QUOTE EXTENT) (replace (TABLEBROWSER TBEXTENT) of BROWSER with (create REGION LEFT _ 0 BOTTOM _ (- ORIGIN TOTALHEIGHT) WIDTH _ 0 HEIGHT _ TOTALHEIGHT))) (* ; "Let extent width be zero until we print something") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0) (if (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Fix extent of header window, too. Be sure to account for different size of borders, if any") (LET ((HWIDTH (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HW (QUOTE BORDER)))))) (if (SETQ EXTENT (WINDOWPROP HW (QUOTE EXTENT))) then (replace (REGION WIDTH) of EXTENT with HWIDTH) else (WINDOWPROP HW (QUOTE EXTENT) (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ HWIDTH HEIGHT _ -1))))) (COND ((AND FONTGIVEN (SETQ FN (fetch (TABLEBROWSER TBFONTCHANGEFN) of BROWSER))) (* ; "Notify application program of font change") (CL:FUNCALL FN BROWSER WINDOW))))) ) (TB.SHRINKFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:14") (TB.CLOSE/SHRINK WINDOW (QUOTE SHRINK)))) (TB.EXPANDFN (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 16:53 by bvm") (* ;;; "If browser changed while it was shrunk, update display accordingly") (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (LET ((FIRSTCHANGEDITEM# (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER)) REGION FN) (* ; "Restore SHRINKFN prop if necessary") (WINDOWADDPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN) T) (COND (FIRSTCHANGEDITEM# (* ; "Browser has changed since shrinking") (TB.DISPLAY.LINES BROWSER (IMAX FIRSTCHANGEDITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW)))) (TB.LAST.VISIBLE.ITEM# BROWSER REGION)) (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with NIL))))))) ) (TB.FIND.PREVIOUS.TAIL (LAMBDA (BROWSER ITEM#) (* ; "Edited 20-Jan-88 23:23 by bvm") (* ;; "Return the tail of BROWSER's items whose CADR is ITEM#. Assumes ITEM# at least 2 and not greater than number of items") (LET (TAIL TAILN) (if (OR (NULL (SETQ TAIL (fetch (TABLEBROWSER TBTAILHINT) of BROWSER))) (< ITEM# (SETQ TAILN (ADD1 (fetch (TABLEITEM TI#) of (CAR TAIL)))))) then (* ; "Can't use the hint") (SETQ TAIL (fetch (TABLEBROWSER TBITEMS) of BROWSER)) (SETQ TAILN 2)) (* ;; "TAILN is the number of (CADR TAIL). Want to get TAIL pointing to one before the requested number") (while (< TAILN ITEM#) do (SETQ TAIL (CDR TAIL)) (add TAILN 1)) (if (OR (NULL TAIL) (NEQ TAILN ITEM#)) then (HELP "Failed to find item tail" ITEM#)) TAIL)) ) (TB.RENUMBER.TAIL (LAMBDA (BROWSER TAIL FIRST#) (* ; "Edited 20-Jan-88 23:22 by bvm") (* ;; "Renumbers all of BROWSER's items from TAIL onward, giving (CAR TAIL) the number FIRST#. Also updates tail hint.") (for ITEM in TAIL as I from FIRST# do (replace TI# of ITEM with I)) (replace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL)) ) ) (* ; "Misc") (DEFINEQ (TB.PROCESS (LAMBDA (FORM NAME ALLOWLOGOUT RESTARTABLE) (* bvm%: "25-Mar-84 17:16") (* ;;; "Creates a process running FORM which by default is not restartable and will not permit LOGOUT while it is running") (ADD.PROCESS FORM (QUOTE NAME) NAME (QUOTE RESTARTABLE) (OR RESTARTABLE (QUOTE NO)) (QUOTE BEFOREEXIT) (COND (ALLOWLOGOUT NIL) (T (QUOTE DON'T))))) ) ) (RPAQ? TB.DELETEDLINEHEIGHT 1) (RPAQQ TB.SELECTION.BITMAP #*(8 9)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@) (RPAQ TB.CROSSCURSOR (CURSORCREATE (QUOTE #*(16 16)L@@CN@@GG@@NCHALALCH@NG@@GN@@CL@@CL@@GN@@NG@ALCHCHALG@@NN@@GL@@C ) (QUOTE NIL) 8 8)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TBDECLS) (RPAQQ TOCSTATES ((TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7))) (DECLARE%: EVAL@COMPILE (RPAQQ TS.IDLE 0) (RPAQQ TS.REPLACING 1) (RPAQQ TS.ADDING 2) (RPAQQ TS.REMOVING 3) (RPAQQ TS.EXTENDING.HI 4) (RPAQQ TS.EXTENDING.LO 5) (RPAQQ TS.SHRINKING.HI 6) (RPAQQ TS.SHRINKING.LO 7) (CONSTANTS (TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .COPYKEYDOWNP. MACRO [NIL (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TB.USERDATA) ) (/DECLAREDATATYPE 'TABLEBROWSER '(FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER)) '48) (/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG POINTER WORD) '((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 2 POINTER) (TABLEITEM 1 (BITS . 15))) '4) (ADDTOVAR SYSTEMRECLST (DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (TBITEMS POINTER) (TB#ITEMS WORD) (TB#DELETED WORD) (TB#LINESPERITEM WORD) (TBFIRSTSELECTEDITEM WORD) (TBLASTSELECTEDITEM WORD) (TBITEMHEIGHT WORD) (TBMAXXPOS WORD) (TBFONTHEIGHT WORD) (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (TBLOCK POINTER) (TBUSERDATA POINTER) (TBFONT POINTER) (TBEXTENT POINTER) (TBUPDATEFROMHERE POINTER) (TBCOLUMNS POINTER) (TBPRINTFN POINTER) (TBCOPYFN POINTER) (TBFONTCHANGEFN POINTER) (TBCLOSEFN POINTER) (TBAFTERCLOSEFN POINTER) (TBTITLEEVENTFN POINTER) (TBLINETHICKNESS POINTER) (TBORIGIN POINTER) (TBTAILHINT POINTER) (TBHEADINGWINDOW POINTER) (NIL POINTER))) (DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (TIDATA POINTER) (TI# WORD))) ) (PUTPROPS TABLEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 1994 1995 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3215 7566 (TB.MAKE.BROWSER 3225 . 6341) (TB.REPLACE.ITEMS 6343 . 7564)) (7567 16586 ( TB.DELETE.ITEM 7577 . 8011) (TB.UNDELETE.ITEM 8013 . 8592) (TB.INSERT.ITEM 8594 . 10601) ( TB.REMOVE.ITEM 10603 . 12135) (TB.NORMALIZE.ITEM 12137 . 12850) (TB.REDISPLAY.ITEMS 12852 . 15171) ( TB.SELECT.ITEM 15173 . 15478) (TB.UNSELECT.ITEM 15480 . 15835) (TB.UNSELECT.ALL.ITEMS 15837 . 16584)) (16587 21113 (TB.NUMBER.OF.ITEMS 16597 . 17079) (TB.NTH.ITEM 17081 . 18155) (TB.COLLECT.ITEMS 18157 . 18528) (TB.MAP.ITEMS 18530 . 18894) (TB.MAP.DELETED.ITEMS 18896 . 19343) (TB.MAP.SELECTED.ITEMS 19345 . 19952) (TB.FIND.ITEM 19954 . 20827) (TB.ITEM.SELECTED? 20829 . 20970) (TB.ITEM.DELETED? 20972 . 21111)) (21114 21955 (TB.CLEAR.LINE 21124 . 21536) (TB.USERDATA 21538 . 21804) (TB.WINDOW 21806 . 21953)) (21980 32238 (TB.REPAINTFN 21990 . 22401) (TB.RESHAPEFN 22403 . 23241) (TB.SCROLLFN 23243 . 23794) (TB.DISPLAY.LINES 23796 . 25053) (TB.PRINT.LINE 25055 . 25575) (TB.FIRST.VISIBLE.ITEM# 25577 . 26014) (TB.LAST.VISIBLE.ITEM# 26016 . 26489) (TB.ITEM.VISIBLE? 26491 . 27011) (TB.ITEM.FROM.YCOORD 27013 . 27323) (TB.BOTTOM.OF.ITEM 27325 . 27738) (TB.SHOW.DELETION 27740 . 28362) (TB.SHOW.SELECTION 28364 . 29133) (TB.UPDATE.DISPLAY 29135 . 31420) (TB.ITEM.UPDATABLE? 31422 . 32236)) (32265 43678 ( TB.BUTTONEVENTFN 32275 . 32734) (TB.DO.UNLESS.BUSY 32736 . 33043) (TB.DO.ITEM.SELECTION 33045 . 39119) (TB.CONTIGUOUS.SELP 39121 . 39488) (TB.DECONSIDERRANGE 39490 . 39858) (TB.CONSIDERRANGE 39860 . 40431 ) (TB.DESELECTRANGE 40433 . 41495) (TB.RECONSIDERRANGE 41497 . 41995) (TB.SELECTRANGE 41997 . 42937) ( TB.UNDOSELECTION 42939 . 43216) (TB.FIND.SELECTED.ITEM 43218 . 43441) (TB.REV.FIND.SELECTED.ITEM 43443 . 43676)) (43679 45178 (TB.COPYBUTTONEVENTFN 43689 . 44909) (TB.SHOW.COPY.SELECTION 44911 . 45176)) ( 45213 51520 (TB.BROWSER.BUSY 45223 . 45340) (TB.CLOSE/SHRINK 45342 . 45974) (TB.CLOSEFN 45976 . 46077) (TB.FINISH.CLOSE 46079 . 46732) (TB.FLUSH.WINDOW 46734 . 47261) (TB.SET.FONT 47263 . 49561) ( TB.SHRINKFN 49563 . 49666) (TB.EXPANDFN 49668 . 50433) (TB.FIND.PREVIOUS.TAIL 50435 . 51177) ( TB.RENUMBER.TAIL 51179 . 51518)) (51542 51915 (TB.PROCESS 51552 . 51913))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Feb-2021 23:02:39"  {DSK}kaplan>Local>medley3.5>git-medley>library>TABLEBROWSER.;4 57889 changes to%: (VARS TABLEBROWSERCOMS) previous date%: " 1-Dec-2018 17:25:13" {DSK}kaplan>Local>medley3.5>git-medley>library>TABLEBROWSER.;3) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993, 1994, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT TABLEBROWSERCOMS) (RPAQQ TABLEBROWSERCOMS ((COMS (* ; "Entries") (FNS TB.MAKE.BROWSER TB.REPLACE.ITEMS) (FNS TB.DELETE.ITEM TB.UNDELETE.ITEM TB.INSERT.ITEM TB.REMOVE.ITEM TB.NORMALIZE.ITEM TB.REDISPLAY.ITEMS TB.SELECT.ITEM TB.UNSELECT.ITEM TB.UNSELECT.ALL.ITEMS) (FNS TB.NUMBER.OF.ITEMS TB.NTH.ITEM TB.COLLECT.ITEMS TB.MAP.ITEMS TB.MAP.DELETED.ITEMS TB.MAP.SELECTED.ITEMS TB.FIND.ITEM TB.ITEM.SELECTED? TB.ITEM.DELETED?) (FNS TB.CLEAR.LINE TB.USERDATA TB.WINDOW)) (COMS (* ; "Display") (FNS TB.REPAINTFN TB.RESHAPEFN TB.SCROLLFN TB.DISPLAY.LINES TB.PRINT.LINE TB.FIRST.VISIBLE.ITEM# TB.LAST.VISIBLE.ITEM# TB.ITEM.VISIBLE? TB.ITEM.FROM.YCOORD TB.BOTTOM.OF.ITEM TB.SHOW.DELETION TB.SHOW.SELECTION TB.UPDATE.DISPLAY TB.ITEM.UPDATABLE?)) (COMS (* ; "Selection") (FNS TB.BUTTONEVENTFN TB.DO.UNLESS.BUSY TB.DO.ITEM.SELECTION TB.CONTIGUOUS.SELP TB.DECONSIDERRANGE TB.CONSIDERRANGE TB.DESELECTRANGE TB.RECONSIDERRANGE TB.SELECTRANGE TB.UNDOSELECTION TB.FIND.SELECTED.ITEM TB.REV.FIND.SELECTED.ITEM) (FNS TB.COPYBUTTONEVENTFN TB.SHOW.COPY.SELECTION)) (COMS (* ; "Misc state change") (FNS TB.BROWSER.BUSY TB.CLOSE/SHRINK TB.CLOSEFN TB.FINISH.CLOSE TB.FLUSH.WINDOW TB.SET.FONT TB.SHRINKFN TB.EXPANDFN TB.FIND.PREVIOUS.TAIL TB.RENUMBER.TAIL)) (COMS (* ; "Misc") (FNS TB.PROCESS) (INITVARS (TB.DELETEDLINEHEIGHT 1)) (VARS TB.SELECTION.BITMAP) (CURSORS TB.CROSSCURSOR) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (CONSTANTS * TOCSTATES) (MACROS .COPYKEYDOWNP.) (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) (LOCALVARS . T))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TB.USERDATA))) (INITRECORDS TABLEBROWSER TABLEITEM) (SYSRECORDS TABLEBROWSER TABLEITEM))) (* ; "Entries") (DEFINEQ (TB.MAKE.BROWSER (LAMBDA (ITEMS WINDOWSPEC PROPS) (* ; "Edited 28-Jan-88 04:37 by bvm") (* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") (PROG ((LINESPERITEM 1) FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA WINDOW USERPROPS BROWSER ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (DECLARE (SPECVARS FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS)) (* ; "For SET below") (for TAIL on PROPS by (CDDR TAIL) do (SELECTQ (CAR TAIL) ((FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (SET (CAR TAIL) (CADR TAIL))) (push USERPROPS (LIST (CAR TAIL) (CADR TAIL))))) (SETQ WINDOW (DECODE.WINDOW.ARG WINDOWSPEC NIL NIL TITLE)) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) (SETQ BROWSER (create TABLEBROWSER TBWINDOW _ WINDOW TBFONT _ FONT TBLOCK _ (CREATE.MONITORLOCK (OR (WINDOWPROP WINDOW (QUOTE TITLE)) "Table Browser")) TB#LINESPERITEM _ (OR LINESPERITEM 1) TBBASELINE _ (OR BASELINE 0) TBCOLUMNS _ COLUMNS TBPRINTFN _ PRINTFN TBCOPYFN _ COPYFN TBCLOSEFN _ CLOSEFN TBAFTERCLOSEFN _ AFTERCLOSEFN TBUSERDATA _ USERDATA TBHEADINGWINDOW _ HEADINGWINDOW TBLINETHICKNESS _ (OR LINETHICKNESS TB.DELETEDLINEHEIGHT)))) (if ITEMHEIGHT then (* ; "User explicitly controlling height variables.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with ITEMHEIGHT) (replace (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER with T)) (DSPLEFTMARGIN TB.LEFT.MARGIN WINDOW) (TB.REPLACE.ITEMS BROWSER ITEMS) (WINDOWPROP WINDOW (QUOTE SCROLLFN) (FUNCTION TB.SCROLLFN)) (WINDOWPROP WINDOW (QUOTE REPAINTFN) (FUNCTION TB.REPAINTFN)) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE COPYBUTTONEVENTFN) (FUNCTION TB.COPYBUTTONEVENTFN)) (for PROP in (QUOTE (CLOSEFN SHRINKFN RESHAPEFN)) do (* ;; "This used to be (progn (windowaddprop window 'closefn (function tb.closefn)) (windowaddprop window 'shrinkfn (function tb.shrinkfn)) (windowaddprop window 'reshapefn (function tb.reshapefn))). However, we want to be careful to put our stuff on before any attached window stuff, so that we can reject a CLOSE, for example, before CLOSEATTACHEDWINDOWS has already closed them. Could always put on front, but it's probably better to put our functions after any the user might have explicitly put there already.") (LET ((OLDP (WINDOWPROP WINDOW PROP)) (FN (PACK* "TB." PROP))) (if (NULL OLDP) then (SETQ OLDP (LIST FN)) else (for TAIL on (OR (LISTP OLDP) (SETQ OLDP (LIST OLDP))) do (if (EQ (CAR TAIL) FN) then (* ; "Window already has our fn!") (RETURN) elseif (STRPOS "ATTACHED" (CAR TAIL)) then (* ; "Insert before this attached window hacker") (RETURN (ATTACH FN TAIL))) finally (* ; "Put at end") (NCONC1 OLDP FN))) (WINDOWPROP WINDOW PROP OLDP))) (replace (TABLEBROWSER TBREADY) of BROWSER with T) (RETURN BROWSER))) ) (TB.REPLACE.ITEMS (LAMBDA (BROWSER NEWITEMS) (* ; "Edited 27-Jan-88 16:27 by bvm") (* ;; "Completely replace the current items with the specified items") (LET ((N 0) FIRSTSEL) (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (for ITEM in NEWITEMS do (* ; "Number the items") (freplace TI# of (\DTEST ITEM (QUOTE TABLEITEM)) with (add N 1))) (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL) (freplace (TABLEBROWSER TBITEMS) of BROWSER with NEWITEMS) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with N) (freplace (TABLEBROWSER TB#DELETED) of BROWSER with (for ITEM in NEWITEMS count (ffetch TIDELETED of ITEM))) (COND ((SETQ FIRSTSEL (TB.FIND.SELECTED.ITEM BROWSER 1 N)) (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with FIRSTSEL) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL N))) (T (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with (ADD1 N)) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with 0))) (TB.SET.FONT BROWSER) (LET ((REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER)))) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) ) (DEFINEQ (TB.DELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((NOT (ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM)))) (freplace (TABLEITEM TIDELETED) of ITEM with T) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 1) (if (TB.ITEM.UPDATABLE? BROWSER ITEM T) then (TB.SHOW.DELETION BROWSER ITEM (ffetch (TABLEBROWSER TBWINDOW) of BROWSER) (QUOTE REPLACE)))))) ) (TB.UNDELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM))) (freplace (TABLEITEM TIDELETED) of ITEM with NIL) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) -1) (COND ((TB.ITEM.UPDATABLE? BROWSER ITEM T) (LET ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE ERASE)) (* ; "reprint the line sans deletion mark") (TB.PRINT.LINE BROWSER ITEM WINDOW (ffetch (TABLEBROWSER TBPRINTFN) of BROWSER)))))))) ) (TB.INSERT.ITEM (LAMBDA (BROWSER NEWITEM BEFOREITEM) (* ; "Edited 27-Jan-88 16:08 by bvm") (* ;;; "Inserts NEWITEM in TABLEBROWSER before item BEFOREITEM or at the end if BEFOREITEM is NIL") (LET ((LASTITEM# (ffetch (TABLEBROWSER TB#ITEMS) of (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))))) BEFORE# TAIL N) (SETQ NEWITEM (\DTEST NEWITEM (QUOTE TABLEITEM))) (if BEFOREITEM then (SETQ BEFORE# (OR (FIXP BEFOREITEM) (ffetch TI# of (\DTEST BEFOREITEM (QUOTE TABLEITEM))))) (COND ((OR (> BEFORE# LASTITEM#) (< BEFORE# 1)) (* ; "Check for bad values") (\ILLEGAL.ARG BEFOREITEM))) else (SETQ BEFORE# (ADD1 LASTITEM#))) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (if (EQ BEFORE# 1) then (* ; "Goes at the beginning (or at the end of a null list)") (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CONS NEWITEM (ffetch (TABLEBROWSER TBITEMS) of BROWSER)))) else (* ; "Somewhere else--find the tail") (SETQ TAIL (if (NULL BEFOREITEM) then (* ; "Insert at end") (FLAST (OR (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER) (ffetch (TABLEBROWSER TBITEMS) of BROWSER))) else (TB.FIND.PREVIOUS.TAIL BROWSER BEFORE#))) (RPLACD TAIL (SETQ TAIL (CONS NEWITEM (CDR TAIL))))) (* ;; "Now (CAR TAIL) is the new item") (TB.RENUMBER.TAIL BROWSER TAIL BEFORE#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (ADD1 LASTITEM#)) (COND ((ffetch TIDELETED of NEWITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) 1))) (* ;; "Update first & last selected item if they fall after the insertion, or if the new item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((ffetch TISELECTED of NEWITEM) BEFORE#) (T (ADD1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBLASTSELECTEDITEM of BROWSER with (ADD1 N))) ((ffetch TISELECTED of NEWITEM) (freplace TBLASTSELECTEDITEM of BROWSER with BEFORE#))) (TB.UPDATE.DISPLAY BROWSER BEFORE# (QUOTE INSERT)))) ) (TB.REMOVE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:09 by bvm") (* ;;; "Removes ITEM from TABLEBROWSER") (LET ((LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (ITEM# (ffetch TI# of (\DTEST ITEM (QUOTE TABLEITEM)))) N TAIL) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (COND ((EQ ITEM# 1) (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CDR (ffetch (TABLEBROWSER TBITEMS) of BROWSER))))) (T (RPLACD (SETQ TAIL (TB.FIND.PREVIOUS.TAIL BROWSER ITEM#)) (SETQ TAIL (CDDR TAIL))))) (TB.RENUMBER.TAIL BROWSER TAIL ITEM#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (SUB1 LASTITEM#)) (COND ((ffetch TIDELETED of ITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) -1))) (* ;; "Update first & last selected item if they fall after the deletion or if the old item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the first selected, so look for next one after it") (OR (TB.FIND.SELECTED.ITEM BROWSER ITEM#) LASTITEM#)) (T (* ; "Item numbers are decremented") (SUB1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBLASTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the last selected, so look for next one before it") (OR (TB.REV.FIND.SELECTED.ITEM BROWSER NIL (SUB1 ITEM#)) 0)) (T (SUB1 N)))))) (TB.UPDATE.DISPLAY BROWSER ITEM# (QUOTE REMOVE)))) ) (TB.NORMALIZE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:22 by bvm") (* ;; "Scroll, if necessary, so that ITEM is visible in browser.") (LET* ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM)) (CLIP (DSPCLIPPINGREGION NIL WINDOW))) (COND ((OR (> (fetch (REGION BOTTOM) of CLIP) BOT) (< (fetch (REGION PTOP) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (* ; "Scroll so that item's midline is at midline of window") (SCROLLBYREPAINTFN WINDOW 0 (- (+ (fetch (REGION BOTTOM) of CLIP) (IQUOTIENT (fetch (REGION HEIGHT) of CLIP) 2)) (+ BOT (IQUOTIENT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) 2)))))))) ) (TB.REDISPLAY.ITEMS [LAMBDA (BROWSER FIRSTITEM LASTITEM) (* ; "Edited 1-Dec-2018 17:25 by rmk:") (* ; "Edited 2-Feb-88 11:53 by bvm:") (* ;; "Force redisplay of all items from FIRSTITEM to LASTITEM, e.g., because their content or format changed. We'll only redisplay the visible ones, of course. Also, if browser isn't open, we'll save the change until browser is expanded") (LET [(REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER 'TABLEBROWSER] (if (AND (NULL FIRSTITEM) (NULL LASTITEM)) then (* ; "We're being told to redisplay the whole browser, so recompute the extent while we're at it (it might have gotten smaller).") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0)) (SETQ FIRSTITEM (IMAX [COND ((NULL FIRSTITEM) 1) ((FIXP FIRSTITEM)) (T (ffetch TI# of (\DTEST FIRSTITEM 'TABLEITEM] (TB.FIRST.VISIBLE.ITEM# BROWSER REGION))) (SETQ LASTITEM (IMIN [COND ((NULL LASTITEM) (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) ((FIXP LASTITEM)) (T (ffetch TI# of (\DTEST LASTITEM 'TABLEITEM] (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (if (AND (>= LASTITEM FIRSTITEM) (TB.ITEM.UPDATABLE? BROWSER FIRSTITEM)) then (* ;; "RMK: For whatever reason, on an FB recompute, this gets called after the items have first been displayed but not in proper alignment. This redisplays them to get the alignment, but the window is garbled if the old stuff isn't cleared first. So, added the CLEARW") (CLEARW (ffetch (TABLEBROWSER TBWINDOW) of BROWSER)) (TB.DISPLAY.LINES BROWSER FIRSTITEM LASTITEM]) (TB.SELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (LET ((N (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))) (TB.SELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N T) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE REPLACE))))) ) (TB.UNSELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:09 by bvm") (if (ffetch (TABLEITEM TISELECTED) of (\DTEST ITEM (QUOTE TABLEITEM))) then (LET ((N (ffetch (TABLEITEM TI#) of ITEM))) (TB.DESELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE ERASE)))))) ) (TB.UNSELECT.ALL.ITEMS (LAMBDA (BROWSER) (* ; "Edited 29-Jan-88 12:14 by bvm") (* ;; "User entry for unselecting all items in the browser. ") (LET ((START (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (END (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER))) (if (<= START END) then (for I from START to END bind (UPDATABLE _ (TB.ITEM.UPDATABLE? BROWSER START)) ITEM when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) do (freplace TISELECTED of ITEM with NIL) (if UPDATABLE then (TB.SHOW.SELECTION BROWSER I (QUOTE ERASE)))) (freplace TBFIRSTSELECTEDITEM of BROWSER with (ADD1 (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (freplace TBLASTSELECTEDITEM of BROWSER with 0)))) ) ) (DEFINEQ (TB.NUMBER.OF.ITEMS (LAMBDA (BROWSER TYPE) (* ; "Edited 27-Jan-88 16:16 by bvm") (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (SELECTQ TYPE (NIL (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (DELETED (ffetch (TABLEBROWSER TB#DELETED) of BROWSER)) (SELECTED (for I from (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER) to (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER) count (ffetch (TABLEITEM TISELECTED) of (TB.NTH.ITEM BROWSER I)))) (\ILLEGAL.ARG TYPE))) ) (TB.NTH.ITEM (LAMBDA (BROWSER N) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;; "Return the Nth item of BROWSER, or NIL if N is out of range.") (* ;; "Browser items are currently stored as a simple list. To make most accesses reasonable, we save a hint to a recent tail of the list to speed up the search.") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET (TAIL TAILN) (if (AND (> N 0) (OR (AND (SETQ TAIL (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER)) (>= N (SETQ TAILN (ffetch (TABLEITEM TI#) of (CAR TAIL))))) (PROG1 (SETQ TAIL (ffetch (TABLEBROWSER TBITEMS) of BROWSER)) (* ; "Item is not in hint tail, have to search whole list") (SETQ TAILN 1)))) then (while (< TAILN N) do (if (NULL (SETQ TAIL (CDR TAIL))) then (* ; "Greater than last item. I could have done a comparison against #items, but it is rare to ask for this (and we never do internally).") (RETURN NIL)) (add TAILN 1) finally (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL) (* ; "Store away the new hint. This makes ascending iterations constant time, rather than n^2.") (RETURN (CAR TAIL)))))) ) (TB.COLLECT.ITEMS (LAMBDA (BROWSER PREDFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) collect ITEM when (OR (NULL PREDFN) (CL:FUNCALL PREDFN BROWSER ITEM)))) ) (TB.MAP.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEMS (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (COND (ITEMS (for ITEM in ITEMS do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (CL:FUNCALL NULLFN BROWSER))))) ) (TB.MAP.DELETED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each deleted item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (COND ((NEQ (ffetch TB#DELETED of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 0) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of BROWSER) when (ffetch TIDELETED of ITEM) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing deleted") (CL:FUNCALL NULLFN BROWSER)))) ) (TB.MAP.SELECTED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:19 by bvm") (* ;;; "Apply MAPFN to each selected item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEM# (SUB1 (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (LASTITEM# (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER)) ITEM) (COND ((< ITEM# LASTITEM#) (until (> (add ITEM# 1) LASTITEM#) when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#))) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing selected") (CL:FUNCALL NULLFN BROWSER))))) ) (TB.FIND.ITEM (LAMBDA (BROWSER PREDFN FIRST# LAST# BACKWARDSFLG) (* ; "Edited 27-Jan-88 16:20 by bvm") (* ;;; "Returns the first item in the designated range satisfying (PREDFN browser item); range defaults to whole browser") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET ((LO (COND (FIRST# (IMAX FIRST# 1)) (T 1))) (HI (COND (LAST# (IMIN LAST# (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (T (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)))) I END INCREMENT ITEM) (COND ((<= LO HI) (COND (BACKWARDSFLG (SETQ I (ADD1 HI)) (SETQ END LO) (SETQ INCREMENT -1)) (T (SETQ I (SUB1 LO)) (SETQ END HI) (SETQ INCREMENT 1))) (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (when (CL:FUNCALL PREDFN BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER (add I INCREMENT)))) do (RETURN ITEM) repeatuntil (EQ I END)))))) ) (TB.ITEM.SELECTED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TISELECTED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) (TB.ITEM.DELETED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TIDELETED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) ) (DEFINEQ (TB.CLEAR.LINE (LAMBDA (BROWSER ITEM LEFT WIDTH) (* ; "Edited 22-Jan-88 16:06 by bvm") (* ;;; "Clears the contents of ITEM's line starting at xpos LEFT for width WIDTH. Defaults to whole line") (BLTSHADE WHITESHADE (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (OR LEFT 0) (TB.BOTTOM.OF.ITEM BROWSER ITEM) WIDTH (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (QUOTE REPLACE))) ) (TB.USERDATA (CL:LAMBDA (BROWSER &OPTIONAL (NEWDATA NIL NEWP)) (* ; "Edited 27-Jan-88 16:25 by bvm") (PROG1 (ffetch (TABLEBROWSER TBUSERDATA) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (COND (NEWP (freplace (TABLEBROWSER TBUSERDATA) of BROWSER with NEWDATA))))) ) (TB.WINDOW (LAMBDA (BROWSER) (* ; "Edited 27-Jan-88 16:25 by bvm") (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) ) ) (* ; "Display") (DEFINEQ (TB.REPAINTFN (LAMBDA (WINDOW REGION) (* bvm%: "10-Sep-85 13:00") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (AND (NEQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (T (TB.BROWSER.BUSY BROWSER))))))) ) (TB.RESHAPEFN (LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 22-Jan-88 10:21 by bvm") (RESETLST (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (REGION (DSPCLIPPINGREGION NIL WINDOW)) ITEM#) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (* ; "Browser is busy, have to wait until it is ready. But don't tie up mouse!") (ALLOW.BUTTON.EVENTS) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) NIL T)) ((NOT (fetch (TABLEBROWSER TBREADY) of BROWSER)) (* ; "Browser not functional") (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION)))) (SETQ ITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER REGION)) (TB.SET.FONT BROWSER) (WYOFFSET (TIMES (SUB1 ITEM#) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) WINDOW) (TB.DISPLAY.LINES BROWSER ITEM# (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) (TB.SCROLLFN (LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* ; "Edited 22-Jan-88 17:32 by bvm") (* ;; "only scroll if can get the monitor lock") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HW) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG) (if (AND (EQ DY 0) (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER))) then (* ; "Horizontally scroll the header window together with it.") (SCROLLW HW DX DY CONTINUOUSFLG))) (T (TB.BROWSER.BUSY BROWSER)))))) ) (TB.DISPLAY.LINES (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 25-Jan-88 18:34 by bvm") (for ITEM# from (IMAX FIRST# 1) to (IMIN LAST# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) bind (WINDOW _ (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (MAXXPOS _ (fetch (TABLEBROWSER TBMAXXPOS) of BROWSER)) (PRINTFN _ (fetch (TABLEBROWSER TBPRINTFN) of BROWSER)) EXTENTCHANGED ITEM HERE EXTENT HWINDOW do (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#)) (TB.PRINT.LINE BROWSER ITEM WINDOW PRINTFN) (* ; "keep track of maximum width printed to, so window's EXTENT is always right") (COND ((< MAXXPOS (SETQ HERE (DSPXPOSITION NIL WINDOW))) (SETQ MAXXPOS HERE) (SETQ EXTENTCHANGED T))) finally (COND (EXTENTCHANGED (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with MAXXPOS) (replace (REGION WIDTH) of (SETQ EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) with MAXXPOS) (WINDOWPROP WINDOW (QUOTE EXTENT) EXTENT) (if (SETQ HWINDOW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Update heading window extent, too. Width has to account for the difference, if any, in borders.") (replace (REGION WIDTH) of (SETQ EXTENT (WINDOWPROP HWINDOW (QUOTE EXTENT))) with (+ MAXXPOS (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HWINDOW (QUOTE BORDER))))))))))) ) (TB.PRINT.LINE (LAMBDA (BROWSER ITEM WINDOW PRINTFN) (* ; "Edited 22-Jan-88 17:16 by bvm") (MOVETO TB.LEFT.MARGIN (+ (TB.BOTTOM.OF.ITEM BROWSER ITEM) (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) WINDOW) (* ; "Move to item's baseline") (POSITION WINDOW 0) (CL:FUNCALL PRINTFN BROWSER ITEM WINDOW) (TB.SHOW.SELECTION BROWSER ITEM (COND ((fetch (TABLEITEM TISELECTED) of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))) (COND ((fetch (TABLEITEM TIDELETED) of ITEM) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE REPLACE))))) ) (TB.FIRST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 16:59 by bvm") (* ;; "Computes number of the first item in TABLEBROWSER that is visible in REGION") (IMAX 1 (ADD1 (IQUOTIENT (- (ffetch (TABLEBROWSER TBORIGIN) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (fetch (REGION PTOP) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))))) ) (TB.LAST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 17:00 by bvm") (* ;; "Computes number of the last item in TABLEBROWSER that is visible in REGION") (IMIN (ffetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (CL:CEILING (- (ffetch (TABLEBROWSER TBORIGIN) of BROWSER) (fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) ) (TB.ITEM.VISIBLE? (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:12 by bvm") (* ;;; "True if any part of ITEM is visible in window of BROWSER") (LET ((CLIP (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM))) (* ;; "Check bottom of line is below top, and top of line is above the bottom") (AND (< BOT (fetch (REGION PTOP) of CLIP)) (< (fetch (REGION BOTTOM) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))))) ) (TB.ITEM.FROM.YCOORD (LAMBDA (BROWSER YPOS) (* ; "Edited 22-Jan-88 16:41 by bvm") (LET ((N (CL:CEILING (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) YPOS) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (TB.NTH.ITEM BROWSER (COND ((<= N 0) 1) (T (IMIN N (fetch (TABLEBROWSER TB#ITEMS) of BROWSER))))))) ) (TB.BOTTOM.OF.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:11 by bvm") (* ;; "Returns the y position of the bottom of specified item (number or tableitem). Add the font descent to get the baseline of the first line.") (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) (TIMES (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (OR (FIXP ITEM) (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))))) ) (TB.SHOW.DELETION (LAMBDA (BROWSER ITEM WINDOW OPERATION) (* ; "Edited 27-Jan-88 17:00 by bvm") (* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that ITEM is deleted") (LET ((THICKNESS (fetch (TABLEBROWSER TBLINETHICKNESS) of BROWSER)) (BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER))) (BLTSHADE BLACKSHADE WINDOW TB.LEFT.MARGIN (PROGN (* ;; "Center the deletion line between the baseline and the top of the item") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE THICKNESS) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL THICKNESS OPERATION))) ) (TB.SHOW.SELECTION (LAMBDA (BROWSER ITEM OPERATION) (* ; "Edited 27-Jan-88 15:42 by bvm") (* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that ITEM is selected") (LET ((BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) (BM TB.SELECTION.BITMAP)) (BITBLT BM 0 0 (fetch (TABLEBROWSER TBWINDOW) of BROWSER) 0 (PROGN (* ;; "Center the selection bitmap between the baseline and the top of the item, rounding down slightly on the grounds that the top pixel of the line tends to be blank, so the center of gravity is lower than it might be.") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE (fetch BITMAPHEIGHT of BM)) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL NIL (QUOTE INPUT) OPERATION))) ) (TB.UPDATE.DISPLAY (LAMBDA (BROWSER FROMITEM# TYPE) (* ; "Edited 11-Feb-88 11:34 by bvm") (* ;;; "Updates the display window appropriately after a TYPE operation (REMOVE or INSERT) on TABLEBROWSER that affects items starting at FROMITEM#") (PROG ((WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) (LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (ITEMHEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) (ITEMBOTTOM (TB.BOTTOM.OF.ITEM BROWSER FROMITEM#)) DELTA HEIGHT LAST# CLIP WBOTTOM EXTENTBOTTOM) (* ; "YPOS is the bottom of the line corresponding to FROMITEM#") (add (fetch (REGION HEIGHT) of EXTENT) (SETQ DELTA (SELECTQ TYPE (REMOVE (- ITEMHEIGHT)) (INSERT ITEMHEIGHT) (SHOULDNT)))) (SETQ CLIP (DSPCLIPPINGREGION NIL WINDOW)) (COND ((>= ITEMBOTTOM (fetch (REGION PTOP) of CLIP)) (* ; "Changed item above top of window, so no visible change -- just cheat the origin appropriately") (add (fetch (TABLEBROWSER TBORIGIN) of BROWSER) DELTA)) (T (* ; "Changed item visible or below bottom of window, so bottom of extent changes") (replace (REGION BOTTOM) of EXTENT with (SETQ EXTENTBOTTOM (- (fetch (REGION BOTTOM) of EXTENT) DELTA))) (COND ((<= (+ ITEMBOTTOM ITEMHEIGHT) (SETQ WBOTTOM (fetch (REGION BOTTOM) of CLIP))) (* ; "Below bottom of window, so we're done")) ((TB.ITEM.UPDATABLE? BROWSER FROMITEM#) (* ; "If window is visible, update it now") (SELECTQ TYPE (INSERT (* ; "Push everything from line FROMITEM# down one line, then redisplay item FROMITEM#") (BITBLT WINDOW 0 (+ WBOTTOM ITEMHEIGHT) WINDOW 0 WBOTTOM NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER FROMITEM# FROMITEM#)) (REMOVE (* ; "Pull everything below line FROMITEM# up one line, then redisplay last visible item(s)") (BITBLT WINDOW 0 WBOTTOM WINDOW 0 (+ WBOTTOM ITEMHEIGHT) NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER (SETQ LAST# (+ FROMITEM# (IQUOTIENT (- ITEMBOTTOM WBOTTOM) ITEMHEIGHT))) (ADD1 LAST#)) (* ; "May have to display two lines if the bottom line of window was a half line") (COND ((> EXTENTBOTTOM WBOTTOM) (* ; "Clear everything below the extent") (BLTSHADE WHITESHADE WINDOW 0 WBOTTOM NIL (- EXTENTBOTTOM WBOTTOM) (QUOTE REPLACE))))) (SHOULDNT)))))))) ) (TB.ITEM.UPDATABLE? (LAMBDA (BROWSER ITEM ONLYIFVISIBLE) (* ; "Edited 29-Jan-88 12:08 by bvm") (* ;;; "True if window of BROWSER is open. If false, we update the TBUPDATEFROMHERE field, denoting that we should repaint window when it is opened. If ONLYIFVISIBLE is true, we do nothing and return NIL if the item is not currently visible.") (OR (FIXP ITEM) (SETQ ITEM (fetch TI# of ITEM))) (COND ((AND ONLYIFVISIBLE (NOT (TB.ITEM.VISIBLE? BROWSER ITEM))) (* ; "Item not visible, so no need to change display") NIL) ((OPENWP (fetch (TABLEBROWSER TBWINDOW) of BROWSER))) (T (LET ((OLDN (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER))) (COND ((OR (NULL OLDN) (< ITEM OLDN)) (* ; "Mark browser for display update after being unshrunk") (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with ITEM)))) NIL))) ) ) (* ; "Selection") (DEFINEQ (TB.BUTTONEVENTFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 15:23") (TOTOPW WINDOW) (LET (FN) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (TB.DO.UNLESS.BUSY WINDOW (FUNCTION TB.DO.ITEM.SELECTION))) ((LASTMOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((AND (LASTMOUSESTATE (ONLY MIDDLE)) (SETQ FN (fetch (TABLEBROWSER TBTITLEEVENTFN) of (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))))) (TB.DO.UNLESS.BUSY WINDOW FN))))) ) (TB.DO.UNLESS.BUSY (LAMBDA (WINDOW FN) (* ; "Edited 20-Jan-88 23:30 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (COND ((AND (fetch (TABLEBROWSER TBREADY) of BROWSER) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (CL:FUNCALL FN WINDOW BROWSER)))))) ) (TB.DO.ITEM.SELECTION (LAMBDA (WINDOW) (* ; "Edited 20-Jan-88 22:17 by bvm") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS) (SPECVARS SELECTIONSTATE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION FIRST# LAST# FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE NEWSELECTION OLDSELECTION SEL# OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS ITEM LASTX LASTY) (COND ((EQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (* ; "Nothing to select") (RETURN))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ LAST# (fetch TBLASTSELECTEDITEM of BROWSER)) (SETQ FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER)) (SETQ FIRSTVISIBLE# (TB.FIRST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (SETQ LASTVISIBLE# (TB.LAST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (* ; "Forget what we were doing") (SETQ OLDSELECTION))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Make selection permanent") (AND OLDSELECTION (SETQ OLDSEL# (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.REPLACING (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (replace TISELECTED of OLDSELECTION with T) (replace TBFIRSTSELECTEDITEM of BROWSER with (replace TBLASTSELECTEDITEM of BROWSER with OLDSEL#))) (TS.ADDING (TB.SELECTRANGE BROWSER OLDSEL# OLDSEL# T)) (TS.REMOVING (TB.DESELECTRANGE BROWSER OLDSEL# OLDSEL#)) (TS.EXTENDING.HI (TB.SELECTRANGE BROWSER (ADD1 LAST#) OLDSEL# CTRLDOWN)) (TS.EXTENDING.LO (TB.SELECTRANGE BROWSER OLDSEL# (SUB1 FIRST#) CTRLDOWN)) (TS.SHRINKING.HI (TB.DESELECTRANGE BROWSER (ADD1 OLDSEL#) LAST#)) (TS.SHRINKING.LO (TB.DESELECTRANGE BROWSER FIRST# (SUB1 OLDSEL#))) NIL) (RETURN)) ((AND NIL (* ; "In a special column")) (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (SETQ OLDSELECTION)))) ((OR (NEQ (SETQ NEWSELECTION (TB.ITEM.FROM.YCOORD BROWSER LASTY)) OLDSELECTION) (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) (* ; "Something changed") (COND ((AND (fetch TIUNSELECTABLE of NEWSELECTION) (NOT (LASTMOUSESTATE RIGHT))) (* ; "Can't select that item, so revert to idle") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION)))) ((AND (LASTMOUSESTATE (OR LEFT MIDDLE)) (SHIFTDOWNP (QUOTE CTRL))) (* ; "Deselect this item") (SELECTC SELECTIONSTATE (TS.REMOVING (* ; "we were deselecting, so reselect that guy") (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE REPLACE))) (TS.IDLE (* ; "nothing going on")) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((fetch TISELECTED of NEWSELECTION) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE ERASE)) TS.REMOVING) (T TS.IDLE)))) ((LASTMOUSESTATE LEFT) (* ; "Set (change) the selection to this single item") (COND ((EQ SELECTIONSTATE TS.REPLACING) (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (T (TB.DECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.REPLACING))) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE))) ((LASTMOUSESTATE MIDDLE) (* ; "Add this item to the selection") (SELECTC SELECTIONSTATE (TS.ADDING (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (TS.IDLE) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((NOT (fetch TISELECTED of NEWSELECTION)) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE)) TS.ADDING) (T TS.IDLE)))) ((LASTMOUSESTATE RIGHT) (* ; "Extend: either up or down, or shrink a selection. This is messy") (SETQ SEL# (fetch TI# of NEWSELECTION)) (SETQ OLDSEL# (AND OLDSELECTION (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.EXTENDING.HI (COND ((> SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE (ADD1 OLDSEL#) SEL# CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE (ADD1 (COND ((> SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#))) OLDSEL#)))) (TS.EXTENDING.LO (COND ((< SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE SEL# (SUB1 OLDSEL#) CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE OLDSEL# (SUB1 (COND ((< SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#))))))) (TS.SHRINKING.HI (COND ((>= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (ADD1 OLDSEL#) (COND ((< SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#)))) ((>= SEL# FIRST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE (ADD1 SEL#) OLDSEL#)) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (TS.SHRINKING.LO (COND ((<= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (COND ((> SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#)) (SUB1 OLDSEL#))) ((<= SEL# LAST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (COND ((<= FIRST# LAST#) (* ; "Something is already selected, so we can think about extending.") (COND ((NEQ SELECTIONSTATE TS.IDLE) (* ; "Cancel any selection we were thinking about") (TB.UNDOSELECTION))) (SETQ CTRLDOWN (SHIFTDOWNP (QUOTE CTRL))) (SETQ SELECTIONSTATE (COND ((> SEL# LAST#) (TB.CONSIDERRANGE (ADD1 LAST#) SEL# CTRLDOWN) TS.EXTENDING.HI) ((< SEL# FIRST#) (TB.CONSIDERRANGE SEL# (SUB1 FIRST#) CTRLDOWN) TS.EXTENDING.LO) ((> SEL# (LRSH (+ LAST# FIRST#) 1)) (* ; "we are closer to the high end, but inside. Shrink from the top, but only if we are pointing at a contigous selection") (if (TB.CONTIGUOUS.SELP BROWSER SEL# (SUB1 LAST#)) then (TB.DECONSIDERRANGE (ADD1 SEL#) LAST#) TS.SHRINKING.HI else TS.IDLE)) (T (* ; "We are closer to the low end, so shrink from bottom") (if (TB.CONTIGUOUS.SELP BROWSER (ADD1 FIRST#) SEL#) then (TB.DECONSIDERRANGE FIRST# (SUB1 SEL#)) TS.SHRINKING.LO else TS.IDLE))))))))) (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ OLDSELECTION NEWSELECTION)))))) ) (TB.CONTIGUOUS.SELP (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:16 by bvm") (* ;; "true if all the elements of ITEMS from FIRST# to LAST# are selected (or deleted or unselectable)") (for I from FIRST# to LAST# bind ITEM always (OR (fetch TISELECTED of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) (fetch TIDELETED of ITEM) (fetch TIUNSELECTABLE of ITEM)))) ) (TB.DECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as unselected.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) do (TB.SHOW.SELECTION BROWSER (TB.NTH.ITEM BROWSER I) (QUOTE ERASE)))) ) (TB.CONSIDERRANGE (LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as selected. Deleted items are not selected unless EVENIFDELETED is true") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (TB.SHOW.SELECTION BROWSER ITEM (QUOTE REPLACE)))))) ) (TB.DESELECTRANGE (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as unselected. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified--use TB.UNSELECT.ALL.ITEMS to do both") (LET ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER))) (if (< FIRST# FIRSTSEL) then (SETQ FIRST# FIRSTSEL)) (if (> LAST# LASTSEL) then (SETQ LAST# LASTSEL)) (if (<= FIRST# LAST#) then (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (COND ((EQ FIRST# FIRSTSEL) (replace TBFIRSTSELECTEDITEM of BROWSER with (COND ((TB.FIND.SELECTED.ITEM BROWSER (ADD1 LAST#) LASTSEL)) (T (replace TBLASTSELECTEDITEM of BROWSER with 0) (* ; "Null selection indicated by first GT last.") (ADD1 (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)))))) ((EQ LAST# LASTSEL) (replace TBLASTSELECTEDITEM of BROWSER with (OR (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL (SUB1 FIRST#)) 1))))))) ) (TB.RECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (TB.SHOW.SELECTION BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((fetch TISELECTED of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))))) ) (TB.SELECTRANGE (LAMBDA (BROWSER FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:10 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified") (PROG ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER)) ITEM) (for I from FIRST# to LAST# do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (replace TISELECTED of ITEM with T)))) (COND ((OR (> FIRSTSEL LASTSEL) (< FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER))) (replace TBFIRSTSELECTEDITEM of BROWSER with FIRST#))) (COND ((OR (> FIRSTSEL LASTSEL) (> LAST# (fetch TBLASTSELECTEDITEM of BROWSER))) (replace TBLASTSELECTEDITEM of BROWSER with LAST#))))) ) (TB.UNDOSELECTION (LAMBDA NIL (* bvm%: " 6-Sep-85 15:04") (* ;;; "Restore browser to state before any selections were attempted") (DECLARE (USEDFREE FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE)) (TB.RECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.IDLE)) ) (TB.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR FIRST# 1) to (OR LAST# (fetch TB#ITEMS of BROWSER)) suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) (TB.REV.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR LAST# (fetch TB#ITEMS of BROWSER)) to (OR FIRST# 1) by -1 suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) ) (DEFINEQ (TB.COPYBUTTONEVENTFN (LAMBDA (WINDOW) (* ; "Edited 22-Jan-88 12:08 by bvm") (* ;;; "copy select an item from the window.") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION COPYFN CURRENTITEM NEWITEM LASTX LASTY) (COND ((OR (NULL (SETQ COPYFN (fetch (TABLEBROWSER TBCOPYFN) of BROWSER))) (NULL (fetch (TABLEBROWSER TBITEMS) of BROWSER))) (RETURN (TOTOPW WINDOW)))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) LP (TOTOPW WINDOW) (COND ((AND (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW))) (TB.ITEM.FROM.YCOORD BROWSER LASTY))) (fetch TIUNCOPYSELECTABLE of NEWITEM)) (SETQ NEWITEM NIL))) (COND ((NEQ CURRENTITEM NEWITEM) (COND (CURRENTITEM (* ; "turn off old selection.") (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))) (COND ((SETQ CURRENTITEM NEWITEM) (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))))) (* ; "wait for a button up or move out of region") LP2 (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (CURRENTITEM (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM) (CL:FUNCALL COPYFN BROWSER CURRENTITEM))) (RETURN)) ((MOUSESTATE UP) (* ; "button up, no action") (GO LP2)) (T (GO LP))))) ) (TB.SHOW.COPY.SELECTION (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:38 by bvm") (* ;;; "underline this item in browser") (BLTSHADE GRAYSHADE (fetch (TABLEBROWSER TBWINDOW) of BROWSER) TB.LEFT.MARGIN (TB.BOTTOM.OF.ITEM BROWSER ITEM) NIL 2 (QUOTE INVERT))) ) ) (* ; "Misc state change") (DEFINEQ (TB.BROWSER.BUSY (LAMBDA (BROWSER) (* bvm%: " 8-Sep-85 16:42") (RESETFORM (CURSOR TB.CROSSCURSOR) (BLOCK 1000)))) (TB.CLOSE/SHRINK (LAMBDA (WINDOW FLG) (* ; "Edited 20-Jan-88 23:36 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HOW?) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (COND ((AND (SETQ HOW? (fetch (TABLEBROWSER TBCLOSEFN) of BROWSER)) (SETQ HOW? (CL:FUNCALL HOW? BROWSER WINDOW FLG))) (COND ((NEQ HOW? (QUOTE DON'T)) (TB.PROCESS (BQUOTE ((\, HOW?) (QUOTE (\, BROWSER)) (QUOTE (\, WINDOW)) (QUOTE (\, FLG)))) (QUOTE TB.UPDATE)))) (QUOTE DON'T)) (T (TB.FINISH.CLOSE BROWSER WINDOW FLG T) NIL))) (T (printout PROMPTWINDOW T "Browser is busy, can't close") (QUOTE DON'T)))))) ) (TB.CLOSEFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:25") (TB.CLOSE/SHRINK WINDOW (QUOTE CLOSE)))) (TB.FINISH.CLOSE (LAMBDA (BROWSER WINDOW CLOSEFLG DONTCLOSE) (* bvm%: " 9-Sep-85 00:42") (* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge. DONTCLOSE is true if neither occurred, in which case we are being called directly from the CLOSEFN and should not close/shrink the window ourselves") (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (SELECTQ CLOSEFLG (CLOSE (SETQ WINDOW (TB.FLUSH.WINDOW BROWSER WINDOW)) (OR DONTCLOSE (CLOSEW WINDOW))) (SHRINK (WINDOWADDPROP WINDOW (QUOTE EXPANDFN) (FUNCTION TB.EXPANDFN)) (WINDOWDELPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN)) (OR DONTCLOSE (SHRINKW WINDOW))) NIL))) ) (TB.FLUSH.WINDOW (LAMBDA (BROWSER WINDOW) (* ; "Edited 20-Jan-88 22:42 by bvm") (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION TB.CLOSEFN)) (ERSETQ (LET ((FN (fetch (TABLEBROWSER TBAFTERCLOSEFN) of BROWSER))) (AND FN (CL:FUNCALL FN BROWSER WINDOW)))) (replace (TABLEBROWSER TBITEMS) of BROWSER with (replace (TABLEBROWSER TBWINDOW) of BROWSER with (replace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL))) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) NIL) (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))))) ) (TB.SET.FONT (LAMBDA (BROWSER FONT) (* ; "Edited 10-Feb-88 11:07 by bvm:") (* ;;; "Sets/changes font of TABLEBROWSER to be FONT. Clears window. Caller is responsible for repainting window") (LET ((FONTGIVEN FONT) (WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) WIDTH HEIGHT ASCENT TOTALHEIGHT ORIGIN FN EXTENT HW) (CLEARW WINDOW) (SETQ FONT (FONTCREATE (OR FONT (fetch (TABLEBROWSER TBFONT) of BROWSER) (DSPFONT NIL WINDOW)))) (DSPFONT FONT WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (LINELENGTH T WINDOW) (replace (TABLEBROWSER TBFONT) of BROWSER with FONT) (replace (TABLEBROWSER TBFONTHEIGHT) of BROWSER with (SETQ HEIGHT (FONTPROP FONT (QUOTE HEIGHT)))) (if (NOT (fetch (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER)) then (* ; "Compute item heights. Don't do this if user gave an explicit height.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with (SETQ HEIGHT (TIMES HEIGHT (fetch (TABLEBROWSER TB#LINESPERITEM) of BROWSER)))) (replace (TABLEBROWSER TBFONTASCENT) of BROWSER with (SETQ ASCENT (FONTPROP FONT (QUOTE ASCENT)))) (replace (TABLEBROWSER TBBASELINE) of BROWSER with (- HEIGHT ASCENT)) else (SETQ HEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))) (replace (TABLEBROWSER TBORIGIN) of BROWSER with (SETQ ORIGIN (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL WINDOW)))) (SETQ TOTALHEIGHT (TIMES (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) HEIGHT)) (WINDOWPROP WINDOW (QUOTE EXTENT) (replace (TABLEBROWSER TBEXTENT) of BROWSER with (create REGION LEFT _ 0 BOTTOM _ (- ORIGIN TOTALHEIGHT) WIDTH _ 0 HEIGHT _ TOTALHEIGHT))) (* ; "Let extent width be zero until we print something") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0) (if (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Fix extent of header window, too. Be sure to account for different size of borders, if any") (LET ((HWIDTH (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HW (QUOTE BORDER)))))) (if (SETQ EXTENT (WINDOWPROP HW (QUOTE EXTENT))) then (replace (REGION WIDTH) of EXTENT with HWIDTH) else (WINDOWPROP HW (QUOTE EXTENT) (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ HWIDTH HEIGHT _ -1))))) (COND ((AND FONTGIVEN (SETQ FN (fetch (TABLEBROWSER TBFONTCHANGEFN) of BROWSER))) (* ; "Notify application program of font change") (CL:FUNCALL FN BROWSER WINDOW))))) ) (TB.SHRINKFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:14") (TB.CLOSE/SHRINK WINDOW (QUOTE SHRINK)))) (TB.EXPANDFN (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 16:53 by bvm") (* ;;; "If browser changed while it was shrunk, update display accordingly") (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (LET ((FIRSTCHANGEDITEM# (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER)) REGION FN) (* ; "Restore SHRINKFN prop if necessary") (WINDOWADDPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN) T) (COND (FIRSTCHANGEDITEM# (* ; "Browser has changed since shrinking") (TB.DISPLAY.LINES BROWSER (IMAX FIRSTCHANGEDITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW)))) (TB.LAST.VISIBLE.ITEM# BROWSER REGION)) (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with NIL))))))) ) (TB.FIND.PREVIOUS.TAIL (LAMBDA (BROWSER ITEM#) (* ; "Edited 20-Jan-88 23:23 by bvm") (* ;; "Return the tail of BROWSER's items whose CADR is ITEM#. Assumes ITEM# at least 2 and not greater than number of items") (LET (TAIL TAILN) (if (OR (NULL (SETQ TAIL (fetch (TABLEBROWSER TBTAILHINT) of BROWSER))) (< ITEM# (SETQ TAILN (ADD1 (fetch (TABLEITEM TI#) of (CAR TAIL)))))) then (* ; "Can't use the hint") (SETQ TAIL (fetch (TABLEBROWSER TBITEMS) of BROWSER)) (SETQ TAILN 2)) (* ;; "TAILN is the number of (CADR TAIL). Want to get TAIL pointing to one before the requested number") (while (< TAILN ITEM#) do (SETQ TAIL (CDR TAIL)) (add TAILN 1)) (if (OR (NULL TAIL) (NEQ TAILN ITEM#)) then (HELP "Failed to find item tail" ITEM#)) TAIL)) ) (TB.RENUMBER.TAIL (LAMBDA (BROWSER TAIL FIRST#) (* ; "Edited 20-Jan-88 23:22 by bvm") (* ;; "Renumbers all of BROWSER's items from TAIL onward, giving (CAR TAIL) the number FIRST#. Also updates tail hint.") (for ITEM in TAIL as I from FIRST# do (replace TI# of ITEM with I)) (replace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL)) ) ) (* ; "Misc") (DEFINEQ (TB.PROCESS (LAMBDA (FORM NAME ALLOWLOGOUT RESTARTABLE) (* bvm%: "25-Mar-84 17:16") (* ;;; "Creates a process running FORM which by default is not restartable and will not permit LOGOUT while it is running") (ADD.PROCESS FORM (QUOTE NAME) NAME (QUOTE RESTARTABLE) (OR RESTARTABLE (QUOTE NO)) (QUOTE BEFOREEXIT) (COND (ALLOWLOGOUT NIL) (T (QUOTE DON'T))))) ) ) (RPAQ? TB.DELETEDLINEHEIGHT 1) (RPAQQ TB.SELECTION.BITMAP #*(8 9)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@) (RPAQ TB.CROSSCURSOR (CURSORCREATE (QUOTE #*(16 16)L@@CN@@GG@@NCHALALCH@NG@@GN@@CL@@CL@@GN@@NG@ALCHCHALG@@NN@@GL@@C ) (QUOTE NIL) 8 8)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (RPAQQ TOCSTATES ((TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7))) (DECLARE%: EVAL@COMPILE (RPAQQ TS.IDLE 0) (RPAQQ TS.REPLACING 1) (RPAQQ TS.ADDING 2) (RPAQQ TS.REMOVING 3) (RPAQQ TS.EXTENDING.HI 4) (RPAQQ TS.EXTENDING.LO 5) (RPAQQ TS.SHRINKING.HI 6) (RPAQQ TS.SHRINKING.LO 7) (CONSTANTS (TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .COPYKEYDOWNP. MACRO [NIL (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TB.USERDATA) ) (/DECLAREDATATYPE 'TABLEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 (FLAGBITS . 32)) (TABLEBROWSER 0 (FLAGBITS . 48)) (TABLEBROWSER 0 (FLAGBITS . 64)) (TABLEBROWSER 0 (FLAGBITS . 80)) (TABLEBROWSER 0 (FLAGBITS . 96)) (TABLEBROWSER 0 (FLAGBITS . 112)) (TABLEBROWSER 2 POINTER) (TABLEBROWSER 1 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 (BITS . 15)) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER) (TABLEBROWSER 48 POINTER)) '50) (/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD) '((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 0 (FLAGBITS . 80)) (TABLEITEM 0 (FLAGBITS . 96)) (TABLEITEM 0 (FLAGBITS . 112)) (TABLEITEM 2 POINTER) (TABLEITEM 1 (BITS . 15)) (TABLEITEM 4 (BITS . 15))) '6) (ADDTOVAR SYSTEMRECLST (DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (NIL 6 FLAG) (TBITEMS POINTER) (TB#ITEMS WORD) (TB#DELETED WORD) (TB#LINESPERITEM WORD) (TBFIRSTSELECTEDITEM WORD) (TBLASTSELECTEDITEM WORD) (TBITEMHEIGHT WORD) (TBMAXXPOS WORD) (TBFONTHEIGHT WORD) (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (TBLOCK POINTER) (TBUSERDATA POINTER) (TBFONT POINTER) (TBEXTENT POINTER) (TBUPDATEFROMHERE POINTER) (TBCOLUMNS POINTER) (TBPRINTFN POINTER) (TBCOPYFN POINTER) (TBFONTCHANGEFN POINTER) (TBCLOSEFN POINTER) (TBAFTERCLOSEFN POINTER) (TBTITLEEVENTFN POINTER) (TBLINETHICKNESS POINTER) (TBORIGIN POINTER) (TBTAILHINT POINTER) (TBHEADINGWINDOW POINTER) (NIL POINTER))) (DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (NIL 3 FLAG) (TIDATA POINTER) (TI# WORD) (NIL WORD))) ) (PUTPROPS TABLEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 1994 1995 1999 2018 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3214 7565 (TB.MAKE.BROWSER 3224 . 6340) (TB.REPLACE.ITEMS 6342 . 7563)) (7566 16585 ( TB.DELETE.ITEM 7576 . 8010) (TB.UNDELETE.ITEM 8012 . 8591) (TB.INSERT.ITEM 8593 . 10600) ( TB.REMOVE.ITEM 10602 . 12134) (TB.NORMALIZE.ITEM 12136 . 12849) (TB.REDISPLAY.ITEMS 12851 . 15170) ( TB.SELECT.ITEM 15172 . 15477) (TB.UNSELECT.ITEM 15479 . 15834) (TB.UNSELECT.ALL.ITEMS 15836 . 16583)) (16586 21112 (TB.NUMBER.OF.ITEMS 16596 . 17078) (TB.NTH.ITEM 17080 . 18154) (TB.COLLECT.ITEMS 18156 . 18527) (TB.MAP.ITEMS 18529 . 18893) (TB.MAP.DELETED.ITEMS 18895 . 19342) (TB.MAP.SELECTED.ITEMS 19344 . 19951) (TB.FIND.ITEM 19953 . 20826) (TB.ITEM.SELECTED? 20828 . 20969) (TB.ITEM.DELETED? 20971 . 21110)) (21113 21954 (TB.CLEAR.LINE 21123 . 21535) (TB.USERDATA 21537 . 21803) (TB.WINDOW 21805 . 21952)) (21979 32237 (TB.REPAINTFN 21989 . 22400) (TB.RESHAPEFN 22402 . 23240) (TB.SCROLLFN 23242 . 23793) (TB.DISPLAY.LINES 23795 . 25052) (TB.PRINT.LINE 25054 . 25574) (TB.FIRST.VISIBLE.ITEM# 25576 . 26013) (TB.LAST.VISIBLE.ITEM# 26015 . 26488) (TB.ITEM.VISIBLE? 26490 . 27010) (TB.ITEM.FROM.YCOORD 27012 . 27322) (TB.BOTTOM.OF.ITEM 27324 . 27737) (TB.SHOW.DELETION 27739 . 28361) (TB.SHOW.SELECTION 28363 . 29132) (TB.UPDATE.DISPLAY 29134 . 31419) (TB.ITEM.UPDATABLE? 31421 . 32235)) (32264 43677 ( TB.BUTTONEVENTFN 32274 . 32733) (TB.DO.UNLESS.BUSY 32735 . 33042) (TB.DO.ITEM.SELECTION 33044 . 39118) (TB.CONTIGUOUS.SELP 39120 . 39487) (TB.DECONSIDERRANGE 39489 . 39857) (TB.CONSIDERRANGE 39859 . 40430 ) (TB.DESELECTRANGE 40432 . 41494) (TB.RECONSIDERRANGE 41496 . 41994) (TB.SELECTRANGE 41996 . 42936) ( TB.UNDOSELECTION 42938 . 43215) (TB.FIND.SELECTED.ITEM 43217 . 43440) (TB.REV.FIND.SELECTED.ITEM 43442 . 43675)) (43678 45177 (TB.COPYBUTTONEVENTFN 43688 . 44908) (TB.SHOW.COPY.SELECTION 44910 . 45175)) ( 45212 51519 (TB.BROWSER.BUSY 45222 . 45339) (TB.CLOSE/SHRINK 45341 . 45973) (TB.CLOSEFN 45975 . 46076) (TB.FINISH.CLOSE 46078 . 46731) (TB.FLUSH.WINDOW 46733 . 47260) (TB.SET.FONT 47262 . 49560) ( TB.SHRINKFN 49562 . 49665) (TB.EXPANDFN 49667 . 50432) (TB.FIND.PREVIOUS.TAIL 50434 . 51176) ( TB.RENUMBER.TAIL 51178 . 51517)) (51541 51914 (TB.PROCESS 51551 . 51912))))) STOP \ No newline at end of file diff --git a/library/TABLEBROWSER.LCOM b/library/TABLEBROWSER.LCOM index 5e045bbc2feb56c18e33d14256bc86b69e917ea0..b3d5cc61d45ab4fbb22b0609cb956b64bbb23b61 100644 GIT binary patch delta 1714 zcmah~Pi)&%7_U>>ZY_ptEwpKe^ewD35lZIw>^N~KWohH2UJ^UlPP3G%qFda=RkoJ? zLFx*ckhpN70TsUoA3u6u=zWfz#%g`M!h(Gh0(ln?IeUE-jIH&R%?&`(DSado2|#6W!>T}_ zwT@^{l)$k-hz+KdoII_|NmEWiz^e@>cqstvcFM@UKT%w_*2p&FU-*Be5RJv-5?rq> z-mF^du(2|hfZ%LWH-K%OX@9!AK~J#uj5Z5rprv3?4;phwS#`nI*-QdEir0|#|V=dD0e%U zpF1uuA2#mQzI*WL87JR=+j-V|o-EMveYLCe{@y?Hs!K;B{lUi_L5w+=PtVD^R-ktC zkde*2Ry1V8q%Hyyd9sl4k3|t=<#I|ZsT9RaEeVdDBxE!5LkdX}}~j+CKyx zJHAfxa&~Lnbm!P#aYi(Iou_L`e@77UBHg5@h|&t=QMTNJAf>6}CdudCVYtSA?#FKG z?*~TdMVDjl*Rz)^O#}Ov55MNgp>e*;T_OYK!EGv`*z8ZW6adF#Ft4aaQJ0TY0gmzB ziYRz1eAL5(Vo^vLh3TA9C@5-1moti{QdeS-)>JcTOv|bX@mQam&d5q;#w2>tpn6(g zJit;Mw+kW-Yp(Zgz$e5 znCvc%5Y0MIKC&jLzJfJM9$Q!X+qEIig_M>qP{7DDEH#%fwPEtbQj*+RdXB-L)cjQ^eJ> delta 1529 zcmZWpPi)&{6tCT`&Dy#OVqK>W!PoFF0VTCRJBbq}wMpxwZc^K`opvo9q%?n=%uBMg zou~kn3wOqo5C^ow;EL1{juRaSp$TmVhPDF|$4MM}L5NfNoTM!=IXLh8z2E!2_r3S* z+ka3Gf2TfOhTo|3w`{>+&FwtlRG0U=u6XPrw=dlkl?=_2? z_3Mp_T`ZvD`;F$-t8ru|L%K9C8(KE88j?+E$v~AF@+}n$c5xT+p)gAA*fuhDx9U6F z2uFhI<~9-LL=*~ze5kOoO~e@AiDQy@Fv%B<3!*Q;_)~ILn$x9(Db2&L)TN$UbsmMI zJd4q$wNWb%%-Ej11KUFm?N;?;2Yll=cH}?cc;>t37Ba&Q`CuVq(~D!4 z*V8`bou@tY>>U#NiE^g@&fTLKW%{gx5;J`FsM+VoLJX~^)+Alk5XKm#C38v58Ioa= zP9n^TaR1#2SWka{1!ECq6Gq3K%$cT2+Q*3kT6fTlwAu;bBD@eL>SOklCHiI|a6@Jg7Tn-g&g|S9UCKpPv&1r0KH45j7FM&a4JvXkJxb zHxb9jh(}%0%oSOgS62vu?*U*SdxH{MH?uzsQddDVR^DoN|H1IuqqDPx?j*cqFyVvQ z_Gz*6_h8`Z+M}T^mgvNI;Ai9Uo`|$uHyg=Jx)|fox~v#EUFz0=qfs{!5#5MWc#jSj zC6_X^xvZ>dvXa)Nw5%#95l^d6_a!V4mV$>7#J(0p;mZ_SXT=od{Y>O zJH?CeL2(NHDvSedO;8v%N-y;Dh=IM*Mevj^!Hw!U*e`h?Us{AliRtH9#^J!z(v%Z1 z#*rQDWC#N_QL1o85p*_{Vb8ZY)!yXISQ@vL_foeKv@^SvIOj` z@u@^lqlL(cD?s!w=T!1K3L^YzEx=4=^!zF4_n*9643sJwJgJP6i$1Jyuv&d( Date: Sun, 21 Feb 2021 20:55:25 -0800 Subject: [PATCH 13/31] COMPAREDIRECTORIES: removed makesysout from MEDLEY-FIX-DIRS, new EOLTYPE tool Larry reorganized the directories so makesysout no longer exists. EOLTYPE now takes a SHOWCONTEXT argument. This prints the context of eol characters that are not consistent with the original type of the file. --- lispusers/COMPAREDIRECTORIES | 2 +- lispusers/COMPAREDIRECTORIES.LCOM | Bin 23248 -> 24355 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/COMPAREDIRECTORIES b/lispusers/COMPAREDIRECTORIES index d204ff9e..169007cd 100644 --- a/lispusers/COMPAREDIRECTORIES +++ b/lispusers/COMPAREDIRECTORIES @@ -1 +1 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 7-Jan-2021 23:21:40"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;275 63412 changes to%: (FNS COMPAREDIRECTORIES) previous date%: "31-Oct-2020 09:13:05" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;274) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020, 2021 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 7-Jan-2021 23:21 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (~= '~=) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (CL:WHEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) (SETQ BINCOMP (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2))) (* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.") [NOT (AND (MEMB '~= SELECT) BINCOMP (EQ (FETCH EOL OF INFO1) (FETCH EOL OF INFO2]) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) BINCOMP] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 16-Oct-2020 13:42 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) ELSE (SETQ FPNAME '*))) (CL:UNLESS FPEXT (SETQ FPEXT '*)) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 31-Oct-2020 09:12 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (EQ T DFASLMARGIN) THEN '(T 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (NOT (FIXP DFASLMARGIN)) THEN (ERROR "ILLEGAL DFASLMARGIN" DFASLMARGIN) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN) ELSE (LIST DFASLMARGIN 0))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES MARGIN) (* ; "Edited 30-Oct-2020 22:01 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (SETQ MARGIN (ITIMES (OR MARGIN 2) 60 ONESECOND)) (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) MARGIN) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1632 17400 (COMPAREDIRECTORIES 1642 . 10869) (CDFILES 10871 . 15446) ( COMPAREDIRECTORIES.INFOS 15448 . 16963) (MATCHNAME 16965 . 17398)) (17401 24586 (CDPRINT 17411 . 22211 ) (CDPRINT.LINE 22213 . 24584)) (24587 26339 (CDMAP 24597 . 25293) (CDENTRY 25295 . 25463) (CDSUBSET 25465 . 26337)) (26340 31871 (BINCOMP 26350 . 30639) (EOLTYPE 30641 . 31869)) (32084 45291 ( FIND-UNCOMPILED-FILES 32094 . 35737) (FIND-UNSOURCED-FILES 35739 . 38548) (FIND-SOURCE-FILES 38550 . 40254) (FIND-COMPILED-FILES 40256 . 42334) (FIND-UNLOADED-FILES 42336 . 43080) (FIND-LOADED-FILES 43082 . 43636) (FIND-MULTICOMPILED-FILES 43638 . 45289)) (45292 53494 (CREATED-AS 45302 . 50099) ( SOURCE-FOR-COMPILED-P 50101 . 52799) (COMPILE-SOURCE-DATE-DIFF 52801 . 53492)) (53495 62474 ( FIX-DIRECTORY-DATES 53505 . 55473) (FIX-EQUIV-DATES 55475 . 56735) (COPY-COMPARED-FILES 56737 . 58861) (COPY-MISSING-FILES 58863 . 60702) (COMPILED-ON-SAME-SOURCE 60704 . 62472)) (62629 63240 ( COMPARE-ENTRY-SOURCE-FILES 62639 . 63238))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Feb-2021 20:37:49"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>COMPAREDIRECTORIES.;282 65535 changes to%: (FNS EOLTYPE EOLTYPE.SHOW) (VARS COMPAREDIRECTORIESCOMS) previous date%: "21-Feb-2021 00:14:38" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>COMPAREDIRECTORIES.;278) (* ; " Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME MEDLEY-FIX-DIRS) (VARS MEDLEY-FIX-DIRS) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE EOLTYPE.SHOW) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 7-Jan-2021 23:21 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (~= '~=) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (CL:WHEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) (SETQ BINCOMP (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2))) (* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.") [NOT (AND (MEMB '~= SELECT) BINCOMP (EQ (FETCH EOL OF INFO1) (FETCH EOL OF INFO2]) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) BINCOMP] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 16-Oct-2020 13:42 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) ELSE (SETQ FPNAME '*))) (CL:UNLESS FPEXT (SETQ FPEXT '*)) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) (MEDLEY-FIX-DIRS [LAMBDA (DIRS) (* ; "Edited 8-Jan-2021 23:00 by rmk:") (* ;  "Edited 4-Jan-2021 15:42 by larry") (for X in (OR (MKLIST DIRS) MEDLEY-FIX-DIRS) join (FIX-DIRECTORY-DATES (MEDLEYDIR (PRINT X T]) ) (RPAQQ MEDLEY-FIX-DIRS ("sources" "library" "lispusers" "internal/library" "greetfiles" "docs>Documentation Tools" "cltl2" "clos")) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 9-Jan-2021 10:12 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (CONCAT (SELECTQ (CAR (FETCH EQUIV OF ENTRY)) (CR 'C) (LF 'L) (CRLF 2) "x") (SELECTQ (CADR (FETCH EQUIV OF ENTRY)) (CR 'C) (LF 'L) (CRLF 2) "x"))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE SHOWCONTEXT) (* ; "Edited 21-Feb-2021 20:34 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (* ;; "If SHOWCONTEXT, it is the number of bytes before and after an EOL inconsistency (e.g. seeing CR after having seen LF) that will be displayed on the TTY. The position of the inconsistency will be marked with ##.") (SELECTQ SHOWCONTEXT (NIL) (T (SETQ SHOWCONTEXT 100)) (CL:UNLESS (FIXP SHOWCONTEXT) (ERROR "SHOWCONTEXT must be an integer" SHOWCONTEXT))) (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (\BIN STREAM) (IF (MEMB EOLTYPE '(LF CR)) THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM) (RETURN NIL)) ELSE (SETQ EOLTYPE 'CRLF)) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'CR STREAM) (RETURN NIL)) ELSE (SETQ EOLTYPE 'CR))) (LF (IF (MEMB EOLTYPE '(CR CRLF)) THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM) (RETURN NIL)) ELSE (SETQ EOLTYPE 'LF))) NIL]) (EOLTYPE.SHOW [LAMBDA (SHOWCONTEXT OLDTYPE NEWTYPE STREAM) (* ; "Edited 21-Feb-2021 20:20 by rmk:") (* ;; "Returns T if we should continue") (CL:WHEN SHOWCONTEXT (LET ((FILEPOS (GETFILEPTR STREAM))) (COPYBYTES STREAM T (IDIFFERENCE FILEPOS SHOWCONTEXT) FILEPOS) (PRINTOUT T OLDTYPE "->" NEWTYPE " " FILEPOS T) (COPYBYTES STREAM T FILEPOS (IPLUS FILEPOS SHOWCONTEXT)) (TERPRI T) (CL:WHEN (EQ 'Y (ASKUSER NIL NIL "Continue? ")) (PRINTOUT T T "-------" T T) (SETFILEPTR STREAM FILEPOS) T)))]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 31-Oct-2020 09:12 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (EQ T DFASLMARGIN) THEN '(T 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (NOT (FIXP DFASLMARGIN)) THEN (ERROR "ILLEGAL DFASLMARGIN" DFASLMARGIN) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN) ELSE (LIST DFASLMARGIN 0))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES MARGIN) (* ; "Edited 30-Oct-2020 22:01 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (SETQ MARGIN (ITIMES (OR MARGIN 2) 60 ONESECOND)) (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) MARGIN) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1712 17919 (COMPAREDIRECTORIES 1722 . 10949) (CDFILES 10951 . 15526) ( COMPAREDIRECTORIES.INFOS 15528 . 17043) (MATCHNAME 17045 . 17478) (MEDLEY-FIX-DIRS 17480 . 17917)) ( 18092 25299 (CDPRINT 18102 . 22902) (CDPRINT.LINE 22904 . 25297)) (25300 27052 (CDMAP 25310 . 26006) ( CDENTRY 26008 . 26176) (CDSUBSET 26178 . 27050)) (27053 33994 (BINCOMP 27063 . 31352) (EOLTYPE 31354 . 33319) (EOLTYPE.SHOW 33321 . 33992)) (34207 47414 (FIND-UNCOMPILED-FILES 34217 . 37860) ( FIND-UNSOURCED-FILES 37862 . 40671) (FIND-SOURCE-FILES 40673 . 42377) (FIND-COMPILED-FILES 42379 . 44457) (FIND-UNLOADED-FILES 44459 . 45203) (FIND-LOADED-FILES 45205 . 45759) (FIND-MULTICOMPILED-FILES 45761 . 47412)) (47415 55617 (CREATED-AS 47425 . 52222) (SOURCE-FOR-COMPILED-P 52224 . 54922) ( COMPILE-SOURCE-DATE-DIFF 54924 . 55615)) (55618 64597 (FIX-DIRECTORY-DATES 55628 . 57596) ( FIX-EQUIV-DATES 57598 . 58858) (COPY-COMPARED-FILES 58860 . 60984) (COPY-MISSING-FILES 60986 . 62825) (COMPILED-ON-SAME-SOURCE 62827 . 64595)) (64752 65363 (COMPARE-ENTRY-SOURCE-FILES 64762 . 65361))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.LCOM b/lispusers/COMPAREDIRECTORIES.LCOM index 7a669cbf6265ddda6d75faddcc3714b0c444f27f..7acbaa7d67c3c8e1b23cd8a0a0cfede10869a9d6 100644 GIT binary patch delta 2443 zcmZWrO>7%g5cb;rfizZ|Hfd>_(&;u$?Shki`{!L(lsNV}-qx|5_2$P24oSQurcRvN z4r!jL0v=Qq5X*9Z~XlR_tBT!8&ka^iKLvlh$x5zL?I?cW3v9{OKR6bxe-}%N)_h@HT@9P#4rST z&?E7c8afLC5G^K)-V(v$wdM>7OfQ6vTC7iX6joH{hBm`5m> z$`-tAJULWI=cdCDnu=QmdS>d_`7o^1oR`bh)w-J-?t9=^L5LAKCTWizd&aMY>9wie z)-C@pJYStQYR?_5{Y^qg3?)uI*U%fe)4z|FS@f!l)Y0$$vagPMX(JE69tiMn+4BI zbfFWJL^bykMD@Igvh5`+kjP~daV%1ZNCG6RObUo7Hz5OrsK9;+8YJ+W86g^NyF>{( zU_i7h7y@Lb#~2{#QQ*VCgA|p351~{v{Do2`z@s22m|fJ+5$$4BbnPO>LAxlS8sI7B zA-GE(dr@XOTqsO~QWk>1U+00vxZe8v^p${LQCq3ADuN^Qn`LT0HFb$m0CI&4GQ~q4vJJ|K0TAlWOq% z_*BNkmLa1407KyWvR)k@1x;v6MTc=(j_`em4;KdR`|9|<7HAr!kuayzFCxb|nf@3V z@~iFA=|jC&RO|qx00g-aA4fJIu)7|N9T@3hIV``==Z}}xPn61A?`&2|bN<&Q_{1$j z+^xbUy*i{eqj+W}mdNA^21A*51%y(Ed9l0*byH_B6-O8lBR{sVdk<7v^X62-3d3BR_hIzb6|EE%F7LB!Koo}caC=H)q_I& zV)odUxchN%_f9fi(DqzS!0QIaDwIdkn{QWjNA*na@Y56!hOUZ&X*{6rAK~B zyN?^Euk9U_H`8s@Y?fW0L^)j=x$oNBip7#!!2=8q?(1*eyFjn)Jwo5#x3B4KO1t$f zA3{_pNJ)mxo+NKu*iE{}Bt+gO6@s&-&4PrnV4G=(phLWHWwKycfQ{bKA`>QZ`Qm7i zQ80q3qecS208Qjk)eD7h(qUFlv(2@lx+@3~VQf1=MokFSB6}$YVm{LTAP)#g42kM; zqrAN8Jj)mYA?%V3^SXp@mNMxN!$(^E!+pp0U`LXcl6oTGuCS}e+Kb#!h2BUXY#qCN zr~AUA)61QskE(<8?$jW?KQ%b)!OWYx2&|lyEI=@kG_tl;ghbNJrgAuuFTll%Kw*0P zC?=LoMkcd`+@zH-k~mZ|SUdXabcPGk@1{@C-=~c}baF@S10#+mXD0Rs*=&ap{kCY+ zt(opa!4R8@?ek0)sJm!3^YMv^hx3LIU$3s#=AAm0sZyS+&DL(XtNO}n-KjAx1AJ|H zwlch9UZ^=v<3;=jg!Uj`s?OIhC9CtROU`m*wo$GwgI%pw*xva{qk?~#P*&?4-^v$n GasLC2FlEsI delta 1322 zcmZux&2Jk;6!$s-rKLvsq$N$7hZWoFNOpH-XFu!~B*$Ji3;u}L+lYK2f@3wQOl`#h zA@z_8e?Y4d2M{Vk2!wM#W^D%}SZVjY`Tc(H&FuVU z_nRlu@k8m($|M+xx3_L3s6q))HBCvHDR*z`BaPj5tJd7B^RFZrHnce0eRh5_^ub=e z*8H%w+o*3t{gc*SJCf#=GZS2rW*pG|>6A<+!?3-zkFrpBkRVE$v9xA};~_b37p$yf zWn3!<;s09)Z%WaBE##u1fvz$_p|-Pi>qfl|`^`uiY~;m;BD`oV@v6Gl19O^`)S= zr0pAGcyhlNzwHh?HveswdC^NT>5`(uvSXJBs3{%X%p$0!(MJrOAI!}p)l-0KeTt-@ zdVR6#V(B$d71G0LO5soEW)8GdKuz^2RUIgyq(3iJSWiJx8n~8&%K>8cX=0qxy4n|F zd$Clao~me1g*FkzJbC&1m2qrKr1JzI<97ktWrbAf9 zs1h7uBn-k~pe6>vQyqoKQ>OVmrKZmlgaPm-VEQR$njtVuRDob5W(b4#>KpG21)1ip z&+8IKek8xik0Y{3|BC2A#`yd3+x&jCCDJ4LExsAM8Du7Z8v9d(Be^buFEvp5YmgZT zrXrBenIU-@RLCd_L*sw~x@2XF=m;)Mpv?PW0fr7lir-1#Qz;mbD*nmvAFqfb(-|8L zRN&!DONZ`uBXsiMYNxV$RuGM|Cl98V{8Q$SJ+%TIzwYtj@gRP&2mUB39t|+}cE-^NIjiJ4s~GK4 zzKp~IT)6@v{`*>y6LSg+D(eM)Z+#lG$LrQq-hMZcv$5JOJFAHt{$Hx79^a^puVkDm n$mNn%#nz=9$RQqk&*o1y&W*~2Ox5kqWc&IT8@BiT=56V3*gs8m From a9ce553070edfd599fbc993cf058871b8e3af47f Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sun, 21 Feb 2021 21:04:05 -0800 Subject: [PATCH 14/31] Update COMPAREDIRECTORIES.TEDIT --- lispusers/COMPAREDIRECTORIES.TEDIT | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lispusers/COMPAREDIRECTORIES.TEDIT b/lispusers/COMPAREDIRECTORIES.TEDIT index 9854a8ac..c5528d16 100644 --- a/lispusers/COMPAREDIRECTORIES.TEDIT +++ b/lispusers/COMPAREDIRECTORIES.TEDIT @@ -1,4 +1,4 @@ -XEROX COMPAREDIRECTORIES 2 4 1 COMPAREDIRECTORIES 1 4 By: Larry Masinter and Ron Kaplan This document edited on December 2, 1987 December 28, 1998 (Ron Kaplan) April 7, 2018 (Ron Kaplan) Rewritten August 25, 2020 (Ron Kaplan) COMPAREDIRECTORIES compares the contents of two directories, identifying files according to their creation dates and lengths. It is called using the function (COMPAREDIRECTORIES DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATES OUTPUTFILE ALLVERSIONS) [Function] Compares the creation dates of files with matching names in the lists that CDFILES returns for DIR1 and DIR2. Collects or prints CDENTRIES for those files that meet the SELECT criteria. May also collect or print entries for relevant files that exist in DIR1 or DIR2 but not both. SELECT specifies which the match/mismatch criteria for filtering the output. If SELECT is or contains AFTER or >: select entries where file1 has a later date than file2 BEFORE or <: select entries where file1 has an earlier date than file2 SAMEDATE or =: select entries where file1 and file2 have the same date -*: exclude entries where file1 does not exist *-: exclude entries where file2 does not exist ~=: exclude entries where file1 and file2 are byte-equivalent SELECT = NIL is equivalent to (< > -* *-). Excludes files with matching dates, a useful default for identifying files that may require further attention. SELECT = T is equivalent to (= < > -* *-). Includes all files for processing by other functions or later filtering by CDSUBSET (below). SELECT may also contain the token AUTHOR to indicate that authors should be provided in the printed output (see CDPRINT below). Unless USEDIRECTORYDATES, the FILECREATED date is used for the date comparison of Lisp source and compiled files, otherwise the file-system CREATIONDATE is used. If OUTPUTFILE=NIL, then a list of the form (Parameters . entries) is returned. Parameters is a list (DIR1 DIR2 SELECT DATE) that records the parameters of the comparison. Entries contains one entry for each of the file-comparisons that meets the SELECT criteria. Each entry is a CDENTRY record with fields (matchname info1 daterel info2 equiv) where matchname is the name.extension shared by the two files, and each file info is either NIL (for nonexistent files) or a CDINFO record with fields (fullfilename date length author type eol) type is SOURCE for Lisp source (filecreated) files, COMPILED for Lisp compiled files, otherwise the PRINTFILETYPE (TEXT, TEDIT...) or NIL. eol is CR, LF, CRLF, or NIL. When both files exist, the date relation is one of <, =, or >. Otherwise, the date relation is * if only one file exists. EQUIV is EQUIVALENT for files with different dates but exactly the same bytes, otherwise NIL. If OUTPUTFILE is not NIL, then it is a filename or open stream on which selected entries will be printed (T for the terminal) by CDPRINT. COMPAREDIRECTORIES sets the variable LASTCDENTRIES is set to the selected entries. This is used by the functions below if their CDENTRIES is NIL. (CDFILES DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) [Function] Returns a list of full filenames for files in directory DIR (NIL=T=the connected directory) that match the other file-name filtering criteria. Files are excluded if: Their name does not match a pattern in FILEPATTERNS (NIL = *). Dotted files are excluded unless FILEPATTERNS includes .* and files in subdirectories are excluded if the number of subdirectories exceeds DEPTH (below). Their extension is in the list EXTENSIONSTOAVOID (* excludes all extensions). They are not the highest version unless ALLVERSIONS=T. DEPTH controls the depth of subdirectory exploration. T means all levels, NIL means no subdirectories. Otherwise the maximum number of ">" characters below the starting DIR in the fullname of files. (CDFILES) produces all the newest, undotted files in the immediate connected directory. (CDPRINT CDENTRIES FILE PRINTAUTHOR) [Function] Prints CDENTRIES on FILE, with one line for each entry. The line for each entry is of the form FILE1 (AUTHOR) SIZE DATE relation DATE FILE2 (AUTHOR) SIZE For example ACE.;1 (Joe) 4035 2-May-1985 18:03:54 < 30-Sep-1985 11:14:48 ACE.;3 (Sam) 5096. The line for byte-equivalent files is prefixed with ==. If the files are equivalent except for a difference in end-of-line conventions, the equivalence prefix will indicate the convention for each file (C for CR, L, for LF, 2 for CRLF). Thus C2 indicates that the files are equivalent except that file1 marks line ends with CR and file2 with CRLF. Note that because of the setting of LASTCDENTRIES, evaluating (CDPRINT) after COMPAREDIRECTORIES prints the results of the last comparision. For conciseness, authors are included only if PRINTAUTHOR or if AUTHOR is included in the SELECT parameter of CDENTRIES. Also, the redundant file-name hosts/directories are not printed. (CDMAP CDENTRIES FN) [Function] (CDSUBSET CDENTRIES FN) [Function] CDMAP applies FN to each CDENTRY in CDENTRIES. CDSUBSET applies FN and also returns the subset of CDENTRIES for which FN is non-NIL and preserves in the value the parameters of CDENTRIES. For convenience, at each invocation the variables MATCHNAME INFO1 DATEREL INFO2 and EQUIV are bound to the corresponding fields and can be used freely by FN. USEFUL UTILITIES (FIX-DIRECTORY-DATES FILES) [Function] For every file included in or specified by FILES, if it is a Lisp source or compiled whose directory creation date is more than 30 seconds later than its internal filecreated date (presumably because of copying), then its directory date is reset to match the internal date. FILES can be a list of file names or a pattern interpretable by FILDIR. Returns a list of files whose dates have been changed. (FIX-EQUIV-DATES CDENTRIES) [Function] If there is an entry in CDENTRIES whose files are EQUIVALENT but with different directory creation dates, the directory date of the file with the later date (presumably a copy) is reset to match the date of the earlier file. In the end all equivalent files will have the same (earliest) date. Returns a list of files whose dates have been changed. (COPY-MISSING-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with a source file but no target file has a matchname in MATCHNAMES, the source file is copied to the target directory. All target-absent files are copied if MATCNAMES is NIL. Source properties (including version number) are preserved in the target. (COPY-COMPARED-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with both source and target files has a matchname in MATCHNAMES, the source file is copied to a new version of the target file. All files are copied if MATCHNAMES is NIL. (COMPARE-ENTRY-SOURCE-FILES CDENTRY LISTSTREAM EXAMINE DW?) [Function] This is a simple wrapper for calling COMPARESOURCES if the CDENTRY files are Lisp source files. The function (CDENTRY MATCHNAME CDENTRIES is useful for extracting a particular entry, with CDENTRIES defaulting to LASTCDENTRIES. (COMPILED-ON-SAME-SOURCE CDENTRIES) [Function] Returns the subset of entries with Lisp compiled files (dfasl or lcom) that are compiled on the same source, according to SOURCE-FOR-COMPILED-P below. Presumably one should be removed to avoid confusion. (FIND-SOURCE-FILES CFILES SDIRS DFASLMARGIN) [Function] Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES and SFILES is list of files in SDIRS that CFILE was compiled on according to SOURCE-FOR-COMPILED-P. This suggests that at least one of SFILES should be copied to CFILE's location (or vice versa). (FIND-COMPILED-FILES SFILES CDIRS DFASLMARGIN) [Function] Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES and CFILES are files in CDIRS that are compiled on SFILE according to SOURCE-FOR-COMPILED-P. This suggests that at least one of CFILES should be copied to SFILE's location. (FIND-UNCOMPILED-FILES FILES DFASLMARGIN COMPILEXTS) [Function] Returns a list of elements each of which corresponds to a source file in FILES for which no appropriate compiled file can be found. An appropriate compiled file is a file in the same location with extension in COMPILEEXTS (defaulting to *COMPILED-EXTENSIONS*) that satisfies SOURCE-FOR-COMPILED-P. Each element is a list of the form (sourcefile . cfiles) cfiles contains compiled files that were compiled on a different version of sourcefile, NIL if no such files exist. Each cfile item is a pair (cfile timediff) where timediff is the time difference (in minutes) between the creation date of the compiled-file's source and the creation date of sourcefile (positive if the cfile was compiled later, as should be the case). FILES can be an explicit list of files, or a file specification interpretable by FILDIR; in that case only the newest source-file versions are processed. (FIND-UNSOURCED-FILES CFILES DFASLMARGIN COMPILEXTS) [Function] Returns the subset of the compiled files specified by CFILES for which a corresponding source file according to SOURCE-FOR-COMPILED-P cannot be found in the same directory. CFILES can be a list of files or a pattern that FILDIR can interpret. COMPILEEXTS can be one or more explicit compile-file extensions, defaulting to *COMPILED-EXTENSIONS*. (SOURCE-FOR-COMPILED-P SOURCE COMPILED DFASLMARGIN) [Function] Returns T if it can confirm that Lisp COMPILED file was compiled on Lisp SOURCE file. SOURCE and COMPILED can be provided as CREATED-AS values, to avoid repetitive computation. This compares the information in the filecreated expressions, original file names and original dates, and not the current directory names and dates. It appears that the times in DFASL files may differ from the filecreated source dates by a few minutes. The DFASLMARGIN can be provided to loosen up the date matching criterion. DFASLMARGIN is a pair (max min) and a DFASL COMPILED is deemed to be compiled on SOURCE if the compiled's source date is no more than max and no less than min minutes after the source date. A negative min allows for the possibility that the compiled-source date is earlier than the candidate source date. DFASLMARGIN defaults to (20 0). A single positive number x is coerced to (x 0). A single negative number is coerced to (-x x) (compiled file is no more than x minutes later or earlier). T is infinity in either direction. Examples: (T 0): COMPILED compiled on source later than SOURCE (0 T): COMPILED compiled on source earlier than SOURCE (odd) 12: COMPILED compiled on source later than SOURCE by no more than 12 minutes -12: COMPILED compiled on source 12 minutes before or after SOURCE (FIND-MULTICOMPILED-FILES FILES SHOWINFO) [Function] Returns a list of files in FILES that have more than one type of compiled file (e.g. LCOM and DFASL). FILES is interpretable by FILDIR. If SHOWINFO, then the value contains a list for each file of the form ÿÿï!ÿ(rootname loaded-version . CREATED-AS information for each compile-type) Otherwise just the rootname of the source is returns. (CREATED-AS FILE) [Function] If FILE is a Lisp source or compiled file, returns a record of its original filename and filecreated dates, and for compiled files, also the original compiled-on name and date. The return for a source file is a pair (sfullname sfilecreateddate) The return for a compiled file is a quadruple (cfullname cfilecreated sfullname sfilecreateddate) where sfullname and sourcefilecreated are extracted from the file's compiled-on information. The return is (fullname NIL) for a non-Lisp file. (EOLTYPE FILE) [Function] Returns the EOLTYPE of FILE (CR, LF, CRLF) if the type is unmistakable: contains at least one instance of one type and no instances of any others. (BINCOMP FILE1 FILE2 EOLDIFFOK) [Function] Returns T if FILE1 and FILE2 are byte-identical. If EOLDIFFOK and FILE1 and FILE2 differ only in their eol conventions, the value is a list of the form (EOL1 EOL2), e.g. (CR CRLF). Otherwise the value is NIL. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4ÈÈ40ÈÈ4 ÈÈ4ÈÈ.4@È4ÈÈ.È.ŠŠ8.ŠŠ8JÈÈ PAGEHEADING RUNNINGHEAD. +XEROX COMPAREDIRECTORIES 2 4 1 COMPAREDIRECTORIES 1 4 By: Larry Masinter and Ron Kaplan This document edited on December 2, 1987 December 28, 1998 (Ron Kaplan) April 7, 2018 (Ron Kaplan) Rewritten August 25, 2020 (Ron Kaplan) COMPAREDIRECTORIES compares the contents of two directories, identifying files according to their creation dates and lengths. It is called using the function (COMPAREDIRECTORIES DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATES OUTPUTFILE ALLVERSIONS) [Function] Compares the creation dates of files with matching names in the lists that CDFILES returns for DIR1 and DIR2. Collects or prints CDENTRIES for those files that meet the SELECT criteria. May also collect or print entries for relevant files that exist in DIR1 or DIR2 but not both. SELECT specifies which the match/mismatch criteria for filtering the output. If SELECT is or contains AFTER or >: select entries where file1 has a later date than file2 BEFORE or <: select entries where file1 has an earlier date than file2 SAMEDATE or =: select entries where file1 and file2 have the same date -*: exclude entries where file1 does not exist *-: exclude entries where file2 does not exist ~=: exclude entries where file1 and file2 are byte-equivalent SELECT = NIL is equivalent to (< > -* *-). Excludes files with matching dates, a useful default for identifying files that may require further attention. SELECT = T is equivalent to (= < > -* *-). Includes all files for processing by other functions or later filtering by CDSUBSET (below). SELECT may also contain the token AUTHOR to indicate that authors should be provided in the printed output (see CDPRINT below). Unless USEDIRECTORYDATES, the FILECREATED date is used for the date comparison of Lisp source and compiled files, otherwise the file-system CREATIONDATE is used. If OUTPUTFILE=NIL, then a list of the form (Parameters . entries) is returned. Parameters is a list (DIR1 DIR2 SELECT DATE) that records the parameters of the comparison. Entries contains one entry for each of the file-comparisons that meets the SELECT criteria. Each entry is a CDENTRY record with fields (matchname info1 daterel info2 equiv) where matchname is the name.extension shared by the two files, and each file info is either NIL (for nonexistent files) or a CDINFO record with fields (fullfilename date length author type eol) type is SOURCE for Lisp source (filecreated) files, COMPILED for Lisp compiled files, otherwise the PRINTFILETYPE (TEXT, TEDIT...) or NIL. eol is CR, LF, CRLF, or NIL. When both files exist, the date relation is one of <, =, or >. Otherwise, the date relation is * if only one file exists. EQUIV is EQUIVALENT for files with different dates but exactly the same bytes, otherwise NIL. If OUTPUTFILE is not NIL, then it is a filename or open stream on which selected entries will be printed (T for the terminal) by CDPRINT. COMPAREDIRECTORIES sets the variable LASTCDENTRIES is set to the selected entries. This is used by the functions below if their CDENTRIES is NIL. (CDFILES DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) [Function] Returns a list of full filenames for files in directory DIR (NIL=T=the connected directory) that match the other file-name filtering criteria. Files are excluded if: Their name does not match a pattern in FILEPATTERNS (NIL = *). Dotted files are excluded unless FILEPATTERNS includes .* and files in subdirectories are excluded if the number of subdirectories exceeds DEPTH (below). Their extension is in the list EXTENSIONSTOAVOID (* excludes all extensions). They are not the highest version unless ALLVERSIONS=T. DEPTH controls the depth of subdirectory exploration. T means all levels, NIL means no subdirectories. Otherwise the maximum number of ">" characters below the starting DIR in the fullname of files. (CDFILES) produces all the newest, undotted files in the immediate connected directory. (CDPRINT CDENTRIES FILE PRINTAUTHOR) [Function] Prints CDENTRIES on FILE, with one line for each entry. The line for each entry is of the form FILE1 (AUTHOR) SIZE DATE relation DATE FILE2 (AUTHOR) SIZE For example ACE.;1 (Joe) 4035 2-May-1985 18:03:54 < 30-Sep-1985 11:14:48 ACE.;3 (Sam) 5096. The line for byte-equivalent files is prefixed with ==. If the files are equivalent except for a difference in end-of-line conventions, the equivalence prefix will indicate the convention for each file (C for CR, L, for LF, 2 for CRLF). Thus C2 indicates that the files are equivalent except that file1 marks line ends with CR and file2 with CRLF. Note that because of the setting of LASTCDENTRIES, evaluating (CDPRINT) after COMPAREDIRECTORIES prints the results of the last comparision. For conciseness, authors are included only if PRINTAUTHOR or if AUTHOR is included in the SELECT parameter of CDENTRIES. Also, the redundant file-name hosts/directories are not printed. (CDMAP CDENTRIES FN) [Function] (CDSUBSET CDENTRIES FN) [Function] CDMAP applies FN to each CDENTRY in CDENTRIES. CDSUBSET applies FN and also returns the subset of CDENTRIES for which FN is non-NIL and preserves in the value the parameters of CDENTRIES. For convenience, at each invocation the variables MATCHNAME INFO1 DATEREL INFO2 and EQUIV are bound to the corresponding fields and can be used freely by FN. USEFUL UTILITIES (FIX-DIRECTORY-DATES FILES) [Function] For every file included in or specified by FILES, if it is a Lisp source or compiled whose directory creation date is more than 30 seconds later than its internal filecreated date (presumably because of copying), then its directory date is reset to match the internal date. FILES can be a list of file names or a pattern interpretable by FILDIR. Returns a list of files whose dates have been changed. (FIX-EQUIV-DATES CDENTRIES) [Function] If there is an entry in CDENTRIES whose files are EQUIVALENT but with different directory creation dates, the directory date of the file with the later date (presumably a copy) is reset to match the date of the earlier file. In the end all equivalent files will have the same (earliest) date. Returns a list of files whose dates have been changed. (COPY-MISSING-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with a source file but no target file has a matchname in MATCHNAMES, the source file is copied to the target directory. All target-absent files are copied if MATCNAMES is NIL. Source properties (including version number) are preserved in the target. (COPY-COMPARED-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with both source and target files has a matchname in MATCHNAMES, the source file is copied to a new version of the target file. All files are copied if MATCHNAMES is NIL. (COMPARE-ENTRY-SOURCE-FILES CDENTRY LISTSTREAM EXAMINE DW?) [Function] This is a simple wrapper for calling COMPARESOURCES if the CDENTRY files are Lisp source files. The function (CDENTRY MATCHNAME CDENTRIES is useful for extracting a particular entry, with CDENTRIES defaulting to LASTCDENTRIES. (COMPILED-ON-SAME-SOURCE CDENTRIES) [Function] Returns the subset of entries with Lisp compiled files (dfasl or lcom) that are compiled on the same source, according to SOURCE-FOR-COMPILED-P below. Presumably one should be removed to avoid confusion. (FIND-SOURCE-FILES CFILES SDIRS DFASLMARGIN) [Function] Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES and SFILES is list of files in SDIRS that CFILE was compiled on according to SOURCE-FOR-COMPILED-P. This suggests that at least one of SFILES should be copied to CFILE's location (or vice versa). (FIND-COMPILED-FILES SFILES CDIRS DFASLMARGIN) [Function] Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES and CFILES are files in CDIRS that are compiled on SFILE according to SOURCE-FOR-COMPILED-P. This suggests that at least one of CFILES should be copied to SFILE's location. (FIND-UNCOMPILED-FILES FILES DFASLMARGIN COMPILEXTS) [Function] Returns a list of elements each of which corresponds to a source file in FILES for which no appropriate compiled file can be found. An appropriate compiled file is a file in the same location with extension in COMPILEEXTS (defaulting to *COMPILED-EXTENSIONS*) that satisfies SOURCE-FOR-COMPILED-P. Each element is a list of the form (sourcefile . cfiles) cfiles contains compiled files that were compiled on a different version of sourcefile, NIL if no such files exist. Each cfile item is a pair (cfile timediff) where timediff is the time difference (in minutes) between the creation date of the compiled-file's source and the creation date of sourcefile (positive if the cfile was compiled later, as should be the case). FILES can be an explicit list of files, or a file specification interpretable by FILDIR; in that case only the newest source-file versions are processed. (FIND-UNSOURCED-FILES CFILES DFASLMARGIN COMPILEXTS) [Function] Returns the subset of the compiled files specified by CFILES for which a corresponding source file according to SOURCE-FOR-COMPILED-P cannot be found in the same directory. CFILES can be a list of files or a pattern that FILDIR can interpret. COMPILEEXTS can be one or more explicit compile-file extensions, defaulting to *COMPILED-EXTENSIONS*. (SOURCE-FOR-COMPILED-P SOURCE COMPILED DFASLMARGIN) [Function] Returns T if it can confirm that Lisp COMPILED file was compiled on Lisp SOURCE file. SOURCE and COMPILED can be provided as CREATED-AS values, to avoid repetitive computation. This compares the information in the filecreated expressions, original file names and original dates, and not the current directory names and dates. It appears that the times in DFASL files may differ from the filecreated source dates by a few minutes. The DFASLMARGIN can be provided to loosen up the date matching criterion. DFASLMARGIN is a pair (max min) and a DFASL COMPILED is deemed to be compiled on SOURCE if the compiled's source date is no more than max and no less than min minutes after the source date. A negative min allows for the possibility that the compiled-source date is earlier than the candidate source date. DFASLMARGIN defaults to (20 0). A single positive number x is coerced to (x 0). A single negative number is coerced to (-x x) (compiled file is no more than x minutes later or earlier). T is infinity in either direction. Examples: (T 0): COMPILED compiled on source later than SOURCE (0 T): COMPILED compiled on source earlier than SOURCE (odd) 12: COMPILED compiled on source later than SOURCE by no more than 12 minutes -12: COMPILED compiled on source 12 minutes before or after SOURCE (FIND-MULTICOMPILED-FILES FILES SHOWINFO) [Function] Returns a list of files in FILES that have more than one type of compiled file (e.g. LCOM and DFASL). FILES is interpretable by FILDIR. If SHOWINFO, then the value contains a list for each file of the form ÿÿï!ÿ(rootname loaded-version . CREATED-AS information for each compile-type) Otherwise just the rootname of the source is returns. (CREATED-AS FILE) [Function] If FILE is a Lisp source or compiled file, returns a record of its original filename and filecreated dates, and for compiled files, also the original compiled-on name and date. The return for a source file is a pair (sfullname sfilecreateddate) The return for a compiled file is a quadruple (cfullname cfilecreated sfullname sfilecreateddate) where sfullname and sourcefilecreated are extracted from the file's compiled-on information. The return is (fullname NIL) for a non-Lisp file. (EOLTYPE FILE SHOWCONTEXT) [Function] Returns the EOLTYPE of FILE (CR, LF, CRLF) if the type is unmistakable: contains at least one instance of one type and no instances of any others. Returns NIL if there is evidence of inconsistent types. If SHOWCONTEXT is an integer, it is the number of bytes for EOLTYPE to display before and after an instance of an inconsistent type. At each instance, the user is asked whether to continue scanning for other instances. SHOWCONTEXT = T is interpreted as 100. (BINCOMP FILE1 FILE2 EOLDIFFOK) [Function] Returns T if FILE1 and FILE2 are byte-identical. If EOLDIFFOK and FILE1 and FILE2 differ only in their eol conventions, the value is a list of the form (EOL1 EOL2), e.g. (CR CRLF). Otherwise the value is NIL. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4ÈÈ40ÈÈ4 ÈÈ4ÈÈ.4@È4ÈÈ.È.ŠŠ8.ŠŠ8JÈÈ PAGEHEADING RUNNINGHEAD. GACHA TERMINALMODERN MODERN @@ -14,5 +14,5 @@ XEROX COMPAREDIRECTORIES 2 4 1 COMPAREDIRECTORIES 1 4 By: Larry Masinter a  HRULE.GETFNMODERN #!(ž  \ -fJLL44C›Š€£6)˜.©Ú‹”K¦ÙN7ÉX1_A P]Ž»'%Z.“,]>I?û= ä0Ì:<ûAOA[@HÑ:BRJ6ÐK7Ù".9“-Õ  - 0 zº \ No newline at end of file +fJLL44C›Š€£6)˜.©Ú‹”K¦ÙN7ÉX1_A P]Ž»'%Z.“,]>I?û= ä0Ì:<ûAOA[@HÑ:BRJ6ÐK7Ù".9'Ñ-Õ  + 1Wzº \ No newline at end of file From d385cf61f380982ec926bd13ec23495744781fe7 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sun, 21 Feb 2021 21:13:25 -0800 Subject: [PATCH 15/31] Using Git Desktop to clean out old version-number files --- lispusers/COMPAREDIRECTORIES.LCOM.~270~ | Bin 23010 -> 0 bytes lispusers/COMPAREDIRECTORIES.LCOM.~274~ | Bin 23125 -> 0 bytes lispusers/COMPAREDIRECTORIES.TEDIT.~110~ | 18 ------------------ lispusers/COMPAREDIRECTORIES.TEDIT.~8~ | Bin 4442 -> 0 bytes lispusers/COMPAREDIRECTORIES.~261~ | 1 - lispusers/COMPAREDIRECTORIES.~268~ | 1 - lispusers/COMPAREDIRECTORIES.~269~ | 1 - 7 files changed, 21 deletions(-) delete mode 100644 lispusers/COMPAREDIRECTORIES.LCOM.~270~ delete mode 100644 lispusers/COMPAREDIRECTORIES.LCOM.~274~ delete mode 100644 lispusers/COMPAREDIRECTORIES.TEDIT.~110~ delete mode 100644 lispusers/COMPAREDIRECTORIES.TEDIT.~8~ delete mode 100644 lispusers/COMPAREDIRECTORIES.~261~ delete mode 100644 lispusers/COMPAREDIRECTORIES.~268~ delete mode 100644 lispusers/COMPAREDIRECTORIES.~269~ diff --git a/lispusers/COMPAREDIRECTORIES.LCOM.~270~ b/lispusers/COMPAREDIRECTORIES.LCOM.~270~ deleted file mode 100644 index c63c494811802fcdaf2eb09c03f0dff69dcb6748..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 23010 zcmc(HeQ;aXbtfJm*|IFM1WmCrs;F03l?GW+#d`orkdbAA04RV2a47&3MOhLe5o|z< z78OZOo$aQRx^6q0ZM%unBzBv&sgtzHw4DJz(6KGq*tXktXLkSC+39wa{Y)AP5NZ{0p~{p!utt2fT%*OsoXo_T(` zwz~Y8*r|~-t1Gu}F0I{K=EMtJGbIai$xr=SwLpTb72YKTJM7JSSE#tpblNFu0h0VRcoM zKXZHSg*(EGx0iJ4)TywjUA=>abcNjomN^l(CStMhLu?4m>?7R(F=~yP<6^0P^~NWc zZ;Lx?SY~9pSQcHoE_P7dytVx4m9-ac^HNYbY>u|qXvQYuBiO=^c$NT_o#!Ve(uuCf zoQTE5RIW(n0xyWIlgBQ!3{q&LD@Ta=tP*Um--n>xh^yJ21RRYeQySWG+-PMQ&1&$@4Oo zMs7?{o4I5KyTM&qdP*oW1@OQ^0*lF&OffBDagk4!E2(s*SRv#X6#Eik!*^h+d2r2# zzjfbVtZaW(C*KH82BvC(SJr*ss=dDM`+7aJ?)&YU@$4t5=Jt1HYbx>87XLPG?U8>` zx2dB6i*Q)kRKL3DIs-NFmsrI%euRs6(d|VbC6D;4M;d=Fj}26hwi@5pb^DD1 zdO`JisP{tPE4k+L*^7%U9MR`zdau+lTc(GBQvdXf?iPRO5z>`>XL*b+jd&bi$RMXvxIJ({f^CTqgVm zk5)b1k`s3NOiP}YXWrG&{G>c1Prs{SmjUo)epV-`n;CTTwCvfCaUY?SZ zp7$T;#W(t8LiMcroZ{WwI4ehGLQcvFyV0hQ2}4d8E0{3-A+3HDe0+{Kv1+ws6gy*K zXQI_pEqT&kJ-Pn=Eolu@qu3eQJ9stoCvqT|Nm_iE7 z#wOR}V^Nhm9#4pJR?g?ssGNvvvMmxssF}!(p%u|5F*-iN1YV3L#snxE`bRPHh<)*_urNZgl1*ikC1KH7v`f&x zQ(_Xc#HN?g5%?3NrKlPJf{Pg)9TCa-N)}TY$Jq>t@zJ;##?MGX3=NBMO!;Xs4nBjY zH6l)nadbydQ=Adw(HNcy^fx3DV^k-BqdYAV*x)l@#c||YVDv-6L_WGRaV+#R!ef~6 zQ5wpOfqkkem^cGFX~oc=iS5BNIx5QG?+jGqVA90v$D=fog~u2~i43H>3?K>PV&-QA zHa$6wMPrR(6jKX}CVcHPa+)~w?z2rZL#*V z^n%?9fBH7njKz>lL8iTWOIHMxgq@=kX$i0^$_lu8u3QOsL0n0EKsh9on24OlOrIVU zCQWd@2pLzNE#@vl`cPtsfb5HyU>$LtJ$&0+AtYma6F&Eqr8kGWZHPBS6JcxHNxyE96VVQR~rzulSfPGPgZ z_}kn|k*g^J{dVzNJoY;UZnk=AyS`oRR^n4iQ*v&^wQ~IIcyux4zn8A9Y=60RalirT(K%zaz|dcCB^2GGQ4q^r!2!fJgU~KDC+(lDeOf;fc&-RYVICB ze3HbQ#W&FVxdKmS`&$Jmwl`8m{Z^FW?Trz6BK_{>&!EB8%!R&M{lTV8n zNJuIR_F^)&lR`WMnr(^s;S?#nF;J(D7U<3{1YUUyEs!UhTUp>%Z31D9fN-fCh_J-%$}VIB}vVWh@zf=2?k}iQR@NK(PiVEO9gA!ycZl?F{05nr)y7@ z5!xOC1T+p(I|P>-W`VSg}6du1`q%+Y1Q(JVz`i1N29SzS81LRuIG#^_vGz;F zW|xaXa4|nznXY7Up_}nqQKx^wX!gsxYwm-EM+o6}XPRBJP{!V5BJ$$wz*~)f zgm?%WPe$f>y`~vwAYvt#b8woBcsLC&OoF|g&2T-oI*rCWuOpT?%Uc;A({dxQ&s`sq zKwHHJ1EbEV0n0ByDmL$sjLNbh6^ca61s$W11(bXNaM0oT3j-ui$@C)eYZppH9bAZutSnbhkvKo$awQ2%n5nEQj0@%5#Kh2iaUoZPwW}m6 zkp6~qkgo$78+vhVDB1Z6wk7c#4w;5lE z1cQ&uJ~loWSL(f<_m}Fub!OL$BNrATp`}PGYg|#fZM6s8RJ#|37&Mf5;MvX5Hvi{* zek=?fBIUlF!EF6mbh~gev~;pngmvbd+)x=tT1EW}yTdHkRmKIKE4y`KmND2gA z7b9(KJn8P2a_p}CIO$Y^zZIplA-&TpIC^j``$CE{g}*CyahXv2~6EE6hf`P|5@4RulB9K z|2(y!B@FJ}3dK&ldEJg|A2^xt#zh%|eL$=Dy{($;efRa2>?N~DSmnx||A-p8%Ke2? z8-4PqJa(V*?99(ScORAodE(1*K%V&iZ%Vd0kkw@UK^I$LW@Z1vseD29$Zp=pu1D#t zpMbUG?;A?A@(7@<+1hV%JdXTtrcZxUz%G3V>Py)%EOW`M#26S z3WArllQHOpjF@5soX$={uhhvnSgV`ffM1SzGh!Ajix|PCmY@lGHnFH9Ma00&)x<22 zd^_c6@D@g4LQ-Z`P?v)U>J$_zodSW^De!GQj)m!}Op+3G3S^yBY7z}}4iq$Zm{@>kiQ~+JbSW5;y(^GW$Q}!AOo?1`ps8`}B~#xx6jfXLh(p76IJJm_M=_a= zL)=t#u^V>X7)EQ?joIRfiIXg579f9Mu52KNf;*-OJ;bI8$RLa^uBK?IDq>c!`9qp% z6TOw&V)^--cRmC02E(}&TnmiUtJGQ;#ZhX_1cV@^)S9p$c$8W*YITVS*u~kRh}f_w z^Xc=+{CsAR)lAy%ifzTW1e4ivh4v7vV<+jI0|h6)(gkRv70`1fa8@)!COL`NITQN! z(qP&48n!{#2_SVh;KkDczb`Pk`P44PR-L7P$}kC6g2(+#G#JzP!GyeZ;t_-J4rdRJ z!7EV=lWYi=3gz2hCn2UoOhNdgqXig zh6IoO9=;?Ge%s1CGe+X9aECDSCKrQ(U}m}GVsKtzhr?z$jF;4IX2HaGciVsR9W3$z zDC`&%#@GBl-=j&tktD(wRKI@cs9#mgrE&QWm@hQuiNBzVws!uB{#9!6b}Q#8wH*sW z*ZPXmlz)RyX8V;@|I6H|GRUieR65Jtv1}DC(vs3n>AzkRK_4og`FG6HT zfm{q~F54MlzSB8lP8m#aIuBB|PC@k5DH!y03WnOY^)LoGQsrAv&2(zaq3|%W>AVrA z9*D2bgVNXT$pXXD`5tnv5y*rERTYy3Os9a2I)(0;+QVL_bBL&uaTSF?2i>02xzk3yeYa4U_vgMk-;1?0QfY>76hWq!cYw~vi5^I;xMf6E*B@%9HIiH&cX+96L?|s*N#-yJVkwEj2TyF?Ezwvh7Z@iPo-ov1XAN=<4uOHsd zJe|O6d8p`zY!$un*QB9?E_}2HqFp|$TGGS%aQzaT2l7I0dK%jbC0yode_dA}+O;Za1QpLvnGC3JeS!B$J8aPZrV;#ndQr79jrl{m|v+nUC;8v5DZ^zIkz> z*_VfBx0ks=ed!Rh{Dp3@xV`zG7kak-Teh~^1+QppMsuNh<8L|j7C-OiRu49guO8gq z`d94=O>c#+?bqv#-_LJ;c?O3Oy4U!1J_K8OfO1W0C`24$+(frXhA)9e0Ah%ELF6xy zxdJcbdIRAC3R8gq{N_O#z{usaTDc_Qbg--QRATB>2r1e-WU76`?sWUW&F6U1=Xhtx z&j;MfPq2W8E=R;fatgk-9ld|}aqD6DOzpwj$X~SUPMnY8ycF zcT|kgiA>~*2V-n7mwi+7#{!LZsSTI>&h79)gzqaS`CjA|PH%!k4@)_h=! zp_#_{SYW>+z$4rx1hmhUP>}E#>$n)$?=#9Bht@(cLYXjb#)WYQ_;}6}!u^*laBb@! z%7PH;Kjm1yVrwK2=s(PC{?$VFJTU03#@oJ#?Ra*b-cC%~6GaGzBGBj%tmeTM-ovrZ z6QV_`6H5HQozRCLjvnTR#FnxDkJzHY@58Z0@A1Q7OQQ2E+So#i{o$}h^-0`^NDPEs zupb4&iUTp>aUFrymk8QPS7J^@dXmFol&r;si%1)hFv5ZVxexA070AI*oMd$1&UzOB@kYmc~UBq>SJv~HNAt#$2 zYrY8y+-==AA)Bip6WFSBv3!7084_?wp-d5b@=mqMJxou~Csc%r3EPvM1f5dK2&fJxK!J4U&|+Nkiwme< zx@)-2+&w!T+udT4uooaq0P+B|7nqGqJ3ZJ1=%igCuJ906|F+v^Z{`f+jk2A=hVBRt zFB{;_=NK^fq1bP*$9GON_h%aw7N1VH&MBiN2>V7T+XlqV*g2uJ{5Kl^-ktvw+}RtA zyVT-OT_wL;xB2=$W*oZSmq=u3b8-p@QLZK(iUc6wcku8_bD7L6cAPkShv;RoXazl) z#4HlSK2XpC`@nvqD%C^0#faW~dcmRUQ}LXHmXF(#n8R8|esFT8PuM1BJ0&fapotox z?-9sK*@CLSVx>JgREV#F{iyaguCp#XJuD+^{lM3g2<)O}>>$ zh>|7V0N#ocLvTH`^a#IV{fbZ^HlC(W+X=^P8Mp^+exeBfQ8G`UbRK>#7WQ^shKtVszz7Q%+JE9(~)6PQ1ZI4X8nN6$g*XWD`V~!gR8nFC
%HcyDbqt7 zF7JDMG|DfOXA9k>T8Qh_f&J=!pY#d zL$W*2d`9-L3GsJ>JzbxGH^#ScDzw5>Y9Sg5272UCo=h(fyS=p!!Ltac4a)H5#d_nD z@H;6QCi~s<>UxBF;)c~D8^;UsNRmP8m3m`D9;x=hwS+j8KE$c?LU)(l{%ZI7gHOx8 z0ch}z@6~yD8RjNiP*8iXY%J!Bu(5urRc~a}OkU+m^-yCZ80{-I2Fby6SPs<+ycdv_ zdnvAFp!t|Qfng#q$rBXz3Rly88R_-9@ZbNocHxs}N1y1hzAHesk6~6BEbwONsTv2K zfwc>E!Ch}pSfIeFCd4byNsq6^MD*RRXrk~PCN_P0WH?!-APhyiVPJImz@g$}9?-Lh zRU?$8C^72-u%`^}3|WJn<8Y7IE*BCr+AbFp5r_`*g6zAfgBxZ^Sm2&uV$>ZG(VW|wL<*rl) zrN&^a7T?$0%k&GcTV1 z_+{?^1p&SXfPm+?#HT^#>b=n$BJUpP3?AgdNpim0*lmt`gHr(aD$WP6XM#VtnwbDS zJNOL}w8CEs)b$`XWHbuwCa^@2M&!1i)r9@NjmV%CLjqA-Tn&LdHo5~J+m$e(JrRxY znZj#fedjv%`hhZT@q;jNP9fqP;o)J0hkOP}6&+w>ACReyeUSG($OdzX=Y7yNL+=>e zK{ogawa8E=Y$9gf#xgS0G3ufK`$l~eS07ghibx&0G=$qz9{vqU9)y!{5E#i#u%hoH zdNx3}T!`m3{|Q*Gzs-g}b*K<%nnlF{)j|W`$lj~JoHg!c{cq%XAHaJbV}o0Vlv;n?ELdP^bHyg8%aRgShM& z0HP3bP_%%3>fS4WyHZ z3&q4tm?9LgLj&X^rD%6ffRXF~4`!8ZO098vcNX%a2VC#)Hs})e6X=rE%b*Lsp*R6_ zwUR_IJcF|mKsj<8;9PElvw}?qXGQ^XvFr-YDF>W21}O2!#xE4hvYE=|DOkXfT1Aj8hFu9m!$yMiq#N52@yp9 z4X!t71UahELa3i1H}5zJ^f)3oH^EmvQd9xUQK*8;7|z+kl7uJ+3iG8fR1e}ffWXAA19j$$d5K^` zjXE~$DoscS;@c!)w^c#z208)xlp04kXdetD zR^J^=)R<%jfVI^EuivZxk|OXbCWF`UdaLpGp8)&w1(T0~D;zGeDxoR=zoAwA1t@oUpZY=85yLOqlXT`=Cv=lnbd9xQ}5^!6GWPxo9smR(S+! zVLupR=q1@dfSVFf3;!JiT*P+2gvz^0lpk+PlqL+AE@o%aMFF>VM#>MfIKq8*MeHH- zG7oe@TJxShkU=SZojg`4FPdY5B`Y%E3B5yXmO_44pd5oodm2mu=(P% z*~U-kMIJ=p$lFR4nT4Z~UJT)d#z$My@tk{HY^xPJAm7z;uR zec%E@3kbq&Zmyh}D^UGsXgmO(7kznphSUlPSZ4nh| z&lC4qcEB8(6(AQ%s(bdT&n)klpsQ00`Sd!vYN}Kdfg66)+Ax7VsItPwZb%dKIv4BfQWT zJbr-DlTn)=2Z&XZujGlwKV!7h4K7`;*H)D5czNSmUfB%q?pb3}*JyYA)}D3ycGP`C zAw1*ytGU&EoOqKn)g^&fXLaUX#AfOlW^1ptN1Ltv&P@A_>5y7@eW_nZcv!BeT*7m8 zYsiA0rmmaQg)^N;@{|&+AS$-$0sMT0S%pxBxD)p$b1uKIo%pKt6KvVU9AZL)eIozdK%Lt^hF_%3tb6|_f!IH zBZzlLExV#6K=3*+MX^IPa??B@Fzmq{{Sa1@jWwLhPav8R>a$Lv(=Ztt_@bOxy0y%o z#R=oSw+NTlUbwZi+*txYSs0gx1znuR<+@t}pVzth0&d!^-4giJj?-cXV(*A)0v~m7 z;|C24Xzzq0DJnEmQlY{{TM&ep{3CIuwI`tn*B<^fZ#9ZxvE9Wx!j5*=+H~;bPMeS| zGb^!%g%7OtmvN~rFd47|4)FbyfE{t*Z%s81Fb;nn*ONK%i&KGX`z9$a+<329oYWEG z?=@3NgUJ%(J)<$dZf^}GRn#)fxKlM_W&1m=?3D5S`u0|E%8%FP!7P6N4>G{W$-bie zQae2pxTUL^FrwsaK}%^8bQ8>B3iL@I=LLWaXD{2v1cU@flOzC#wh^g_=pcP=D1t61 zRA|r9oq$v}Kkx>!?E*j<6|xBaLQXI2=Fe~ts_osPxJ}-Sq?4oGzq@*R?r;AG7h&CT zGM11j9rR06EpkrVe2$!nD%-m@9p5^gy8!2n`aag;u+kOvy#Yv}DW-y?6R9s50pdNH zFN>${6?_)q!Y(bR;~MIfjSDW__i~Y!a0THmo0G-DcUNCr=>EHRH;yr=1}Z8lOT_-PZG77;}ed)Ae8gnSY~}uL0H+&TXDYQt9*C zUsJ)u6is}kp@J^9e+w_jK&30cqJ)Q{YFSV}d`{|oiugK$x(BTMt-rzkR+v=5U)?9f z+^!ww3ZezxW`7w5$Ysa-Llm{c_lYaIw;rMo0_}h{ zo;!D)oJ%86pOnKBjEU;tSO^-Fo{mDd8x_p|1CEO#Bf_~NqBZd4GquOKl8?YmVKFVn zQ5JG#oX%PANkWEmh2`VM6{sIj3zxC^X6q?kkhVOOvP>e2MM=?88?{E|Z0(fI9#PXW&Z!sP$FZT?7DJ z`5cZvA-j!Df`MKe1~d|@&y09sp!eQv^H9DXdX_#3()fCQ;4WPiAX&E!1E8s17{G-g zh5>{Gr~_BuufTDDg*+TwfRrk@K)4>H!fTTb9i0B*oaFCWQT-qbSho;BFxMEN;zHs1c#zxyhy*LzxxIC!?0$=u6vMyZ_ivpjtMnq$N9c+dnK9mLcJVDRx?5wsN5X(xaHn8F zJsBvx*gk|ZIAR=-)J~(skzUfn-i0ax=pkO1dl!^O9WTa&0wV+F?YlDQ&v7Gn_QxCN z3CcWhG*5S;?}?%zFM;oaJ4JNM3>Tl&Z7Szb)#y4HmBO1T zfD~=$yHh2^)wCNBgrk6$*A-q}Tf5F0oAYH=^`Vrt)fzOqJNO1EFJ0+#x9wH36}U6t z57HBd0jjgGS#;M9@29Fqn?YinrvJLF$Fj_MJ9Bn%5)2A_xE8THZG6%Y(fMImJ*o}R zBt&v_l-}Ll(ser~rQ(#jlILkiB^bf}pbm@jI@(&_9p|8MKruH1p0*V++JTQ~ zvlIz<#w!ib)hsNMmrt-~69{_?@O@j{?k~wXK%3e>7wJIO++rzrHe10*lFu*Scwt!# zhzrZN)?S2_$a;Mi-B2JaGPoB23DT<-K>%EU1aPZJcv+u!${b1&`%NonoMQ%ZYr?z!iEzW4W?6Uk&}^QG+QY`%~k&6j4SIKGfd&!^60 zML1uoX3K?qWg#q%m$Ru%H8oS{%AQG8vcilG_e7|HG)h&o84-?|qjKf;s1>!MB04!` z#-^f)u!w|LHlDt*w!T^y8`nix^!#$BGXE>57H_TIymk88l^g3oUN}EVqlY#)5vaKX1Id?)7 zQ`K~?lqzQF%eY9>589xDCVr`u85NoALN!NulPXEsNnsBV{o#E=RI&hfg7pP~mQtk* z52b?F1b11X7UC*NEyP4c3E5Q`NDu9sFwAr}gjpy^S^QuI>Js(qC2co=^8vhx)U- z%FN!p>2&5yuk7!+hpJ?`--{{E8*t}cs_)!W_@hQ&FzPQff2nQ+jR(&3ZY>mpsXlo$ z&f2%474LRs<)SFqOCXh6Cw?3-!r0_RFp-}C3TOMom%j1nu?N}|;mPh@yqs>2) z$A@ai+Rb-#*+HX-R#3bV>OUWNA>VpBcVW4WE&BXi|K&Qmd{~A9t*i26KMz;UsTABi zAs-90epQb3*Lv%`f%do!|-n{dSj11L=+RYyswYVYU{#v|U8*fV|ophzA z+A_KIxSZOWlu5tAz12>&<&>R1-Ik~1>9;jBKO#@dQ*Ue7WdMARpS5XfW)96fF8j8m zobE!VgaTIG%A<1H^Zv6u`R1TZs+LuoGrXExXXLm{%4s=eSK1abX~-#K4Fje>q}8v2 zkI(WV)~vRSVr49>Otd!EmXG;sk8QqpQ(8l{C{{-H&hiju>I}&I=<`L)=){CbXBNtk z5kNF2EK$rBXOJ={9dbQ65mmX9@uaBaz>GGAgJaQ;d%%os=aC+0vP6PK?Jv`D7V&W8>l?7)2>*#**XqTw)WGx?F4mT!Cj5OH2w# zR-n<&H!P9<1_qWbmt`5u4lARlvdlazhMv?nYmzBGOGE0Lg?=iFGZhf~(ivf)hf+0{ z&ZWx2qP^&RLHo`Zlb9tIy@H0opCCa+RR<7e%;;J znlrI2^poH|%=kEUWyZih)eubVft|EsXwSs*;29kk74UZks!1?u;`NhJ>dC@m0-{6~ z5?>aOgnlvd(*ld0n#H6sM=_3}g~jUi+c(!%Z-qr102LOH_3(_Fl)kmPzPfUI?fNH> zj!jx3eC3wd_(gib>V!Xai%P~~NTwm@Ub(3Y0!qTp)`^S+*p*}zTs>c@hI=5cB;V&d zB$SwloWe*S9~LGJaIplrSDq>5FF^WGVu*k|jHzN8VeFbJjs?RCqSA!xeHfCKhI}nv zp?EcyudvVqF~yu9X@e5uLQ6_m+1bTH!G4R1SqM926alybn^-skUXxIiJ)bTtX0jOx zsYFRevkR&@w6UODh@%0Nh5$nnohhnvf!ZTMM~#An8?TsT?JEL7u*KrSEXxZx*@Q`q*w`x7Mq~r?jTzT!~BN`Pud8Vaoq{ zroOiO)%Nu}cbc*7_*3-)m*Sp+0VT=F0oi};Ehf{o{;$ivYkytqYd8O^?CZaJf4ji_ z2S3>_2Z{9`Rebo>od5jh9iLG<-f4~t)`OvZLnl1D(ZEwMP7CM7rq>eN*O&DkG;SKf~n$dk>jEO4t1 zfv^%FTxt|nEZJQR^pv``8ynLk-b}>o(V0+^)aZyP>H(NwP<9{!Sq)nm|RU z@UEgJ!~)QNG|yd{NstPg7lLFd#xX9mVkL-Q5W4^?0ZT}@8cKrQ5l_I*j1a|-V>!d8 zLA1dO!qDk0)TDP4{4geA`K zQpP8=+z9M*mxmzQ%~mZ4 zM7pWro=zuvk0Ix>woR~wotZLxK7*I6vFAChD0$HE<+T0@cJN}(Ry_N15Uznb5YbXq zSp*%j<+HTR0B*r^UD%I_0g`8AW|{c43niisF2qGnR;nmSoS$&Hnu2xARMr*7g-U*E zYGkprlrO;oR+d#re`d{!_*YHxyu3W5Ujht2_xmNHxuxk`XGm2iQjsKTmPM7{;8q+}CkWKofWT{273 zLsalY(uHiQw75Wqy<%kq2n0xU%pUZrqy|cX*wfU@*$QCJDIQb6ssI7P#1{q*`HZEA z5&Y8OoYwWW<4ciX@Bul%#s}kaqu=xXY@@%y?3!`p{8A*e5^3j*%SyMc^`V(s@6rf^ zhB6O4xjo+D|D4Z{rI80ox$k5!TYnPGE`b#Q5iAHH=_hTgjL&{Aa6_pVVJ#9$ufCD@BhVCsgU z5Nh+iUy%d;+Q8;}Pg5P5!tlYh@Y$)isOypK13MGmx*$Wa4`>y?zg?I8Z@<)*{bcqC zt6bUlHz=WtytOp8H6V}4<8M)(o%z|P-hyR8p8TpDk|*E!ie#$;Sxq+Y^sp6XUJfpe z6^gP?_VPOR+(&!;5UeGC*HogFM*wZl*T2H$Kp(~vfa!v)WM`j%`U?qKE6UKmG`9xE zYHS}Xz`8HS!TuErf|qrYG3bSim?8mAXD6Xo>SP?O)lF}}FDJYiF$+s6cj3*0)f{l@NM0Xh2g49k`i%S61f&YQ{z}mroM3~seDxFe+J?Wx^pSG78t2lskP9Hqtu#72ti7zHDN*UD79wP z>JbsJi!&t=v0+gbGUrl-#q2PvnY7$h+lp@qCbN|)tsz*)Uedb&3QoSJ^Uy}Cpyx{9 ztZIf#auTs~CiI=D!Lsc&Y=f>7KbEy$0bO_8uIAXQCJ;*$^%k&!NMrAPL;fVX=och&q@6W~87HS~nvt0TB!`-d1T3 zfk+TJZ?8@Xv3QFN2_E}B{7WAEwv~BijKo>t4q@g^E(Qg`%yP-a;Jm^PhsAOjFR9(k zf{F3&xBlciSmq5-*fA`OZ}@$_`%-=*MT9S?e*Mre{vF<#-RIZ+&vB#5Ag?-7=^S&DZ)cvGb}>I)3?nr5*2uRG zPb;dr-`95Dn7#H^gL`96ytje&%+`>5G&GZa`k@)x+0B1$WPi+7nLF>(Iq_wkowg?p z=|X31zW2X<5h6PZ_oz9tXzQF{i^B`sG6hvR0fN8oubPCw0Q)r&4J?wQlhln~E zSAj`p6wbSHVHN}v90!I(BT`o?jIZzpxa+Vlv-E?!pOHe>5 zmsp={eK4h5>b>goYrV74XDl19=KaQN1mUkU_`g9<|C{-1sh{a>LoICnz!$koVpz%- z?vC~;TEt|JCfJ!7DFU5Em?fs-b$t5n_mSQVH{QZvpN~4^PKlrrJZ2r1HR&w7aw5~R zLvsNGQ_DW?EIZU$*RsdoZ`lDA-Q&4&gvN6>>ppPRXH5G^5ec;J&G(0(^BZpz{KlIF ztUU~h_`z=<|N7zWEYJ?TSb&QDpsk`e{|#yApbH=FhG-8xtCsYzK3Km5=YhPCpPj|B zLJ5}zT3^_QWPw#qF+=YVuZT+>q}wI5a!4-jaeOW(dVq3GYA8e;V%$Wx zNQN(iMgU@nctPYZleq#f!s&2N_pZd$t`JgmR>)NA zhSllyftxSzpwIHkke?5@RhVJ{4^1Y-RB8skwmq$X@OJBNcu(!l58ha89ae%i5Uv1h zD}sA`Gk(9%DD&|6!9!ew(7|sVi7m(Pd9}9?-0UsAS4(jq^!B2IwA-_z5D7aQQg`># zS!DenwEXk1>x6fqQ&LrEAmL2u7$7#?84f z?tb2$bA)jJB?nyF`TL3>g!)f;mao_v2?Y9&bK8Hl)Vl}_dbRn6FJe2MUAwmzlMX}? z!l4K>Is~wJu!YxfqI-vEl4^&N|8G0=!JDJI`3bRQ;{PMIXz=@BY|(3cci58b-ir>l z&}4ryY*B3z_aPDkVHfO2fw1C0On6*dp!Fq!cG8uYQ<0wJa2O?PG2tT8MkI`I;C~*1 zJ5mL5Fcha49XR=er*^l-)hEupTbkB4vqOfn7t`NU>dV!8+nMjBmX&XBZZmhwPQ!My7$ock2or!j0PO{4BhyX~_W(L+RfsFxh1I{~ zwmFzN!+4`?XRx6=!ozb0xbs;C41Or~8|?F)6|H-6%_@ser`l(gQ4@rHE0pU1;&$w; zP+I=W&Hv!e|2b~#<>qTt<6pVH{6WL!>xYy4sR4)GQVz4-KkP1U>N*$FKlcO)@~wIqIg za;A6KCTDvkEta5(8lmk3WISUZoHlp?J2>4fML`xkSX%PH*a4*9RR+S;!7>t}(KDlq z9Po<~XE-pu;(}hsc$g-gYqXrLE|yE9vt?N%ua(vmGK8qhW3~d^gEl`^g8wL0 zAW%97KNkyo`%c8(B(#+#%?I|@S!#xoa9Sh0Ad{!ytI-@niVNBDC;&8r7%sT7Py&ET z9xFBc*+S|J=OTIvhS+o#i$#$Ls_5Q{QUeHK;9k+Ya-}IJDRqywZAT~G;Gzc9pty>S zM`5xFB1~a6RVfrx-1A-ILna3OK9hxM@t+I^V7RRZzRg<_ zOdW#K+n4XZ>Z>c$LmV#e*LiD{U#P$qx{LKZGuH3fe(7blK>XGG(1qqdXczefCazt@HT-uJW%pFBHyM@RMf z0kVDI!~j%w3%nV6s>XpQVC{lkaNiRZ7AUYP3GoVa(&K9}5q-BWnkamSiA|p<8BJ9v z2t$!>7#LkXaH#kg2lOmr)d*!NNsPJ(?5Th|L)KvDINT$)%Z0>@j?2YF1fqkyAp0)r z;D%We7Puvt7FegT4LB0ryffyx(+MB2ZAIX#o)*N&7 zp^+TQhh7D>hI@$~+qh;`NPl{kgvyTsru@?e@4u2NU1`oBij_nl-2!4Z$wdx4qzxly zl!^d?Ztuy!j1UdT&MFoB=O$yGk=ay?Oca`)RQMN03OZGRuvz;k5R($QSfX%1h&+nw zP%(8>NO>CWmdb!y?n`ArE(9Vf0uVO{ox{P@J^9x0x&HI@;MoUC%E|mi+1pvHzQDKg zuQi^_liBi>x#>Vld6-o^A0rc&<%bJ@bafaLfe zBm*QYDEooteXt0Y{FgWH_+|eP1p&SbfPm+?%)3G6>Vwf6BJTm{3?AgdNpim0*lkXF zgHr(aD$WP6XM#Vts+j;iJNOL}w8CEs)b$`XWHbuwCa}aOjmRB8s|ovk2a!Q5Mg*d^ zxEKO?Y;*@cb_!uY2O=8bGlkc}`p#wS`2%I#;s;^kfqbq<>a{@xto*jrFGqnfznTi3?U$iI3vrqKwSny?o9l?c z&|K8j38RV(GmBRkadJz@lk(^c^F_p8oaA6t98nPfeHH!buZ5c5m0}2}NJmuU0B{2Q zwe>Ty4`q7aEc!2P-igb;As`AN2Sp3myY4*}NbYY3%;DaAp)B7t6ljoOZxjV}KGr zol!ZYfFdZ3$j^dj{PZCGPaQ}H*ze%T6y#0cpDc}O@sP16815tRe^4GL@c(6?2N(*X zu7MYWbXW?2tym55lMq4lU*mX_Mv!9)Erj|Rar2JHfF4KXV-9*eR^t;;{oWH$&2Q=h zPzRyMdv`kMVZrROKYCaoMK*|A2utyz2NY!gxbO<8rB^-WR4}4M4|BG8AiVkjt zT>-VcNxbLZ_j=_1Onc-&9AJln@TB^paqGx)6+6!1N08|3m3GO!5MpUUR05&vYVsYD zu-~j8cLSY(d`gWY9JDtE607ev25L+*1HjzsftOxy{JJ9WDkg*H@lw0_cOM7)^956f z!4)1Zu_~b{|G%YK{W&OqyC7YJeD@C#NXJyTw?l=Sf1#o5fB7QtaM=UVvuE=hIkdp< zc{3pws3}pw0wQk!n9lS&(=IL+s(J5*+j~kJ64TdELhGQY5&A~9!#;`E7amHJ0sO64#8h@^LZ7d5d^@dh@+p6#N$S!*+e$(!)u0WNC%j4L& z#%T&22^b0uN>1Iagsyj?yV};z=}8_z;K|B^bEv-3KZi$OpXWm#HN2tyzp zVjnv%2uorxv*7yGr(!G!Ep+JxgccBl`TRm9yHKVed_<`NT*w4|c9BeekngxIg(lgj zZNT%mt_k?{)+MC~#>dJs0`bq2$^)9OUqIiq9eSY(yR$ZpP&viG9MKH6{OE;J}3a)LpwF7Om|bj0uC*$=2$n23taSILPH_U#myg?Y$0ES8j<9D zoP=@>7?EJ^LYO@20&Ni$X^#`WqR4fkuX{KX5k?cipJVWCOF;-xQN)q(0cw0%W&6Edat!*RVjt$`9)qLIsQm z4+nfk@Zhrz>2%)~K&3+40iW)q=7a zzII@VXtD~WAL7I-oT&~8e0^SLzJ}OLJ;Gf5#ZGVY_1~ZC zyfGb86K|{x>Ie_Z6_rbPu1*bE(9_g$b2@OQ^GKdjf)zx?4n2UMuQ;!;3MM{m0&TPj zE24cahv3rA1_xBF5%W{6QK(-hx{)+GyD-=xOo4PprQ{c*-8_(dR z-NsFU>vxF4}@1#N?lfGp#cSMYs;|r+JG} z42$h9-V=7Tzt*OMC->TfY?)b!H7tB!uHVI>w!n124miO5DFHj;z~7!}9cCPEj;-y! zpi(Dsh0OLxW8z=%t2&tbg{NlT`N~r>e>3xIGfx3?uO6DF$Z_M{R%u$tkiXkXrwk@s zOc@x_`E_?^B&Fh-Vd$Ny8*97YZ|7!=cN)7p!5KeZTSs#E{XfV6t2Zh9K)J5=Ixi@) z&Sum~jC2{rfx`My1q!&cSqNPKo&h3px~1}jCPOuRK&>a=B1V%;PGi=K*a5Ss!CZhmQUbB>wquzh8 zern-w{|A4<^2EvNLN<92LQVe2%k9h-c6OERowg2?-RIsY8(kpIrkR|Qa;2_B0_rFg z+C-G>9>3v)XEL9o5abljg8A1^{cx%Ghi=Pb*E!eATUD2GeW}D#yNr06?Ng=V4^nS$ z9cQ>Js3Z64GcgMWtG23IVyU(5RmZ=f)p4>>YcY%UKb&OFWed3NU{cd-XsU{EgW#&w z0uggZlE8dN;*DZ2>}%2L3XUY_dA0SSQXHA~W)K`9e#Cui1Y{YJO+mte#8!phh?~}1 z#zDz!w?040q2lT?ug<0vs5Wg0wXn=PqC&#~Eo3;6!N5g(Q_(3hZc^C3E0|yT-m5?# zgr~Ey-nDBus@xUf{_Xq8uF3Gvi>OGjx~Qr>y&d8&UAx(b<4>U2`nC*2nSYWl#bCph zy-jbXuI+xgRDAP|0tK5Fjjf52u@#$nQT8h8zV)cyIpxzTDMN!oIN9roLjSIfWU%F= zu~>vB>@V`#4j>09?cX^{<(x@@cBbew_#TyEqMX!b0DN?NX(3y@&rvE0ya?w@2nNB$ zYHE#f;$K8eVKIfqRu=OW?9LhQPC`U%l@J^d#Ll()?y&=ruZt zK%#U92Izc`$9{zKNDKprI8Ym|uE)T3fU(>iTtGlq<{?A_Qi4zzDr-2B#)U`@0UQ>2 zbumv0F+2nd&ZRn}c~$A;&yNj9J#IkKw@f0qhwdfPa*0bhCHT-3U7dZRiwt1%o~Q`ds-?G7ui7H;n+eXEH>^K>Kn7%D3A6!^Hg^N9|z z;artEtmSN~>RrdWQuH*%r=kvBYgI8yw-xi@T%&Rw~#Zu`X*vC$}Q-lgR~@M|=TBjQw`l&`8DJX}stEChYW zxX?SVmO`n0a2&-vAZueC9YWV2)#fnH5UX;JAkACposrcV5MD$*D9VBgon!n_XV z)<@Gh<{VJW)qtlRjfPg>Ls~3F0-o?n19b8WljP|W?AZjuUIJX7i^~Jbaskk$*3U&c zkhQQ}&Y#IuaWC_^)$7l!iXm}+_2$N>VT8GPW8>zP+iM%wVb+<1{ENppJtpWuVec?p V;}NF^&afh|FG*H$QfWy^{J&YkZ+QR! diff --git a/lispusers/COMPAREDIRECTORIES.TEDIT.~110~ b/lispusers/COMPAREDIRECTORIES.TEDIT.~110~ deleted file mode 100644 index d3559442..00000000 --- a/lispusers/COMPAREDIRECTORIES.TEDIT.~110~ +++ /dev/null @@ -1,18 +0,0 @@ -XEROX COMPAREDIRECTORIES 2 4 1 COMPAREDIRECTORIES 1 4 By: Larry Masinter and Ron Kaplan This document edited on December 2, 1987 December 28, 1998 (Ron Kaplan) April 7, 2018 (Ron Kaplan) Rewritten August 25, 2020 (Ron Kaplan) COMPAREDIRECTORIES compares the contents of two directories, identifying files according to their creation dates and lengths. It is called using the function (COMPAREDIRECTORIES DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATES OUTPUTFILE ALLVERSIONS) [Function] Compares the creation dates of files with matching names in the lists that CDFILES returns for DIR1 and DIR2. Collects or prints CDENTRIES for those files that meet the SELECT criteria. May also collect or print entries for relevant files that exist in DIR1 or DIR2 but not both. SELECT specifies which the match/mismatch criteria for filtering the output. If SELECT is or contains AFTER or >: select entries where file1 has a later date than file2 BEFORE or <: select entries where file1 has an earlier date than file2 SAMEDATE or =: select entries where file1 and file2 have the same date -*: exclude entries where file1 does not exist *-: exclude entries where file2 does not exist SELECT = NIL is equivalent to (< > -* *-). Excludes files with matching dates, a useful default for identifying files that may require further attention. SELECT = T is equivalent to (= < > -* *-). Includes all files for processing by other functions or later filtering by CDSUBSET (below). SELECT may also contain the token AUTHOR to indicate that authors should be provided in the printed output (see CDPRINT below). Unless USEDIRECTORYDATES, the FILECREATED date is used for the date comparison of Lisp source and compiled files, otherwise the file-system CREATIONDATE is used. If OUTPUTFILE=NIL, then a list of the form (Parameters . entries) is returned. Parameters is a list (DIR1 DIR2 SELECT DATE) that records the parameters of the comparison. Entries contains one entry for each of the file-comparisons that meets the SELECT criteria. Each entry is a CDENTRY record with fields (matchname info1 daterel info2 equiv) where matchname is the name.extension shared by the two files, and each file info is either NIL (for nonexistent files) or a CDINFO record with fields (fullfilename date length author type eol) type is SOURCE for Lisp source (filecreated) files, COMPILED for Lisp compiled files, otherwise the PRINTFILETYPE (TEXT, TEDIT...) or NIL. eol is CR, LF, CRLF, or NIL. When both files exist, the date relation is one of <, =, or >. Otherwise, the date relation is * if only one file exists. EQUIV is EQUIVALENT for files with different dates but exactly the same bytes, otherwise NIL. If OUTPUTFILE is not NIL, then it is a filename or open stream on which selected entries will be printed (T for the terminal) by CDPRINT. COMPAREDIRECTORIES sets the variable LASTCDENTRIES is set to the selected entries. This is used by the functions below if their CDENTRIES is NIL. (CDFILES DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) [Function] Returns a list of full filenames for files in directory DIR (NIL=T=the connected directory) that match the other file-name filtering criteria. Files are excluded if: Their name does not match a pattern in FILEPATTERNS (NIL = *). Dotted files are excluded unless FILEPATTERNS includes .* and files in subdirectories are excluded if the number of subdirectories exceeds DEPTH (below). Their extension is in the list EXTENSIONSTOAVOID (* excludes all extensions). They are not the highest version unless ALLVERSIONS=T. DEPTH controls the depth of subdirectory exploration. T means all levels, NIL means no subdirectories. Otherwise the maximum number of ">" characters below the starting DIR in the fullname of files. (CDFILES) produces all the newest, undotted files in the immediate connected directory. (CDPRINT CDENTRIES FILE PRINTAUTHOR) [Function] Prints CDENTRIES on FILE, with one line for each entry. The line for each entry is of the form FILE1 (AUTHOR) SIZE DATE relation DATE FILE2 (AUTHOR) SIZE For example ACE.;1 (Joe) 4035 2-May-1985 18:03:54 < 30-Sep-1985 11:14:48 ACE.;3 (Sam) 5096. The line for byte-equivalent files is prefixed with ==. If the files are equivalent except for a difference in end-of-line conventions, the equivalence prefix will indicate the convention for each file (C for CR, L, for LF, 2 for CRLF). Thus C2 indicates that the files are equivalent except that file1 marks line ends with CR and file2 with CRLF. Note that because of the setting of LASTCDENTRIES, evaluating (CDPRINT) after COMPAREDIRECTORIES prints the results of the last comparision. For conciseness, authors are included only if PRINTAUTHOR or if AUTHOR is included in the SELECT parameter of CDENTRIES. Also, the redundant file-name hosts/directories are not printed. (CDMAP CDENTRIES FN) [Function] (CDSUBSET CDENTRIES FN) [Function] CDMAP applies FN to each CDENTRY in CDENTRIES. CDSUBSET applies FN and also returns the subset of CDENTRIES for which FN is non-NIL and preserves in the value the parameters of CDENTRIES. For convenience, at each invocation the variables MATCHNAME INFO1 DATEREL INFO2 and EQUIV are bound to the corresponding fields and can be used freely by FN. USEFUL UTILITIES (FIX-DIRECTORY-DATES FILES) [Function] For every file included in or specified by FILES, if it is a Lisp source or compiled whose directory creation date is more than 30 seconds later than its internal filecreated date (presumably because of copying), then its directory date is reset to match the internal date. FILES can be a list of file names or a pattern interpretable by FILDIR. Returns a list of files whose dates have been changed. (FIX-EQUIV-DATES CDENTRIES) [Function] If there is an entry in CDENTRIES whose files are EQUIVALENT but with different directory creation dates, the directory date of the file with the later date (presumably a copy) is reset to match the date of the earlier file. In the end all equivalent files will have the same (earliest) date. Returns a list of files whose dates have been changed. (COPY-MISSING-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with a source file but no target file has a matchname in MATCHNAMES, the source file is copied to the target directory. All target-absent files are copied if MATCNAMES is NIL. Source properties (including version number) are preserved in the target. (COPY-COMPARED-FILES CDENTRIES TARGET MATCHNAMES) [Function] Target is 1 or 2, indicating the direction of potential copies. If an entry with both source and target files has a matchname in MATCHNAMES, the source file is copied to a new version of the target file. All files are copied if MATCHNAMES is NIL. (COMPARE-ENTRY-SOURCE-FILES CDENTRY LISTSTREAM EXAMINE DW?) [Function] This is a simple wrapper for calling COMPARESOURCES if the CDENTRY files are Lisp source files. The function (CDENTRY MATCHNAME CDENTRIES is useful for extracting a particular entry, with CDENTRIES defaulting to LASTCDENTRIES. (COMPILED-ON-SAME-SOURCE CDENTRIES) [Function] Returns the subset of entries with Lisp compiled files (dfasl or lcom) that are compiled on the same source, according to SOURCE-FOR-COMPILED-P below. Presumably one should be removed to avoid confusion. (FIND-SOURCE-FILES CFILES SDIRS DFASLMARGIN) [Function] Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES and SFILES is list of files in SDIRS that CFILE was compiled on according to SOURCE-FOR-COMPILED-P. This suggests that at least one of SFILES should be copied to CFILE's location (or vice versa). (FIND-COMPILED-FILES SFILES CDIRS DFASLMARGIN) [Function] Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES and CFILES are files in CDIRS that are compiled on SFILE according to SOURCE-FOR-COMPILED-P. This suggests that at least one of CFILES should be copied to SFILE's location. (FIND-UNCOMPILED-FILES FILES DFASLMARGIN COMPILEXTS) [Function] Returns a list of elements each of which corresponds to a source file in FILES for which no appropriate compiled file can be found. An appropriate compiled file is a file in the same location with extension in COMPILEEXTS (defaulting to *COMPILED-EXTENSIONS*) that satisfies SOURCE-FOR-COMPILED-P. Each element is a list of the form (sourcefile . cfiles) cfiles contains compiled files that were compiled on a different version of sourcefile, NIL if no such files exist. Each cfile item is a pair (cfile timediff) where timediff is the time difference (in minutes) between the creation date of the compiled-file's source and the creation date of sourcefile (positive if the cfile was compiled later, as should be the case). FILES can be an explicit list of files, or a file specification interpretable by FILDIR; in that case only the newest source-file versions are processed. (FIND-UNSOURCED-FILES CFILES DFASLMARGIN COMPILEXTS) [Function] Returns the subset of the compiled files specified by CFILES for which a corresponding source file according to SOURCE-FOR-COMPILED-P cannot be found in the same directory. CFILES can be a list of files or a pattern that FILDIR can interpret. COMPILEEXTS can be one or more explicit compile-file extensions, defaulting to *COMPILED-EXTENSIONS*. (SOURCE-FOR-COMPILED-P SOURCE COMPILED DFASLMARGIN) [Function] Returns T if it can confirm that Lisp COMPILED file was compiled on Lisp SOURCE file. SOURCE and COMPILED can be provided as CREATED-AS values, to avoid repetitive computation. This compares the information in the filecreated expressions, original file names and original dates, and not the current directory names and dates. It appears that the times in DFASL files may differ from the filecreated source dates by a few minutes. The DFASLMARGIN can be provided to loosen up the date matching criterion. DFASLMARGIN is a pair (max min) and a DFASL COMPILED is deemed to be compiled on SOURCE if the compiled's source date is no more than max and no less than min minutes after the source date. A negative min allows for the possibility that the compiled-source date is earlier than the candidate source date. DFASLMARGIN defaults to (20 0). A single positive number x is coerced to (x 0). A single negative number is coerced to (-x x) (compiled file is no more than x minutes later or earlier). T is infinity in either direction. Examples: (T 0): COMPILED compiled on source later than SOURCE (0 T): COMPILED compiled on source earlier than SOURCE (odd) 12: COMPILED compiled on source later than SOURCE by no more than 12 minutes -12: COMPILED compiled on source 12 minutes before or after SOURCE (FIND-MULTICOMPILED-FILES FILES SHOWINFO) [Function] Returns a list of files in FILES that have more than one type of compiled file (e.g. LCOM and DFASL). FILES is interpretable by FILDIR. If SHOWINFO, then the value contains a list for each file of the form ÿÿï!ÿ(rootname loaded-version . CREATED-AS information for each compile-type) Otherwise just the rootname of the source is returns. (CREATED-AS FILE) [Function] If FILE is a Lisp source or compiled file, returns a record of its original filename and filecreated dates, and for compiled files, also the original compiled-on name and date. The return for a source file is a pair (sfullname sfilecreateddate) The return for a compiled file is a quadruple (cfullname cfilecreated sfullname sfilecreateddate) where sfullname and sourcefilecreated are extracted from the file's compiled-on information. The return is (fullname NIL) for a non-Lisp file. (EOLTYPE FILE) [Function] Returns the EOLTYPE of FILE (CR, LF, CRLF) if the type is unmistakable: contains at least one instance of one type and no instances of any others. (BINCOMP FILE1 FILE2 EOLDIFFOK) [Function] Returns T if FILE1 and FILE2 are byte-identical. If EOLDIFFOK and FILE1 and FILE2 differ only in their eol conventions, the value is a list of the form (EOL1 EOL2), e.g. (CR CRLF). Otherwise the value is NIL. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4ÈÈ40ÈÈ4 ÈÈ4ÈÈ.4@È4ÈÈ.È.ŠŠ8.ŠŠ8JÈÈ PAGEHEADING RUNNINGHEAD. -GACHA -TERMINALMODERN -MODERN -TERMINAL -MODERN MODERN -MODERNLOGOMODERN -    HRULE.GETFNMODERN - - HRULE.GETFNMODERN - - HRULE.GETFNMODERN -   HRULE.GETFNMODERN  - HRULE.GETFNMODERN #!(ž - -\ -fJLL44›Š€£6)˜.©Ú‹”K¦ÙN7ÉX1_A P]Ž»'%Z.“,]>I?û= ä0Ì:<ûAOA[@HÑ:BRJ6ÐK7Ù".9“-Õ  - /Êzº \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.TEDIT.~8~ b/lispusers/COMPAREDIRECTORIES.TEDIT.~8~ deleted file mode 100644 index ca45d6e2281085055ee4dc5f3ad79ef28b1ccf75..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4442 zcmeHK!EW0|5Tz6+P3p2h+o0&7hk<$s707}l%eL&sMHq>)*-)fPQi)T;hqbh_iAbbC z(sk5N$R8B_j$V4{HOGEZXO^T)$%%siMNT0QYB@V^IQ!*!wF>h)Dy>*%)D zb}d`i9JwLOO}-MihEDydjJLt!#VU=O z>!xd4ok82xE%Pl|!!Vf6SjZ!Y&pAF|zJ44*FoyUtfRPvSVH|`Wk18-c=fjtte+F>? z5$E8IflVgD6`^Bqf-0m{wt849a4ot!ht~7`u5M_KYgsUG zG(&g#^xRQh4QSC(`;cX-=pienOAi^MBSyrCpyfI*z+ZV0Rl-kBR0UZdgBPP_ zc;r7o$ViQtCaOB{a5=HdX1lo(2MY}xOd7T(F-C4Is~dH zz6gCZp3X(>sE8FIK!1+EeiUX-QiIi|9%XoBc$kuxbY4<@e~xOv7LKUBvSN8>eh~7JsBlisDV%!vHy#oqT0qjN zFhYG{*5RcWaa7`DE;9A`B_63N=Nl(IGZQQcNn@&bZqBB}K_WIH0NJ>h2whjPe|V;> z2yh6&8TWaJ3C$O^48p1GSOdGQ5$}pRa1SlJ3~)>mILQkqwP3g8J>{-w5H_7nxU9Cd z>W_8BVZP5N6IO=f#zv3LH(FazZ|&7K_qLiR@aPd7Z`L*(J`?u(UcI^3Y@L7rZz|6G zlue?S^RoOLiQ!OsRKhbb8FLA_)6`f&rAFJ*&Z<>ra&?Zq4e-! z2_-S|hA8`VtdLJKQ6iXnkrN?$$D0DBQ|)u&PR zs|E&-Nqk+)&@J8UTA--5`b2M+!Esfa#v!48fO;8}8q{FB-hiFm20keQlf|=D!?K<_ zp!_mWJJ8ll9I0BT4DCbJPIsIEy;O{D45XXSbVq-Jqt@zn0mm|aTKkxSE1vtd<)Q(* zQS4Ht^%`{5o^HGV{0`8(ws0I9x|s%WZT+cc4HEdkM32RucGOqJEC*XV7#J#k6b!4c zEuNlh`oWC!MmzU-cg?BobTO6ogJ*xZIjtA#)1 z#8Wxc)DF^^5S2c-FX;6H)5HxjA-2_oon{lZ8hNaXy)S^GYUr}N4b81>*sj%*@MT1P zP+8IcQyD*%5tL8e2w7|XkKI@(b8PfouXj=Ha!Vp(1PN8LknS+5|^S>kk$`v{0~p{Ky$lh;T<6bIT?_C zKQ53oA#zW|QN%*roWd2ks1@`T0D`GlNJ= z+%PS26|W|PFy^EFMVPyEOI?K~mR#3qbIFqV-lrV`pVER}L_NF|E?71EnHj|2c7*vd zvt(iaB||RBf>2=2AgL=J(u36)`>O^)L3U6&jY%HKv`I+%BM(_kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;261 60872 changes to%: (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS CDPRINT.LINE CDPRINT) previous date%: "12-Oct-2020 20:22:51" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;254) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 12-Oct-2020 23:48 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 12-Oct-2020 23:48 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (OR (FILENAMEFIELD FP 'NAME) '*] [SETQ FPEXT (U-CASE (OR (FILENAMEFIELD FP 'EXTENSION) '*] (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (OR (EQ DEPTH T) (EQ FP '*)) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 12-Oct-2020 21:56 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 12-Oct-2020 21:47 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES))) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (NCHARS (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY (FETCH FULLNAME OF INFO1))) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1) ) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1) (* ; "Edited 12-Oct-2020 21:47 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY)) EQUIV) (SETQ EQUIV (FETCH EQUIV OF ENTRY)) (PRINTOUT STREAM (SELECTQ EQUIV (T "==") (NIL " ") (IF (EQUAL EQUIV '(CR LF)) THEN "CL" ELSEIF (EQUAL EQUIV '(LF CR)) THEN "LC" ELSEIF (EQ 'CRLF (CAR EQUIV)) THEN (CONCAT "2" (CL:IF (EQ 'CR (CADR EQUIV)) 'L 'C)) ELSE (* ;; "CADR must be CRLF") (CONCAT (CL:IF (EQ 'CR (CAR EQUIV)) 'L 'C) "2"))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY (FETCH FULLNAME OF INFO1)) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY (FETCH FULLNAME OF INFO2)) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK) (* ; "Edited 12-Oct-2020 17:14 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (LET ((EOL1 (EOLTYPE FILE1)) (EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 21-Sep-2020 16:56 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (IGREATERP DFASLMARGIN 0) THEN (LIST DFASLMARGIN 0) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES) (* ; "Edited 6-Sep-2020 15:08 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) (ITIMES 120 ONESECOND)) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1680 15255 (COMPAREDIRECTORIES 1690 . 9637) (CDFILES 9639 . 13357) ( COMPAREDIRECTORIES.INFOS 13359 . 14818) (MATCHNAME 14820 . 15253)) (15256 22558 (CDPRINT 15266 . 20045 ) (CDPRINT.LINE 20047 . 22556)) (22559 24311 (CDMAP 22569 . 23265) (CDENTRY 23267 . 23435) (CDSUBSET 23437 . 24309)) (24312 29482 (BINCOMP 24322 . 28250) (EOLTYPE 28252 . 29480)) (29691 42898 ( FIND-UNCOMPILED-FILES 29701 . 33344) (FIND-UNSOURCED-FILES 33346 . 36155) (FIND-SOURCE-FILES 36157 . 37861) (FIND-COMPILED-FILES 37863 . 39941) (FIND-UNLOADED-FILES 39943 . 40687) (FIND-LOADED-FILES 40689 . 41243) (FIND-MULTICOMPILED-FILES 41245 . 42896)) (42899 50931 (CREATED-AS 42909 . 47706) ( SOURCE-FOR-COMPILED-P 47708 . 50236) (COMPILE-SOURCE-DATE-DIFF 50238 . 50929)) (50932 59939 ( FIX-DIRECTORY-DATES 50942 . 52938) (FIX-EQUIV-DATES 52940 . 54200) (COPY-COMPARED-FILES 54202 . 56326) (COPY-MISSING-FILES 56328 . 58167) (COMPILED-ON-SAME-SOURCE 58169 . 59937)) (60094 60705 ( COMPARE-ENTRY-SOURCE-FILES 60104 . 60703))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.~268~ b/lispusers/COMPAREDIRECTORIES.~268~ deleted file mode 100644 index ffcabcd7..00000000 --- a/lispusers/COMPAREDIRECTORIES.~268~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "13-Oct-2020 22:06:40"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;268 62358 changes to%: (FNS CDFILES BINCOMP COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS CDPRINT CDPRINT.LINE) (RECORDS CDINFO) previous date%: "12-Oct-2020 20:22:51" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;254) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 13-Oct-2020 08:43 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2)))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 13-Oct-2020 22:06 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) (SETQ FPEXT NIL) ELSE (SETQ FPEXT '*))) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (OR (EQ DEPTH T) (STRPOS "*>" FP)) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (CL:UNLESS FPNAME (SETQ FPNAME '*)) (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 21-Sep-2020 16:56 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (IGREATERP DFASLMARGIN 0) THEN (LIST DFASLMARGIN 0) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES) (* ; "Edited 6-Sep-2020 15:08 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) (ITIMES 120 ONESECOND)) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1751 16493 (COMPAREDIRECTORIES 1761 . 9870) (CDFILES 9872 . 14539) ( COMPAREDIRECTORIES.INFOS 14541 . 16056) (MATCHNAME 16058 . 16491)) (16494 23679 (CDPRINT 16504 . 21304 ) (CDPRINT.LINE 21306 . 23677)) (23680 25432 (CDMAP 23690 . 24386) (CDENTRY 24388 . 24556) (CDSUBSET 24558 . 25430)) (25433 30964 (BINCOMP 25443 . 29732) (EOLTYPE 29734 . 30962)) (31177 44384 ( FIND-UNCOMPILED-FILES 31187 . 34830) (FIND-UNSOURCED-FILES 34832 . 37641) (FIND-SOURCE-FILES 37643 . 39347) (FIND-COMPILED-FILES 39349 . 41427) (FIND-UNLOADED-FILES 41429 . 42173) (FIND-LOADED-FILES 42175 . 42729) (FIND-MULTICOMPILED-FILES 42731 . 44382)) (44385 52417 (CREATED-AS 44395 . 49192) ( SOURCE-FOR-COMPILED-P 49194 . 51722) (COMPILE-SOURCE-DATE-DIFF 51724 . 52415)) (52418 61425 ( FIX-DIRECTORY-DATES 52428 . 54424) (FIX-EQUIV-DATES 54426 . 55686) (COPY-COMPARED-FILES 55688 . 57812) (COPY-MISSING-FILES 57814 . 59653) (COMPILED-ON-SAME-SOURCE 59655 . 61423)) (61580 62191 ( COMPARE-ENTRY-SOURCE-FILES 61590 . 62189))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.~269~ b/lispusers/COMPAREDIRECTORIES.~269~ deleted file mode 100644 index 1e54129c..00000000 --- a/lispusers/COMPAREDIRECTORIES.~269~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "14-Oct-2020 21:18:16"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;269 62551 changes to%: (FNS COMPAREDIRECTORIES CDFILES) previous date%: "13-Oct-2020 22:06:40" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;268) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 14-Oct-2020 21:15 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2)))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 14-Oct-2020 21:17 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) (SETQ FPEXT NIL) ELSE (SETQ FPNAME '*) (SETQ FPEXT '*))) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 21-Sep-2020 16:56 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (IGREATERP DFASLMARGIN 0) THEN (LIST DFASLMARGIN 0) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES) (* ; "Edited 6-Sep-2020 15:08 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) (ITIMES 120 ONESECOND)) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1634 16686 (COMPAREDIRECTORIES 1644 . 10134) (CDFILES 10136 . 14732) ( COMPAREDIRECTORIES.INFOS 14734 . 16249) (MATCHNAME 16251 . 16684)) (16687 23872 (CDPRINT 16697 . 21497 ) (CDPRINT.LINE 21499 . 23870)) (23873 25625 (CDMAP 23883 . 24579) (CDENTRY 24581 . 24749) (CDSUBSET 24751 . 25623)) (25626 31157 (BINCOMP 25636 . 29925) (EOLTYPE 29927 . 31155)) (31370 44577 ( FIND-UNCOMPILED-FILES 31380 . 35023) (FIND-UNSOURCED-FILES 35025 . 37834) (FIND-SOURCE-FILES 37836 . 39540) (FIND-COMPILED-FILES 39542 . 41620) (FIND-UNLOADED-FILES 41622 . 42366) (FIND-LOADED-FILES 42368 . 42922) (FIND-MULTICOMPILED-FILES 42924 . 44575)) (44578 52610 (CREATED-AS 44588 . 49385) ( SOURCE-FOR-COMPILED-P 49387 . 51915) (COMPILE-SOURCE-DATE-DIFF 51917 . 52608)) (52611 61618 ( FIX-DIRECTORY-DATES 52621 . 54617) (FIX-EQUIV-DATES 54619 . 55879) (COPY-COMPARED-FILES 55881 . 58005) (COPY-MISSING-FILES 58007 . 59846) (COMPILED-ON-SAME-SOURCE 59848 . 61616)) (61773 62384 ( COMPARE-ENTRY-SOURCE-FILES 61783 . 62382))))) STOP \ No newline at end of file From 3e13151e591d6b976dd1866d303d5f4f88db8957 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sun, 21 Feb 2021 21:15:35 -0800 Subject: [PATCH 16/31] Cleaning out old versions of MACINTERFACE --- lispusers/MACINTERFACE.LCOM.~46~ | Bin 5733 -> 0 bytes lispusers/MACINTERFACE.~28~ | 1 - lispusers/MACINTERFACE.~30~ | 1 - lispusers/MACINTERFACE.~31~ | 1 - lispusers/MACINTERFACE.~52~ | 1 - 5 files changed, 4 deletions(-) delete mode 100644 lispusers/MACINTERFACE.LCOM.~46~ delete mode 100644 lispusers/MACINTERFACE.~28~ delete mode 100644 lispusers/MACINTERFACE.~30~ delete mode 100644 lispusers/MACINTERFACE.~31~ delete mode 100644 lispusers/MACINTERFACE.~52~ diff --git a/lispusers/MACINTERFACE.LCOM.~46~ b/lispusers/MACINTERFACE.LCOM.~46~ deleted file mode 100644 index e1341dda1a5eeb3e41822055a34849870653ac8a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5733 zcmb_g&2QV-5tr26WVfwSdrw7L1Ooxv(#1*;Dan?VMPf>%EL!|BNyT=NLluj$WXqx} z$(sa4FTvh>S`=+hDf)3M()|Dy*pHmkUKfkx4`|P8^w48FZyqU8vK3^37%)XX&YL&y zH#5JPM?q2RnyF^%nyzLwvu?pPN0k*%uIegeG}BWZU32XWT(jj`Q{J2zTuBRTUJYk> zssb4(XXVp_tdy7XAeJh{az$LrfRNb_j!$}hzXQPlh0?!L+~%*}ZH@fl=*Cg|q~9Lg z(1ZPU|HiT3>H7}~xzde(Z*;OB41KyeB}qfBkvVm_rsl4fq!m=Po|R9AxLzLDD_8Pj zr68gHJ41i6qJRHnIC{GRgJ9h44Gy4(78tY);5tx0?f1cbFbYn`5Vt;;%VnU`9;40k zyDCVPl9YM5t-qqJf>Ni2iysHk#wxOCAdE+0cJ z=c-=I=GfVYouitvp(>W6ZGw&P+09KhfKWZGcSI45vTi9L z=8McN3ZTE(z)dKYp{7?TeGy;@YL;1(JwR`{o}+HJWF03lk&tAvwB-^Tarca>rDwwz zh+P@8wq@2l%`%}Jg%_+X^ct*|K$nfGB0~Y~k!uX7EGmMvJP1*A7V*Zu3CI4yX%AM4c&`jU7T_5T4ICG zKR?vZ9_bGcb(H%vCDKxN2^HX;Y0J;QI5f^484nK)rs&^`6@7VVo;@-j9-2(w& zX%OK(zR8Dv-_*Clk!(!NXzE<-hg|G;O=F9XyieAq(e99edrQ^7aBF_ce|k&u-(q#~ zPU_=p8%OdFuACdb%!kqK#p3z029hLRG@2(CR(CKw)*+UlVtF0hhHSGpWzrXVMqDf7 z3#+9orU#|9xr$mWppwvWg*9|Ex_Spaj%Ake)Ag_!#CVY~t}d#Hl89COf?6rAicz#- zzavd!Qj~b`MDdyrqbht3Q=qBtRV~?J)n}RnJWkygMenqzhwV#@uo&wmyFFg#5&~5Z zP9n2C!-SDItz>0I$*Q|*Evo8l!&Z&5z{G1FTF5iT(>~*SEC)eE4?r zEn06md8yB7-y{JVq%vSGZMDD9KS^U0-u`Us=&PSU{)h3C&maF6`=eM_07bs4>bksD zDuJT8hUU6}h{?9CBasS4G3?KvJSmNl^$}_qGFjJ@?Hw8WY%#{`xQQzap?JDcAHYfz zMpY>cj(K=US%eM3je35Br6ECy!b$>dm@d@%HBhNknCtYg{)MHS)S zAuHMx9#%9j7q0=_nmW3Mznh$a&^9H3#*sAy{~+0>2b*jgB;}c>U(P&j$DVK#*okoU z*g8yl7Uc7gx>ctG7<I+9ELuEfl#uN22z=%&=iUR z0XYZ-vAwe$jPNjYREHfe=^&LB99!PrKKB9y;b(CDI%L%QV}Cek_eYr(5ZDwD>ZUt& z$Mi1j@u!Xon@607O^oKzQBH`*W4tH9d|g>VQNF4+xNy}NuTR){dNiA*tC(Rk?wwF! zv{*V*^}B66O%CBM{*QuVAC3mWy#d_o4LZR+*dO}saWEtV!o4%Lh!`ZqjAl(AcVSe0NP!65S+qs z@SYFjt`Em;{Jg-Sd4~r2z45s3Lwh`K?|1QALI_(Y@JEB6j%gyQsp7|n-khqrDepjU z3~l^YaW5Dijc|_X`<)TAff>_l_o3t8?G1Y4UNFFyZnu5HK6XUwuu0(e(8OUTO(?No zi<1U~px`lB!Sl0?%rF}>6oCsSrL~%Y-g4x<9CiQf$b>-RVRYh=`q1}}{lO`7$O0|5 z>&E<&QOvuH3d!;Xb4j35nTh7<;);Lg^xy#ZzIgGpQr)an6t&vg+*F+`SCpks0#iNi zpndWJ9lQ=jNTQ{a!Z}fq&Y1o^@bCNklrjr;6QvKD%R@EPH5rd!O(O^OMq}n`rW1m@ zJnDjWXU0y<7fy%N2?%k1jF#ZRfLkaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;28 8463 changes to%: (FNS MACWINDOW) previous date%: "18-May-2020 17:27:13" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;27) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [(FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW) (FNS MACINT\TEDIT.BUTTONEVENTFN MACINT\SEDIT-BUTTONEVENTFN MACINT-ADD-EXEC MACINT-DEBUGGER-BUTTON-EVENT MACINT-\ITEM.WINDOW.BUTTON.HANDLER MACINT-SNAPW) (INITVARS (MACINTERFACECORNERMARGIN 25)) (P (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN)) (P (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN)) (P (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC)) (P (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT)) (P (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER)) (P (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (CL:WHEN (MOUSESTATE (ONLY LEFT)) (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (INTITLEBAR WINDOW) THEN (MOVEW WINDOW) T)))]) (MACWINDOW [LAMBDA (WINDOW) (* ; "Edited 18-May-2020 20:11 by rmk:") (* ; "Edited 10-May-2020 14:20 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")  (* ; "Edited 3-May-2020 21:17 by rmk:") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION MACWINDOW.BUTTONEVENTFN))) WINDOW]) ) (DEFINEQ (MACINT\TEDIT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (CL:WHEN (LISTP WINDOW) (SETQ WINDOW (CAR WINDOW))) (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\TEDIT.BUTTONEVENTFN WINDOW]) (MACINT\SEDIT-BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\SEDIT-BUTTONEVENTFN WINDOW]) (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 10-May-2020 03:31 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-DEBUGGER-BUTTON-EVENT [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-DEBUGGER-BUTTON-EVENT WINDOW]) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER [LAMBDA (WINDOW) (* ; "Edited 16-May-2020 22:35 by rmk:") (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-\ITEM.WINDOW.BUTTON.HANDLER WINDOW]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 18-May-2020 17:20 by rmk:") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN) (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN) (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC) (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT) (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER) (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1747 5706 (INTITLEBAR 1757 . 1977) (INCORNER 1979 . 3394) (MACWINDOW.BUTTONEVENTFN 3396 . 5018) (MACWINDOW 5020 . 5704)) (5707 7601 (MACINT\TEDIT.BUTTONEVENTFN 5717 . 6008) ( MACINT\SEDIT-BUTTONEVENTFN 6010 . 6237) (MACINT-ADD-EXEC 6239 . 6663) (MACINT-DEBUGGER-BUTTON-EVENT 6665 . 6896) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER 6898 . 7250) (MACINT-SNAPW 7252 . 7599))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.~30~ b/lispusers/MACINTERFACE.~30~ deleted file mode 100644 index 8e3318e0..00000000 --- a/lispusers/MACINTERFACE.~30~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-May-2020 08:54:49"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;30 9079 changes to%: (FNS MACWINDOW.BUTTONEVENTFN MACWINDOW) previous date%: "18-May-2020 17:27:13" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;27) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [(FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW) (FNS MACINT\TEDIT.BUTTONEVENTFN MACINT\SEDIT-BUTTONEVENTFN MACINT-ADD-EXEC MACINT-DEBUGGER-BUTTON-EVENT MACINT-\ITEM.WINDOW.BUTTON.HANDLER MACINT-SNAPW) (INITVARS (MACINTERFACECORNERMARGIN 25)) (P (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN)) (P (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN)) (P (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC)) (P (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT)) (P (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER)) (P (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (MOUSESTATE (ONLY LEFT)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (INTITLEBAR WINDOW) THEN (MOVEW WINDOW) T ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW))) ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW]) (MACWINDOW [LAMBDA (WINDOW) (* ; "Edited 18-May-2020 20:11 by rmk:") (* ; "Edited 10-May-2020 14:20 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")  (* ; "Edited 3-May-2020 21:17 by rmk:") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION MACWINDOW.BUTTONEVENTFN))) WINDOW]) ) (DEFINEQ (MACINT\TEDIT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (CL:WHEN (LISTP WINDOW) (SETQ WINDOW (CAR WINDOW))) (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\TEDIT.BUTTONEVENTFN WINDOW]) (MACINT\SEDIT-BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\SEDIT-BUTTONEVENTFN WINDOW]) (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 10-May-2020 03:31 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-DEBUGGER-BUTTON-EVENT [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-DEBUGGER-BUTTON-EVENT WINDOW]) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER [LAMBDA (WINDOW) (* ; "Edited 16-May-2020 22:35 by rmk:") (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-\ITEM.WINDOW.BUTTON.HANDLER WINDOW]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 18-May-2020 17:20 by rmk:") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN) (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN) (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC) (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT) (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER) (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1771 6322 (INTITLEBAR 1781 . 2001) (INCORNER 2003 . 3418) (MACWINDOW.BUTTONEVENTFN 3420 . 5634) (MACWINDOW 5636 . 6320)) (6323 8217 (MACINT\TEDIT.BUTTONEVENTFN 6333 . 6624) ( MACINT\SEDIT-BUTTONEVENTFN 6626 . 6853) (MACINT-ADD-EXEC 6855 . 7279) (MACINT-DEBUGGER-BUTTON-EVENT 7281 . 7512) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER 7514 . 7866) (MACINT-SNAPW 7868 . 8215))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.~31~ b/lispusers/MACINTERFACE.~31~ deleted file mode 100644 index dd681bfe..00000000 --- a/lispusers/MACINTERFACE.~31~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-May-2020 18:02:27"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;31 11583 changes to%: (VARS MACINTERFACECOMS) (FNS MACWINDOW.BUTTONEVENTFN.ANYWHERE MACWINDOW) previous date%: "23-May-2020 08:54:49" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;30) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [(FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE MACWINDOW) (FNS MACINT\TEDIT.BUTTONEVENTFN MACINT\SEDIT-BUTTONEVENTFN MACINT-ADD-EXEC MACINT-DEBUGGER-BUTTON-EVENT MACINT-\ITEM.WINDOW.BUTTON.HANDLER MACINT-SNAPW) (INITVARS (MACINTERFACECORNERMARGIN 25)) (P (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN)) (P (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN)) (P (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC)) (P (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT)) (P (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER)) (P (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (MOUSESTATE (ONLY LEFT)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (INTITLEBAR WINDOW) THEN (MOVEW WINDOW) T ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW))) ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 28-May-2020 18:00 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (IF (MOUSESTATE (ONLY LEFT)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSE (MOVEW WINDOW) T)) ELSEIF (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) THEN (APPLY* (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) WINDOW]) (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 28-May-2020 17:58 by rmk:") (* ; "Edited 18-May-2020 20:11 by rmk:") (* ; "Edited 10-May-2020 14:20 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")  (* ; "Edited 3-May-2020 21:17 by rmk:") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) ) (DEFINEQ (MACINT\TEDIT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (CL:WHEN (LISTP WINDOW) (SETQ WINDOW (CAR WINDOW))) (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\TEDIT.BUTTONEVENTFN WINDOW]) (MACINT\SEDIT-BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG\SEDIT-BUTTONEVENTFN WINDOW]) (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 10-May-2020 03:31 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-DEBUGGER-BUTTON-EVENT [LAMBDA (WINDOW) (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-DEBUGGER-BUTTON-EVENT WINDOW]) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER [LAMBDA (WINDOW) (* ; "Edited 16-May-2020 22:35 by rmk:") (* ; "Edited 10-May-2020 03:31 by rmk:") (OR (MACWINDOW.BUTTONEVENTFN WINDOW) (MACORIG-\ITEM.WINDOW.BUTTON.HANDLER WINDOW]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 18-May-2020 17:20 by rmk:") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (MOVD? '\TEDIT.BUTTONEVENTFN 'MACORIG\TEDIT.BUTTONEVENTFN) (MOVD 'MACINT\TEDIT.BUTTONEVENTFN '\TEDIT.BUTTONEVENTFN) (MOVD? 'SEDIT::BUTTONEVENTFN 'MACORIG\SEDIT-BUTTONEVENTFN) (MOVD 'MACINT\SEDIT-BUTTONEVENTFN 'SEDIT::BUTTONEVENTFN) (MOVD? 'ADD-EXEC 'MACORIG-ADD-EXEC) (MOVD 'MACINT-ADD-EXEC 'ADD-EXEC) (MOVD? 'DBG::DEBUGGER-BUTTON-EVENT 'MACORIG-DEBUGGER-BUTTON-EVENT) (MOVD 'MACINT-DEBUGGER-BUTTON-EVENT 'DBG::DEBUGGER-BUTTON-EVENT) (MOVD? '\ITEM.WINDOW.BUTTON.HANDLER 'MACORIG-\ITEM.WINDOW.BUTTON.HANDLER) (MOVD 'MACINT-\ITEM.WINDOW.BUTTON.HANDLER '\ITEM.WINDOW.BUTTON.HANDLER) (MOVD? 'SNAPW 'MACORIG-SNAPW) (MOVD 'MACINT-SNAPW 'SNAPW) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1857 8826 (INTITLEBAR 1867 . 2087) (INCORNER 2089 . 3504) (MACWINDOW.BUTTONEVENTFN 3506 . 5720) (MACWINDOW.BUTTONEVENTFN.ANYWHERE 5722 . 7859) (MACWINDOW 7861 . 8824)) (8827 10721 ( MACINT\TEDIT.BUTTONEVENTFN 8837 . 9128) (MACINT\SEDIT-BUTTONEVENTFN 9130 . 9357) (MACINT-ADD-EXEC 9359 . 9783) (MACINT-DEBUGGER-BUTTON-EVENT 9785 . 10016) (MACINT-\ITEM.WINDOW.BUTTON.HANDLER 10018 . 10370 ) (MACINT-SNAPW 10372 . 10719))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.~52~ b/lispusers/MACINTERFACE.~52~ deleted file mode 100644 index 6b135c9b..00000000 --- a/lispusers/MACINTERFACE.~52~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Aug-2020 15:48:17"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;52 14335 changes to%: (VARS MACINTERFACECOMS) previous date%: " 8-Aug-2020 08:01:06" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;51) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP MACWINDOW.UNSETUP) (INITVARS (MACINTERFACECORNERMARGIN 25))) (* ;; "Internals") [COMS (FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the write circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (* ;; "Internals") (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (OR ANYWHERE (INTITLEBAR WINDOW)) THEN (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN NIL T]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:58 by rmk:") (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3345 6723 (MACWINDOW 3355 . 3996) (MACWINDOW.SETUP 3998 . 5914) (MACWINDOW.UNSETUP 5916 . 6721)) (6792 11103 (INTITLEBAR 6802 . 7022) (INCORNER 7024 . 8439) (MACWINDOW.BUTTONEVENTFN 8441 . 10850) (MACWINDOW.BUTTONEVENTFN.ANYWHERE 10852 . 11101)) (11161 12138 (MACINT-ADD-EXEC 11171 . 11595) (MACINT-SNAPW 11597 . 12136)) (12139 13098 (TEDIT.MACINTERFACE 12149 . 12767) (TEDIT.SELECTALL 12769 . 13096))))) STOP \ No newline at end of file From 217d5a17d221dc71a10caf1f94ad070235f900c7 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 22 Feb 2021 12:48:51 -0800 Subject: [PATCH 17/31] WHEELSCROLL: Added keyactions for LEFT/RIGHT --- lispusers/WHEELSCROLL | 2 +- lispusers/WHEELSCROLL.LCOM | Bin 3526 -> 4030 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL index baf31632..db277f2a 100644 --- a/lispusers/WHEELSCROLL +++ b/lispusers/WHEELSCROLL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Feb-2021 09:39:06"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42 6734 changes to%: (VARS WHEELSCROLLCOMS) (FNS WHEELSCROLL) previous date%: "20-Feb-2021 17:34:35" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;39) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) (INITVARS (WHEELSCROLLDELTA 20) (WHEELSCROLLSETTLETIME 50) (\WHEELSCROLLINPROGRESS NIL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:") (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)") (* ;; "") (CL:WHEN (MOUSESTATE UP) (* ;  "Ignore interrupt if a button is down") [LET ((W (WHICHW))) (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within  the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME))) (CL:WHEN W (* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ") (IF (WINDOWPROP W 'SCROLLFN) THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE) (CL:IF (EQ DIRECTION 'VERTICAL) `(WHEELSCROLL.DOIT ,(KWOTE W) 0 ,DELTA) `(WHEELSCROLL.DOIT ,(KWOTE W) ,DELTA 0))] ELSEIF (EQ DIRECTION 'VERTICAL) THEN (* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.") (CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR) (\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA)) (GETMOUSESTATE)) ELSEIF (EQ DIRECTION 'HORIZONTAL) THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR) (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX) LASTMOUSEY) (GETMOUSESTATE))))])]) (WHEELSCROLL.DOIT [LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:") (* ;; "This does the actual wheel scrolling, runing in the mouse process.") (* ;; "There have been instances where the window gets garbled as the wheel moves. The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.") (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.") (CL:UNLESS \WHEELSCROLLINPROGRESS (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I) (CADR I) (CADDR I)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) ) (RPAQ? WHEELSCROLLDELTA 20) (RPAQ? WHEELSCROLLSETTLETIME 50) (RPAQ? \WHEELSCROLLINPROGRESS NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1187 6142 (ENABLEWHEELSCROLL 1197 . 1622) (WHEELSCROLL 1624 . 4160) (WHEELSCROLL.DOIT 4162 . 4798) (INSTALL-WHEELSCROLL 4800 . 5863) (LISPINTERRUPTS.WHEELSCROLL 5865 . 6140))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 09:47:46"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;43 7259 changes to%: (VARS WHEELSCROLLCOMS) (FNS ENABLEWHEELSCROLL) previous date%: "21-Feb-2021 09:39:06" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T) (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA) T)) (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) (INITVARS (WHEELSCROLLDELTA 20) (WHEELSCROLLSETTLETIME 50) (\WHEELSCROLLINPROGRESS NIL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 22-Feb-2021 09:47 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] [KEYACTION 'PAD4 '((522 522) . IGNORE] [KEYACTION 'PAD5 '((523 523) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE)) (KEYACTION 'PAD4 '(IGNORE . IGNORE)) (KEYACTION 'PAD5 '(IGNORE . IGNORE]) (WHEELSCROLL [LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:") (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)") (* ;; "") (CL:WHEN (MOUSESTATE UP) (* ;  "Ignore interrupt if a button is down") [LET ((W (WHICHW))) (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within  the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME))) (CL:WHEN W (* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ") (IF (WINDOWPROP W 'SCROLLFN) THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE) (CL:IF (EQ DIRECTION 'VERTICAL) `(WHEELSCROLL.DOIT ,(KWOTE W) 0 ,DELTA) `(WHEELSCROLL.DOIT ,(KWOTE W) ,DELTA 0))] ELSEIF (EQ DIRECTION 'VERTICAL) THEN (* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.") (CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR) (\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA)) (GETMOUSESTATE)) ELSEIF (EQ DIRECTION 'HORIZONTAL) THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR) (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX) LASTMOUSEY) (GETMOUSESTATE))))])]) (WHEELSCROLL.DOIT [LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:") (* ;; "This does the actual wheel scrolling, runing in the mouse process.") (* ;; "There have been instances where the window gets garbled as the wheel moves. The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.") (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.") (CL:UNLESS \WHEELSCROLLINPROGRESS (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I) (CADR I) (CADDR I)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T) (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA) T)) (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T)))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) ) (RPAQ? WHEELSCROLLDELTA 20) (RPAQ? WHEELSCROLLSETTLETIME 50) (RPAQ? \WHEELSCROLLINPROGRESS NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1432 6591 (ENABLEWHEELSCROLL 1442 . 2071) (WHEELSCROLL 2073 . 4609) (WHEELSCROLL.DOIT 4611 . 5247) (INSTALL-WHEELSCROLL 5249 . 6312) (LISPINTERRUPTS.WHEELSCROLL 6314 . 6589))))) STOP \ No newline at end of file diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM index 97812037d1609f8a787cad5ce2aae88c1e6bf51a..0c1e49d74d98f643e656d93938e457d8ddf8bc09 100644 GIT binary patch delta 640 zcmZXP(Q4E{6oxlhER}S$)C!{19wXQUX~;~HO|m!LX)@bg9WvWAR$CBU*crp{(EDW(HocNc{a?ZACG20Y#q>E-)DVFZI?L1u@qS;cqMYM+5bIo zYP?toAZAgDr^fTER`|SOK-05_T!PypmH6P=NdAF`*?Ytr=3*et_l2$Y5wVFc2E_o1Na@J}Ft)%t5Kxu-s zd(Wgk`rTDCX_XN-;#m}f<3x4Zx?J#Jyi=%BxCBDh0#*a&eowoz#ivjk>s#`AB!t|{ zN+l&YyRTFwV5G|Np(-l;WUbwX%5@uWfK%%}yGC5Ppg+xptaxK>7C1XnZF9NL%RRtv z*1#b6#{yhl${v!u{#fjDIgpCykgH5h4#1g!gCCYIZndeJPIvT94#CgXgMXtu(GA)V NH%V|pR&hj*{{qwJopJyG delta 302 zcmdlde@uFUpOB%hTWXT7k%5t+f`O%#v89#4#DpkDqlvrqCcam*?t!DWoKp zq^2nFDj`c4npl|_TA5fXY4U2gdHT3I2e~?ixVlVcVM<_CFf%tcnY^7*d-4lLd0_*D zX@=%j#wJ$ArV|T2n2aqar!XmTI599VFgk2foZQDGH~AEkypRBchMBQ~w`-)MbBL$E zpMr_SWPfIL3sYl-07n-i1!D^kZKz;m1mT;5xj;uKm|7@kc)I)f2e~TfDL@#S3MP{; zGK*|>V2R`q(gXqp4R;@ZCr6(!$Dm*Z-pQK04wJKZ6&QIZ2l7i!Ud*dC`5dn#koTPT J*ko<~$pHQnOSk|4 From 3351dddc79d8db0abbccbe2755d3a4a6b25e6f03 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 22 Feb 2021 13:00:49 -0800 Subject: [PATCH 18/31] FILEBROWSER: Build-in anticipation of MODERNIZE, eliminate line feeds --- library/FILEBROWSER | 227 +-------------------------------------- library/FILEBROWSER.LCOM | Bin 82485 -> 84471 bytes 2 files changed, 1 insertion(+), 226 deletions(-) diff --git a/library/FILEBROWSER b/library/FILEBROWSER index 5cc6690e..8ad956ae 100644 --- a/library/FILEBROWSER +++ b/library/FILEBROWSER @@ -1,226 +1 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "11-Sep-2001 09:26:14" |{DSK}medley3.5>library>FILEBROWSER.;8| 152759 |changes| |to:| (FNS FB.PROMPTFORINPUT) |previous| |date:| "20-Nov-2000 14:25:02" |{DSK}medley3.5>library>FILEBROWSER.;7|) ; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1999, 2000, 2001 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (FB.ICONSPEC '(#*(83 70)OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@LOOOOOOOOOOOOOOOOOONF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DCOOOHD@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DOOOOND@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@B@@@@@H@@@@@BF@@@LH@@@@@A@@@@A@@@@@@BF@@@LH@@@@@@OOOON@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LOOOOOOOOOOOOOOOOOONF@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@ NIL (5 5 73 40)))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (VARS FB.MENU.ITEMS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (RPAQ? FB.ICONSPEC '(#*(83 70)OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@LOOOOOOOOOOOOOOOOOONF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DCOOOHD@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DOOOOND@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@B@@@@@H@@@@@BF@@@LH@@@@@A@@@@A@@@@@@BF@@@LH@@@@@@OOOON@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LOOOOOOOOOOOOOOOOOONF@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@ NIL (5 5 73 40))) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQQ FB.MENU.ITEMS ((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. \ - (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion.") ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser.\ -You specify how many versions to keep." ))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)") (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| FB.FASTSEECOMMAND "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice"))) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files.\ -Your deletions are thus ignored." ))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB -(NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \; "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FILEBROWSER)) (QUOTE (\\\, PAT)) (QUOTE (\\\, PROPS)) (QUOTE (\\\, OPTIONS)))) (QUOTE NAME) (QUOTE FB)))) NIL) -) (FB.COPYBINARYCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE) (QUOTE ((TYPE BINARY)))))) -) (FB.COPYTEXTCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE) (QUOTE ((TYPE TEXT)))))) -) (FILEBROWSER -(LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT (QUOTE HEIGHT))) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \; "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \; "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \; "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \; "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT (QUOTE HEIGHT))))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT (QUOTE HEIGHT)) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC)) (SETQ REGION (GETREGION (PROGN (* \; "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \; "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \; "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW (QUOTE FILEBROWSER) (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \; "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \; "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \; "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW (QUOTE RIGHT) (QUOTE TOP))) (PROGN (* \; "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \; "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ (QUOTE (("--Abort--" NIL "Abort the current FileBrowser operation"))) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT (QUOTE WEIGHT) (QUOTE BOLD)) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W (QUOTE PASSTOMAINCOMS)))) |do| (* \; "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W (QUOTE PASSTOMAINCOMS) (UNION (QUOTE (HARDCOPYIMAGEW)) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST (QUOTE PRINTFN) (FUNCTION FB.PRINTFN) (QUOTE COPYFN) (FUNCTION FB.COPYFN) (QUOTE USERDATA) BROWSER (QUOTE CLOSEFN) (FUNCTION FB.CLOSEFN) (QUOTE AFTERCLOSEFN) (FUNCTION FB.AFTERCLOSEFN) (QUOTE HEADINGWINDOW) HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW (QUOTE HARDCOPYFN) (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONFN) (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \; "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FB.STARTUP)) (QUOTE (\\\, BROWSER)) (QUOTE (\\\, COMMANDMENU)) (QUOTE (\\\, (FUNCTION FB.UPDATEBROWSERITEMS))))) (QUOTE NAME) (QUOTE |FB-Update|) (QUOTE BEFOREEXIT) (QUOTE DON\'T))) (RETURN BROWSERWINDOW))) -) (FB.TABLEBROWSER -(LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)))) -) (FB.SELECTEDFILES -(LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER))) (QUOTE SELECTED))) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL))) -) (FB.FETCHFILENAME -(LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM (QUOTE TABLEITEM))))) -) (FB.PROMPTWPRINT -(LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) (QUOTE FILEBROWSER)))) THING) (* \; "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW))))))) -) (FB.PROMPTW.FORMAT -(CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER))))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS))) -) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P -(LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;| "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) (QUOTE Y)) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) (QUOTE N)) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL)))) -) (FB.ALLOW.ABORT -(LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) (QUOTE BOTTOM)) (* \; "And repaint it in case it was used last time") (REDISPLAYW (CAR W))))) -) (\\FB.HARDCOPY.TOFILE.EXTENSION -(LAMBDA NIL (* \; "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS (QUOTE IP)) (POSTSCRIPT (QUOTE PS)) (DEFAULT TYPE)))) -) ) (* \; "Setup") (DEFINEQ (FB.STARTUP -(LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC (QUOTE |Recompute|) (|fetch| (MENU ITEMS) |of| COMMANDMENU)) COMMANDMENU) (CL:FUNCALL FN BROWSER))) -) (FB.MAKERIGIDWINDOW -(LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW (QUOTE REGION))))) (WINDOWPROP WINDOW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (WINDOWPROP WINDOW (QUOTE MAXSIZE) (CONS SCREENWIDTH HEIGHT)) WINDOW)) -) ) (DEFINEQ (FB.PRINTFN -(LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW (QUOTE DSP))) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \; "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \; "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \; "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \; "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT (QUOTE DATE)) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM)))) -) (FB.COPYFN -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) -) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FB.COMMANDSELECTEDFN)) (QUOTE (\\\, ITEM)) (QUOTE (\\\, MENU)) (QUOTE (\\\, KEY)))) (QUOTE NAME) (PACK* (QUOTE FB-) (CAR ITEM)) (QUOTE BEFOREEXIT) (QUOTE DON\'T))) -) (FB.COMMANDSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER)))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW)))))) -) (FB.SUBITEMP -(LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) (QUOTE SUBITEMS)) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I)))))) -) (FB.MAKE.BROWSER.BUSY -(LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE)) T))) -) (FB.FINISH.COMMAND -(LAMBDA (BROWSER ITEM MENU) (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \; "Take down the abort button if there was one") (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W (QUOTE MENU)))))) M FB.ITEMUNSELECTEDSHADE) (DETACHWINDOW W) (CLOSEW W))) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted.")))) -) (FB.HANDLE.ABORT.BUTTON -(LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) (QUOTE FILEBROWSER))) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER)) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \; "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC)))) -) ) (DEFINEQ (FB.DELETECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) (FB.DELVERCOMMAND -(LAMBDA (FBROWSER) (* \; "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM))))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER (QUOTE DELETED)) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED))))) -) (FB.IS.NOT.SUBDIRECTORY.ITEM -(LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES -(LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \; "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED))) -) (FB.DELETE.FILE -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T)))) -) ) (DEFINEQ (FB.UNDELETECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) (FB.UNDELETEALLCOMMAND -(LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) (FB.UNDELETE.FILE -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE)))))))) -) ) (DEFINEQ (FB.COPYCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE)))) -) (FB.RENAMECOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Rename|) (CONS (FUNCTION RENAMEFILE)))) -) (FB.COPY/RENAME.COMMAND -(LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN))))))))) -) (FB.COPY/RENAME.ONE -(LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \; "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD (QUOTE |Rename|)) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) (QUOTE BOTH)) (T (QUOTE TOTAL))))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \; "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE (QUOTE TOTAL))))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME)))))) -) (FB.COPY/RENAME.MANY -(LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted")) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) (QUOTE HOST)) (LISTGET FIELDS (QUOTE DIRECTORY)) (LISTGET FIELDS (QUOTE DEVICE))) (OR (LISTGET FIELDS (QUOTE NAME)) (LISTGET FIELDS (QUOTE EXTENSION)) (LISTGET FIELDS (QUOTE VERSION)))) (* \; "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) (QUOTE HOST))) (SETQ DIR (OR (LISTGET FIELDS (QUOTE DIRECTORY)) (LISTGET FIELDS (QUOTE RELATIVEDIRECTORY)))) (SETQ DEVICE (LISTGET FIELDS (QUOTE DEVICE))) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM)))) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER (QUOTE Y)) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay")) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION)))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING (QUOTE HOST) HOST (QUOTE DEVICE) DEVICE (QUOTE DIRECTORY) (|if| (NOT RETAIN) |then| DIR |else| (* \; "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME) CMD MOVEFN)))))) -) (FB.MERGE.DIRECTORIES -(LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL)))) -) (FB.GREATEST.PREFIX -(LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL))))))) -) (FB.MAYBE.INSERT.FILE -(LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \; "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;| "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER)))) (* |;;| "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;| "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \; "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM)))) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME (QUOTE VERSION) NIL (QUOTE TENEX)))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION (QUOTE CREATIONDATE) (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)))) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME (QUOTE ICREATIONDATE))) (= CRDATE2 CRDATE))) |then| (* \; "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \; "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING (QUOTE BODY) NEWNAME (QUOTE EXTENSION) "" (QUOTE VERSION) VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \; "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \; "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD (QUOTE |Rename|))) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD (QUOTE |Rename|)) (|fetch| TISELECTED |of| OLDITEM)) (* \; "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T)))) -) (FB.GET.NEW.FILE.SPEC -(LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING (QUOTE DIRECTORY) (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) (QUOTE NAME)))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING (QUOTE DIRECTORY) NEWNAME (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS (QUOTE EXTENSION)))) (EQ (NCHARS NAMEFIELD) 0))) (* \; "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these")) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) (QUOTE HOST)) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME))))))) -) (FB.CANONICAL.DIRECTORY -(LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER (QUOTE FILEBROWSER)))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \; "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL (QUOTE ASK))) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) (QUOTE Y)) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW (QUOTE PROCESS) NIL)))) -) ) (DEFINEQ (FB.HARDCOPYCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST (QUOTE SERVER) PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS)))))) -) (FB.HARDCOPY.TOFILE -(LAMBDA (BROWSER FILES) (* \; "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING (QUOTE NAME) (QUOTE *) (QUOTE EXTENSION) (\\FB.HARDCOPY.TOFILE.EXTENSION))) (T (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (\\FB.HARDCOPY.TOFILE.EXTENSION) (QUOTE BODY) (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS (QUOTE *) (CADR TAIL))) (|if| (NEQ (CAR TAIL) (QUOTE NAME)) |then| (RETURN (SETQ MSG "Only name portion can contain *"))) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files"))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \; "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS (QUOTE DIRECTORY) NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE (QUOTE EXTENSION)))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC (QUOTE EXTENSION) (CDR TYPE)))) |do| (* \; "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE (QUOTE CONVERSION))) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) (QUOTE TEXT))) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL (QUOTE TENEX))) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS (QUOTE NAME)) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) (QUOTE VERSION) NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE)))))) -) ) (DEFINEQ (FB.EDITCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (SELECTQ (OR OPTION FB.DEFAULT.EDITOR) (READONLY (* \; "From SEE command") (COND ((NOT (GETD (QUOTE OPENTEXTSTREAM))) (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU)) (T (RESETLST (LET ((WINDOW (CREATEW NIL FILE)) (STR (OPENSTREAM FILE (QUOTE INPUT)))) (COND ((LISPSOURCEFILEP STR) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STR)) (SETQ STR (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STR NSTR) NSTR))) ((NOT (RANDACCESSP STR)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STR)) (SETQ STR (LET ((NSTR (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) (QUOTE NEW) NIL (LIST (LIST (QUOTE TYPE) (GETFILEINFO STR (QUOTE TYPE))))))) (COPYBYTES STR NSTR) NSTR)))) (OPENTEXTSTREAM STR WINDOW NIL NIL (QUOTE (READONLY T)))))))) (TEDIT (TEDIT (MKATOM FILE))) (LISP (FB.EDITLISPFILE FILE BROWSER)) (NIL (COND ((LISPSOURCEFILEP FILE) (FB.EDITLISPFILE FILE BROWSER)) (T (TEDIT (MKATOM FILE))))) (CL:FUNCALL OPTION (MKATOM FILE)))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) -) (FB.EDITLISPFILE -(LAMBDA (FILE BROWSER) (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) (QUOTE FILEDATES))) FILE)) (NOT (GET ROOT (QUOTE FILE))) (NOT (BOUNDP (FILECOMS ROOT)))) (COND ((MOUSECONFIRM (CONCAT "The file " FILE " is not loaded or is not current. (LOAD '" FILE " 'PROP)?") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL (BQUOTE (LOAD (QUOTE (\\\, FILE)) (QUOTE PROP))))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT (QUOTE (FILES :DONTWAIT)))))) -) (FB.BROWSECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ FILE (|fetch| TIDATA |of| FILE)) (SETQ NAME (|fetch| (FBFILEDATA FILENAME) |of| FILE)) (|if| (OR (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL (QUOTE TENEX))) (NAMETAIL (MEMB (QUOTE NAME) FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) (QUOTE VERSION)) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \; "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \; "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS (QUOTE DIRECTORY))) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS (QUOTE DIRECTORY) (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS (QUOTE HOST)) (QUOTE OSTYPE)) (QUOTE UNIX)) |then| (* \; "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FILEBROWSER)) (QUOTE (\\\, NAME)) (QUOTE (\\\, (MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)))) (\\\,@ (AND DEPTH (BQUOTE ((QUOTE (:DEPTH (\\\, DEPTH)))))))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME)))) -) ) (DEFINEQ (FB.FASTSEECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) (QUOTE NAME)) (UNPACKFILENAME (FB.FETCHFILENAME FILE) (QUOTE EXTENSION))))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW (QUOTE PAGEFULLFN) (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (WINDOWPROP W (QUOTE INUSE) NIL) (DEL.PROCESS (WINDOWPROP W (QUOTE PROCESS)))))))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW (QUOTE PROCESS) NIL) (* \; "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW (QUOTE MORETYPE))))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \; "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \; "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL)))))) -) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \;  "Edited 20-Nov-2000 14:24 by rmk:") (* \;  "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((OR (UNPACKFILENAME FILE 'NAME) (UNPACKFILENAME FILE 'EXTENSION)) (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS))))))) (T (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER))))) (FB.SEEFULLFN -(LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW (QUOTE MORETYPE)))))) (EVENT (WINDOWPROP WINDOW (QUOTE MOREEVENT)))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS (QUOTE (("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one") ("Abort" ABORT "Abort viewing of this and any further files")))) (FINISHEDMOREBUTTONS (QUOTE ((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files")))) (QUOTE ((" More " MORE "View another screenfull of the file") (" Abort " ABORT "Abort view; allow this window to be re-used")))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW (QUOTE MOREEVENT) (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW (QUOTE TITLE))))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS (QUOTE REGION))) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW (QUOTE REGION)))) (QUOTE TOP)) (T (QUOTE BOTTOM))) (QUOTE LEFT)) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW (QUOTE MOREOK) NIL)))) -) (FB.SEEBUTTONFN -(LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \; "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW (QUOTE MOREOK) T) (NOTIFY.EVENT (WINDOWPROP WINDOW (QUOTE MOREEVENT)))) (NEXT (* \; "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW (QUOTE PROCESS)) (QUOTE (CL:THROW :NEXT)))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW (QUOTE PROCESS)))) (SHOULDNT)))) -) ) (DEFINEQ (FB.LOADCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) (QUOTE NAME) (QUOTE LOAD) (QUOTE BEFOREEXIT) (QUOTE DON\'T))))) -) (FB.COMPILECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) (QUOTE NAME) (QUOTE COMPILE) (QUOTE BEFOREEXIT) (QUOTE DON\'T))))) -) (FB.OPERATE.ON.FILES -(LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN (QUOTE LOAD))) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| (BQUOTE ((\\\, FN) (QUOTE (\\\, (FB.FETCHFILENAME FILEENTRY))) (\\\,@ (AND LDFLG (BQUOTE ((QUOTE (\\\, LDFLG)))))))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS (QUOTE PROGN) FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM)))) -) ) (DEFINEQ (FB.UPDATECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER (QUOTE |Recompute|)) (FB.UPDATEBROWSERITEMS BROWSER)))) -) (FB.MAYBE.EXPUNGE -(LAMBDA (BROWSER COMMAND) (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. -Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \; "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL)))) -) (FB.UPDATEBROWSERITEMS -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \; "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \; "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \; "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION (QUOTE SIZE) INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION (QUOTE LENGTH) INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \; "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN (QUOTE DIRECTORY))))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS (QUOTE SUBTREE.SIZE))) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS (QUOTE (SORT RESETLST)))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \; "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \; "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER (QUOTE CLEAR) "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER (QUOTE |done|)) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER)))) -) (FB.DATE -(LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;| "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9)))) -) (FB.ADJUST.DATE.WIDTH -(LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) (QUOTE DATE)) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \; "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT))) -) (FB.SET.BROWSER.TITLE -(LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (QUOTE TITLE) (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser")))))) -) (FB.MAYBE.WIDEN.NAMES -(LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \; "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \; "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T)))))) -) (FB.SET.DEFAULT.NAME.WIDTH -(LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL))) -) (FB.CREATE.FILEBUCKET -(LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \; "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \; "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \; "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \; "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \; "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA)) -) (FB.CHECK.NAME.LENGTH -(LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \; "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN))))))))) -) (FB.ADD.FILEGROUP -(LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA)))) (* \; "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \; "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA))))) -) (FB.INSERT.DIRECTORY -(LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM)) -) (FB.MAKE.SUBDIRECTORY.ITEM -(LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T)))) -) (FB.ADD.FILE -(LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM))) -) (FB.INSERT.FILE -(LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already")) (T (* |;;| "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \; "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \; "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \; "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE (QUOTE ADD)))) -) (FB.ANALYZE.PATTERN -(LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \; "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \; "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \; "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))))) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \; "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN)) -) (FB.GETALLFILEINFO -(LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) (QUOTE (SIZE LENGTH))) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR (QUOTE SUBTREE.SIZE)))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE))) -) ) (DEFINEQ (FB.SORT.VERSIONS -(LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \; "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \; "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS)) -) (FB.DECREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y)))) -) (FB.INCREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y)))) -) (FB.NAMES.DECREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL)) -) (FB.NAMES.INCREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL)) -) (FB.DECREASING.NUMERIC.ATTR -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y))))) -) (FB.INCREASING.NUMERIC.ATTR -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y))))) -) (FB.ALPHABETIC.ATTR -(LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL)) -) ) (DEFINEQ (FB.SORTCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \; "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \; "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \; "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA)))) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \; "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done"))) -) (FB.INSERT.SUBDIRECTORIES -(LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \; "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL)))) -) (FB.GET.SORT.MENU -(LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS (QUOTE ("Name" (QUOTE NAME) "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" (QUOTE NAME) "Sort files by name, decreasing version numbers") ("Increasing version" (QUOTE (NAME T)) "Sort files by name, increasing version numbers")))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) |collect| (BQUOTE ((\\\, (SETQ ATTR (CAR ATTR))) (QUOTE (\\\, ATTR)) "Sort by this attribute" (\\\, (SELECTQ ATTR ((SIZE LENGTH BYTESIZE) (BQUOTE (SUBITEMS ("Decreasing" (QUOTE (\\\, ATTR)) "Sort files in order of decreasing size") ("Increasing" (QUOTE ((\\\, ATTR) T)) "Sort files in order of increasing size")))) ((CREATIONDATE WRITEDATE READDATE) (BQUOTE (SUBITEMS ("Newer first" (QUOTE (\\\, ATTR)) "Sort files with newer dates appearing before older dates") ("Older first" (QUOTE ((\\\, ATTR) T)) "Sort files with older dates appearing before newer dates")))) NIL)))))))))) -) ) (DEFINEQ (FB.EXPUNGECOMMAND -(LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER (QUOTE DELETED))) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER (QUOTE BOTH))) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;| "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " -No") (T (CONCAT (COND (FAILED " -Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T))) -) (FB.NEWPATTERNCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER))))) -) (FB.NEWINFOCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW (QUOTE REGION)))) 0) (* \; "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) (QUOTE FILEBROWSER))) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER (QUOTE CLEAR) "Select from the lower menu which attributes are to be displayed, -then click Recompute")))) (FB.DEPTHCOMMAND -(LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH)))) -) (FB.SHAPECOMMAND -(LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW (QUOTE EXTENT))) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW (QUOTE WIDTH)))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW (QUOTE HEIGHT)) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW (QUOTE REGION))) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) (QUOTE REGION)))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \; "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT))))) -) (FB.REMOVE.FILE -(LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \; "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM (QUOTE REMOVE)))) -) (FB.COUNT.FILE.CHANGE -(LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))))))) -) (FB.SETNEWPATTERN -(LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| (DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN (QUOTE HOST)))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) (QUOTE ICONWINDOW))) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN)) -) (FB.GET.NEWPATTERN -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN))))) -) (FB.OPTIONSCOMMAND -(LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire.")) -) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS -(LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW (QUOTE MENU)))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW)))) -) (FB.INFO.ITEM.NAMED -(LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM))) -) ) (DEFINEQ (FB.MAKECOUNTERWINDOW -(LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW (QUOTE TOP)) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW (QUOTE FILEBROWSER)) |with| COUNTERW) (WINDOWPROP COUNTERW (QUOTE REPAINTFN) (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW (QUOTE RESHAPEFN) (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW (QUOTE PAGEFULLFN) (FUNCTION NILL)) COUNTERW)) -) (FB.COUNTERW.REDISPLAYFN -(LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) (QUOTE FILEBROWSER)))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \; "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER)))) -) (FB.UPDATE.COUNTERS -(LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW (QUOTE HEIGHT))) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE (QUOTE DELETED)) (* \; "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE (QUOTE TOTAL)) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT (QUOTE REPLACE))))) -) (FB.DISPLAY.COUNTERS -(LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW (QUOTE WIDTH))) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW (QUOTE HEIGHT))) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)))) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \; "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT (QUOTE REPLACE)) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING))) -) (FB.COUNTER.STRING -(LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES)))) -) ) (DEFINEQ (FB.MAKEHEADINGWINDOW -(LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW (QUOTE TOP)) (WINDOWPROP HEADINGW (QUOTE PASSTOMAINCOMS) T) (* \; "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW (QUOTE REPAINTFN) (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW (QUOTE RESHAPEFN) (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \; "This is a white on black window") (DSPOPERATION (QUOTE INVERT) HEADINGW) (DSPFILL NIL BLACKSHADE (QUOTE REPLACE) HEADINGW) HEADINGW)) -) (FB.HEADINGW.REDISPLAYFN -(LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE FILEBROWSER)) WINDOW)) -) (FB.HEADINGW.RESHAPEFN -(LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE FILEBROWSER)))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW))) -) (FB.HEADINGW.DISPLAY -(LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW (QUOTE DSP))) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) (QUOTE BORDER))) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE (QUOTE REPLACE) STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \; "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \; "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))))) -) ) (DEFINEQ (FB.ICONFN -(LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) FB.ICONFONT POSITION NIL NIL (QUOTE FILE)))) -) (FB.INFOMENU.WHENSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (BROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN))) -) (FB.CLOSEFN -(LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) (QUOTE DON\'T)) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER (QUOTE DELETED)) 0) (* \; "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \; "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) (QUOTE DON\'T)))))) -) (FB.EXPUNGE?.MENU -(LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT)))) -) (FB.AFTERCLOSEFN -(LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER) NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL))) -) (FB.CLOSE&EXPUNGE -(LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W (QUOTE MENU)))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC (QUOTE |Expunge|) (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG)))))) -) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY -(LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) (TBROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \; "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \; "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \; "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER))) (STREAMPROP IMAGESTREAM (QUOTE PRINTOPTIONS) (LIST* (QUOTE DOCUMENT.NAME) TITLE (STREAMPROP IMAGESTREAM (QUOTE PRINTOPTIONS)))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER) (QUOTE TITLE))) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) (QUOTE DATE)) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \; "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \; "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \; "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM)) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \; "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \; "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \; "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM)))) -) (FB.HARDCOPY.PRINT.TITLE -(LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T)) -) (FB.HARDCOPY.MAXWIDTH -(LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;| "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \; "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH))) -) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001)) (DECLARE\: DONTCOPY (FILEMAP (NIL (20917 33529 (FB 20927 . 21482) (FB.COPYBINARYCOMMAND 21484 . 21672) (FB.COPYTEXTCOMMAND 21674 . 21858) (FILEBROWSER 21860 . 28102) (FB.TABLEBROWSER 28104 . 28266) (FB.SELECTEDFILES 28268 . 28722) (FB.FETCHFILENAME 28724 . 28959) (FB.PROMPTWPRINT 28961 . 29412) (FB.PROMPTW.FORMAT 29414 . 29935) (FB.PROMPTFORINPUT 29937 . 32189) (FB.YES-OR-NO-P 32191 . 32751) (FB.ALLOW.ABORT 32753 . 33328) (\\FB.HARDCOPY.TOFILE.EXTENSION 33330 . 33527)) (33553 34215 (FB.STARTUP 33563 . 33858) ( FB.MAKERIGIDWINDOW 33860 . 34213)) (34216 37235 (FB.PRINTFN 34226 . 37086) (FB.COPYFN 37088 . 37233)) (37285 40702 (FB.MENU.WHENSELECTEDFN 37295 . 37589) (FB.COMMANDSELECTEDFN 37591 . 38452) (FB.SUBITEMP 38454 . 38766) (FB.MAKE.BROWSER.BUSY 38768 . 39176) (FB.FINISH.COMMAND 39178 . 40097) ( FB.HANDLE.ABORT.BUTTON 40099 . 40700)) (40703 43411 (FB.DELETECOMMAND 40713 . 40913) (FB.DELVERCOMMAND 40915 . 42294) (FB.IS.NOT.SUBDIRECTORY.ITEM 42296 . 42423) (FB.DELVER.FILES 42425 . 43001) ( FB.DELETE.FILE 43003 . 43409)) (43412 44242 (FB.UNDELETECOMMAND 43422 . 43626) (FB.UNDELETEALLCOMMAND 43628 . 43826) (FB.UNDELETE.FILE 43828 . 44240)) (44243 56381 (FB.COPYCOMMAND 44253 . 44411) ( FB.RENAMECOMMAND 44413 . 44577) (FB.COPY/RENAME.COMMAND 44579 . 45102) (FB.COPY/RENAME.ONE 45104 . 46202) (FB.COPY/RENAME.MANY 46204 . 49315) (FB.MERGE.DIRECTORIES 49317 . 49554) (FB.GREATEST.PREFIX 49556 . 50216) (FB.MAYBE.INSERT.FILE 50218 . 53907) (FB.GET.NEW.FILE.SPEC 53909 . 55720) ( FB.CANONICAL.DIRECTORY 55722 . 56379)) (56382 59993 (FB.HARDCOPYCOMMAND 56392 . 57007) ( FB.HARDCOPY.TOFILE 57009 . 59991)) (59994 64171 (FB.EDITCOMMAND 60004 . 61295) (FB.EDITLISPFILE 61297 . 61891) (FB.BROWSECOMMAND 61893 . 64169)) (64172 71205 (FB.FASTSEECOMMAND 64182 . 65775) ( FB.FASTSEE.ONEFILE 65777 . 68924) (FB.SEEFULLFN 68926 . 70548) (FB.SEEBUTTONFN 70550 . 71203)) (71206 72336 (FB.LOADCOMMAND 71216 . 71523) (FB.COMPILECOMMAND 71525 . 71866) (FB.OPERATE.ON.FILES 71868 . 72334)) (72337 97097 (FB.UPDATECOMMAND 72347 . 72506) (FB.MAYBE.EXPUNGE 72508 . 73103) ( FB.UPDATEBROWSERITEMS 73105 . 79551) (FB.DATE 79553 . 79949) (FB.ADJUST.DATE.WIDTH 79951 . 81294) ( FB.SET.BROWSER.TITLE 81296 . 81892) (FB.MAYBE.WIDEN.NAMES 81894 . 82870) (FB.SET.DEFAULT.NAME.WIDTH 82872 . 83457) (FB.CREATE.FILEBUCKET 83459 . 87084) (FB.CHECK.NAME.LENGTH 87086 . 88583) ( FB.ADD.FILEGROUP 88585 . 89565) (FB.INSERT.DIRECTORY 89567 . 89776) (FB.MAKE.SUBDIRECTORY.ITEM 89778 . 90590) (FB.ADD.FILE 90592 . 91042) (FB.INSERT.FILE 91044 . 92941) (FB.ANALYZE.PATTERN 92943 . 95612 ) (FB.CANONICALIZE.PATTERN 95614 . 96360) (FB.GETALLFILEINFO 96362 . 97095)) (97098 101508 ( FB.SORT.VERSIONS 97108 . 98201) (FB.DECREASING.VERSION 98203 . 98593) (FB.INCREASING.VERSION 98595 . 98982) (FB.NAMES.DECREASING.VERSION 98984 . 99534) (FB.NAMES.INCREASING.VERSION 99536 . 100081) ( FB.DECREASING.NUMERIC.ATTR 100083 . 100577) (FB.INCREASING.NUMERIC.ATTR 100579 . 101067) ( FB.ALPHABETIC.ATTR 101069 . 101506)) (101509 106088 (FB.SORTCOMMAND 101519 . 104531) ( FB.INSERT.SUBDIRECTORIES 104533 . 104960) (FB.GET.SORT.MENU 104962 . 106086)) (106089 114725 ( FB.EXPUNGECOMMAND 106099 . 107166) (FB.NEWPATTERNCOMMAND 107168 . 107435) (FB.NEWINFOCOMMAND 107437 . 108724) (FB.DEPTHCOMMAND 108726 . 109525) (FB.SHAPECOMMAND 109527 . 111464) (FB.REMOVE.FILE 111466 . 112646) (FB.COUNT.FILE.CHANGE 112648 . 113441) (FB.SETNEWPATTERN 113443 . 114189) (FB.GET.NEWPATTERN 114191 . 114548) (FB.OPTIONSCOMMAND 114550 . 114723)) (114760 115354 ( FB.INFOMENU.SHADEINITIALSELECTIONS 114770 . 115122) (FB.INFO.ITEM.NAMED 115124 . 115352)) (115355 120184 (FB.MAKECOUNTERWINDOW 115365 . 116044) (FB.COUNTERW.REDISPLAYFN 116046 . 116404) ( FB.UPDATE.COUNTERS 116406 . 117685) (FB.DISPLAY.COUNTERS 117687 . 119984) (FB.COUNTER.STRING 119986 . 120182)) (120185 122784 (FB.MAKEHEADINGWINDOW 120195 . 120964) (FB.HEADINGW.REDISPLAYFN 120966 . 121144) (FB.HEADINGW.RESHAPEFN 121146 . 121430) (FB.HEADINGW.DISPLAY 121432 . 122782)) (122785 125489 (FB.ICONFN 122795 . 123043) (FB.INFOMENU.WHENSELECTEDFN 123045 . 123568) (FB.CLOSEFN 123570 . 124200) (FB.EXPUNGE?.MENU 124202 . 124457) (FB.AFTERCLOSEFN 124459 . 124745) (FB.CLOSE&EXPUNGE 124747 . 125487 )) (125490 131674 (FB.HARDCOPY.DIRECTORY 125500 . 130650) (FB.HARDCOPY.PRINT.TITLE 130652 . 130901) ( FB.HARDCOPY.MAXWIDTH 130903 . 131672))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 12:41:59"  |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;25| 259384 |changes| |to:| (FNS FB.MAKECOUNTERWINDOW FB.NEWINFOCOMMAND FB.EXPUNGECOMMAND FB.MAYBE.EXPUNGE FB.MAKEHEADINGWINDOW FB.EDITCOMMAND.ONEFILE) (VARS FB.CLOSE.MENU.ITEMS FILEBROWSERCOMS) |previous| |date:| "21-Feb-2021 23:37:13" |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;21|) ; Copyright (c) 1983-1991, 1993-1994, 1999-2001, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (DECLARE\: EVAL@COMPILE DONTCOPY (P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)))) (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (P (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE)) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (INITVARS (FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser" ))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files" ) ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files" ))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing" ))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards" ) ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards" ) ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window" ) ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory" ))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files" ) ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files")) ) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files") ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files") (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files")) ) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion" ) (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern" ) ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser" ) ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed" ) ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible" ))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice" )))) (VARS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.DIRECTORYP FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITCOMMAND.ONEFILE FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (DECLARE\: EVAL@COMPILE DONTCOPY (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)) ) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQ? FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD ) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice") )) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files. Your deletions are thus ignored."))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB (NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \;  "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',PAT ',PROPS ',OPTIONS) 'NAME 'FB))) NIL)) (FB.COPYBINARYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE BINARY)))))) (FB.COPYTEXTCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE TEXT)))))) (FILEBROWSER (LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT 'HEIGHT)) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \;  "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \;  "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \;  "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \;  "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT 'HEIGHT)))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT 'HEIGHT) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC )) (SETQ REGION (GETREGION (PROGN (* \;  "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \;  "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT ))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \;  "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW 'FILEBROWSER (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \;  "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \;  "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \;  "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW 'RIGHT 'TOP)) (PROGN (* \;  "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \;  "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ '(("--Abort--" NIL "Abort the current FileBrowser operation" )) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT 'WEIGHT 'BOLD) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W 'PASSTOMAINCOMS))) |do| (* \;  "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W 'PASSTOMAINCOMS (UNION '(HARDCOPYIMAGEW) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST 'PRINTFN (FUNCTION FB.PRINTFN) 'COPYFN (FUNCTION FB.COPYFN) 'USERDATA BROWSER 'CLOSEFN (FUNCTION FB.CLOSEFN) 'AFTERCLOSEFN (FUNCTION FB.AFTERCLOSEFN) 'HEADINGWINDOW HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW 'HARDCOPYFN (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW 'ICONFN (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \;  "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS `(,(FUNCTION FB.STARTUP) ',BROWSER ',COMMANDMENU ',(FUNCTION FB.UPDATEBROWSERITEMS)) 'NAME '|FB-Update| 'BEFOREEXIT 'DON\'T)) (RETURN BROWSERWINDOW)))) (FB.TABLEBROWSER (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (FB.SELECTEDFILES (LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)) 'SELECTED)) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL)))) (FB.FETCHFILENAME (LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM 'TABLEITEM))))) (FB.DIRECTORYP (LAMBDA (FILE) (* \; "Edited 20-Feb-2021 20:05 by rmk:") (* |;;| "Does FILE denote a directory?") (CL:WHEN (TYPE? TABLEITEM FILE) (SETQ FILE (FETCH TIDATA OF FILE))) (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE))) (FB.PROMPTWPRINT (LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) 'FILEBROWSER))) THING) (* \;  "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW)))))))) (FB.PROMPTW.FORMAT (CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS)))) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P (LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;|  "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) 'Y) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) 'N) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL))))) (FB.ALLOW.ABORT (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER 'FILEBROWSER) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) 'BOTTOM) (* \;  "And repaint it in case it was used last time") (REDISPLAYW (CAR W)))))) (\\FB.HARDCOPY.TOFILE.EXTENSION (LAMBDA NIL (* \;  "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS 'IP) (POSTSCRIPT 'PS) (DEFAULT TYPE))))) ) (* \; "Setup") (DEFINEQ (FB.STARTUP (LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC '|Recompute| (|fetch| (MENU ITEMS) |of| COMMANDMENU) ) COMMANDMENU) (CL:FUNCALL FN BROWSER)))) (FB.MAKERIGIDWINDOW (LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW 'REGION)))) (WINDOWPROP WINDOW 'MINSIZE (CONS 0 HEIGHT)) (WINDOWPROP WINDOW 'MAXSIZE (CONS SCREENWIDTH HEIGHT)) WINDOW))) ) (DEFINEQ (FB.PRINTFN (LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW 'DSP)) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \;  "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \;  "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \;  "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \;  "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT 'DATE) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM))))) (FB.COPYFN (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM))))) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS `(,(FUNCTION FB.COMMANDSELECTEDFN) ',ITEM ',MENU ',KEY) 'NAME (PACK* 'FB- (CAR ITEM)) 'BEFOREEXIT 'DON\'T))) (FB.COMMANDSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW))))))) (FB.SUBITEMP (LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) 'SUBITEMS) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I))))))) (FB.MAKE.BROWSER.BUSY (LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE)) T)))) (FB.FINISH.COMMAND (LAMBDA (BROWSER ITEM MENU) (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \;  "Take down the abort button if there was one") (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W 'MENU))))) M FB.ITEMUNSELECTEDSHADE) (DETACHWINDOW W) (CLOSEW W))) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted."))))) (FB.HANDLE.ABORT.BUTTON (LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) 'FILEBROWSER)) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER )) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \;  "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC))))) ) (DEFINEQ (FB.DELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.DELVERCOMMAND (LAMBDA (FBROWSER) (* \;  "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM)) ))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER ) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER 'DELETED) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED)))))) (FB.IS.NOT.SUBDIRECTORY.ITEM (LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES (LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \;  "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED)))) (FB.DELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T))))) ) (DEFINEQ (FB.UNDELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETEALLCOMMAND (LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE))))))))) ) (DEFINEQ (FB.COPYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE))))) (FB.RENAMECOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Rename| (CONS (FUNCTION RENAMEFILE))))) (FB.COPY/RENAME.COMMAND (LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN)))))))))) (FB.COPY/RENAME.ONE (LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \;  "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD '|Rename|) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) 'BOTH) (T 'TOTAL)))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \;  "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE 'TOTAL)))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME))))))) (FB.COPY/RENAME.MANY (LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted") ) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST) (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'DEVICE)) (OR (LISTGET FIELDS 'NAME) (LISTGET FIELDS 'EXTENSION) (LISTGET FIELDS 'VERSION))) (* \;  "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST)) (SETQ DIR (OR (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'RELATIVEDIRECTORY))) (SETQ DEVICE (LISTGET FIELDS 'DEVICE)) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM))) ) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER 'Y) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay") ) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION) ))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING 'HOST HOST 'DEVICE DEVICE 'DIRECTORY (|if| (NOT RETAIN) |then| DIR |else| (* \;  "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) 'VERSION NIL 'BODY OLDNAME) CMD MOVEFN))))))) (FB.MERGE.DIRECTORIES (LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL))))) (FB.GREATEST.PREFIX (LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL)))))))) (FB.MAYBE.INSERT.FILE (LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \;  "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;|  "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER) ))) (* |;;|  "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;|  "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \;  "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM))) ) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME 'VERSION NIL 'TENEX))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION 'CREATIONDATE (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)) )) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME 'ICREATIONDATE)) (= CRDATE2 CRDATE))) |then| (* \;  "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \;  "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING 'BODY NEWNAME 'EXTENSION "" 'VERSION VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \;  "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \;  "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD '|Rename|)) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD '|Rename|) (|fetch| TISELECTED |of| OLDITEM)) (* \;  "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T))))) (FB.GET.NEW.FILE.SPEC (LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING 'DIRECTORY (OR (|fetch| (  FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) 'VERSION NIL 'BODY OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) 'NAME))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING 'DIRECTORY NEWNAME 'VERSION NIL 'BODY OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS 'EXTENSION))) (EQ (NCHARS NAMEFIELD) 0))) (* \;  "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these") ) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) 'HOST) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME)))))))) (FB.CANONICAL.DIRECTORY (LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER 'FILEBROWSER))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \;  "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL 'ASK)) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) 'Y) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW 'PROCESS NIL))))) ) (DEFINEQ (FB.HARDCOPYCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \;  "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST 'SERVER PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS))))))) (FB.HARDCOPY.TOFILE (LAMBDA (BROWSER FILES) (* \;  "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING 'NAME '* 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ))) (T (PACKFILENAME.STRING 'VERSION NIL 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ) 'BODY (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS '* (CADR TAIL))) (|if| (NEQ (CAR TAIL) 'NAME) |then| (RETURN (SETQ MSG "Only name portion can contain *") )) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files" ))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \;  "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS 'DIRECTORY NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE 'EXTENSION))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC 'EXTENSION (CDR TYPE)))) |do| (* \;  "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE 'CONVERSION)) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) 'TEXT)) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL 'TENEX)) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS 'NAME) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) 'VERSION NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE))))))) ) (DEFINEQ (FB.EDITCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 21-Feb-2021 15:56 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (IF (DIRECTORYNAMEP FILE) THEN (FB.BROWSECOMMAND BROWSER) ELSEIF (GETD 'OPENTEXTSTREAM) THEN (FB.EDITCOMMAND.ONEFILE BROWSER FILE OPTION) ELSE (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU))))) (FB.EDITCOMMAND.ONEFILE (LAMBDA (BROWSER FILE OPTION) (* \; "Edited 21-Feb-2021 23:37 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (* |;;| "Called when we know that FILE is a file, not a directory, and that TEDIT exists. If OPTION is READONLY, we don't want to edit, just view. If FILE is a lisp sourcefile, we execute the font changes by COPY.TEXT.TO.IMAGE") (CL:UNLESS OPTION (SETQ OPTION FB.DEFAULT.EDITOR)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (IF (LISPSOURCEFILEP FILE) THEN (SELECTQ OPTION ((LISP NIL TEDIT) (* |;;| "Asks to load prop and edits the coms. We really don't want to use a text editor on a source file.") (* |;;| "The FUNCALL at the bottom is concerning.") (FB.EDITLISPFILE FILE BROWSER)) (READONLY (* \; "READONLY on call from SEE") (RESETLST (LET ((WINDOW (CREATEW NIL FILE)) (STR (OPENSTREAM FILE 'INPUT))) (RESETSAVE NIL (LIST 'CLOSEF STR)) (SETQ STR (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STR NSTR) NSTR)) (GETPROMPTWINDOW WINDOW (OR TEDIT.PROMPTWINDOW.HEIGHT 1)) (OPENTEXTSTREAM STR WINDOW NIL NIL '(READONLY T))))) (CL:FUNCALL OPTION (MKATOM FILE))) ELSE (SELECTQ OPTION (READONLY (* |;;| "From SEE command. We want to be able to scroll around in the content, can't do that if it isn't random access. So in that case we do a secret NODIRCORE copy and look at that.") (RESETLST (LET ((WINDOW (CREATEW NIL FILE)) (STR (OPENSTREAM FILE 'INPUT))) (CL:UNLESS (RANDACCESSP STR) (RESETSAVE NIL (LIST 'CLOSEF STR)) (SETQ STR (LET ((NSTR (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW NIL (LIST (LIST 'TYPE (GETFILEINFO STR 'TYPE)))))) (COPYBYTES STR NSTR) NSTR))) (GETPROMPTWINDOW WINDOW (OR TEDIT.PROMPTWINDOW.HEIGHT 1)) (OPENTEXTSTREAM STR WINDOW NIL NIL '(READONLY T))))) ((TEDIT NIL) (TEDIT (MKATOM FILE))) (LISP (FB.PROMPTW.FORMAT BROWSER "Failed because not a Lisp source file")) (CL:FUNCALL OPTION (MKATOM FILE))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) (FB.EDITLISPFILE (LAMBDA (FILE BROWSER) (* \; "Edited 21-Feb-2021 17:29 by rmk:") (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) 'FILEDATES)) FILE)) (NOT (GET ROOT 'FILE)) (NOT (BOUNDP (FILECOMS ROOT)))) (FB.PROMPTW.FORMAT BROWSER "The file ~A is not loaded or is not current." FILE) (COND ((MOUSECONFIRM (CONCAT "(LOAD '" FILE " 'PROP)? ") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL `(LOAD ',FILE 'PROP))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT '(FILES :DONTWAIT)))))) (FB.BROWSECOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 20-Feb-2021 20:10 by rmk:") (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ NAME (FB.FETCHFILENAME FILE)) (|if| (OR (FB.DIRECTORYP FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL 'TENEX)) (NAMETAIL (MEMB 'NAME FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) 'VERSION) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \;  "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \;  "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS 'DIRECTORY)) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS 'DIRECTORY (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS 'HOST) 'OSTYPE) 'UNIX) |then| (* \;  "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',NAME ',(MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)) ,@(AND DEPTH `('(:DEPTH ,DEPTH))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME))))) ) (DEFINEQ (FB.FASTSEECOMMAND (LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'NAME) (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'EXTENSION)))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW 'PAGEFULLFN (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'INUSE NIL) (DEL.PROCESS (WINDOWPROP W 'PROCESS)))))) ) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW 'PROCESS NIL) (* \;  "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW 'MORETYPE)))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \;  "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \;  "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL))))))) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \; "Edited 21-Feb-2021 14:46 by rmk:") (* \; "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((DIRECTORYNAMEP FILE) (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER)) (T (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS)))))))))) (FB.SEEFULLFN (LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW 'MORETYPE))))) (EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS '(("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one" ) ("Abort" ABORT "Abort viewing of this and any further files" ))) (FINISHEDMOREBUTTONS '((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files" ))) '((" More " MORE "View another screenfull of the file" ) (" Abort " ABORT "Abort view; allow this window to be re-used" ))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH ) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW 'MOREEVENT (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW 'TITLE)))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS 'REGION)) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW 'REGION))) 'TOP) (T 'BOTTOM)) 'LEFT) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW 'MOREOK NIL))))) (FB.SEEBUTTONFN (LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \;  "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW 'MOREOK T) (NOTIFY.EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (NEXT (* \;  "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW 'PROCESS) '(CL:THROW :NEXT))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW 'PROCESS))) (SHOULDNT))))) ) (DEFINEQ (FB.LOADCOMMAND (LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) 'NAME 'LOAD 'BEFOREEXIT 'DON\'T))))) (FB.COMPILECOMMAND (LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) 'NAME 'COMPILE 'BEFOREEXIT 'DON\'T))))) (FB.OPERATE.ON.FILES (LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN 'LOAD)) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| `(,FN ',(FB.FETCHFILENAME FILEENTRY) ,@(AND LDFLG `(',LDFLG))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS 'PROGN FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM))))) ) (DEFINEQ (FB.UPDATECOMMAND (LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER '|Recompute|) (FB.UPDATEBROWSERITEMS BROWSER))))) (FB.MAYBE.EXPUNGE (LAMBDA (BROWSER COMMAND) (* \; "Edited 22-Feb-2021 12:33 by rmk:") (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL))))) (FB.UPDATEBROWSERITEMS (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \;  "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \;  "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \;  "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION 'SIZE INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION 'LENGTH INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) ) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \;  "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN 'DIRECTORY)))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS 'SUBTREE.SIZE)) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS '(SORT RESETLST))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \;  "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \;  "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME ) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER 'CLEAR "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER '|done|) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.DATE (LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;|  "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9))))) (FB.ADJUST.DATE.WIDTH (LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) 'DATE) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM))) ) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \;  "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT)))) (FB.SET.BROWSER.TITLE (LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) 'TITLE (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser"))))))) (FB.MAYBE.WIDEN.NAMES (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \;  "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES ) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \;  "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T))))))) (FB.SET.DEFAULT.NAME.WIDTH (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL)))) (FB.CREATE.FILEBUCKET (LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \;  "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR ))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \;  "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \;  "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \;  "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER )) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \;  "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA))) (FB.CHECK.NAME.LENGTH (LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \;  "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN)))))))))) (FB.ADD.FILEGROUP (LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA))))(* \;  "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \;  "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA)))))) (FB.INSERT.DIRECTORY (LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM))) (FB.MAKE.SUBDIRECTORY.ITEM (LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER) )))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T))))) (FB.ADD.FILE (LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM)))) (FB.INSERT.FILE (LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already") ) (T (* |;;|  "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \;  "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \;  "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE 'ADD)))) (FB.ANALYZE.PATTERN (LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \;  "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \;  "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \;  "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))) )) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \;  "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN))) (FB.GETALLFILEINFO (LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) '(SIZE LENGTH)) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR 'SUBTREE.SIZE))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE)))) ) (DEFINEQ (FB.SORT.VERSIONS (LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \;  "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME ) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \;  "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS))) (FB.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y))))) (FB.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y))))) (FB.NAMES.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL))) (FB.NAMES.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL))) (FB.DECREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.INCREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.ALPHABETIC.ATTR (LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL))) ) (DEFINEQ (FB.SORTCOMMAND (LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \;  "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \;  "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \;  "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME ) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA))) ) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \;  "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done")))) (FB.INSERT.SUBDIRECTORIES (LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \;  "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL))))) (FB.GET.SORT.MENU (LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS '("Name" 'NAME "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" 'NAME "Sort files by name, decreasing version numbers") ("Increasing version" '(NAME T) "Sort files by name, increasing version numbers"))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER ) |collect| `(,(SETQ ATTR (CAR ATTR)) ',ATTR "Sort by this attribute" ,(SELECTQ ATTR ((SIZE LENGTH BYTESIZE) `(SUBITEMS ("Decreasing" ',ATTR "Sort files in order of decreasing size" ) ("Increasing" '(,ATTR T) "Sort files in order of increasing size"))) ((CREATIONDATE WRITEDATE READDATE) `(SUBITEMS ("Newer first" ',ATTR "Sort files with newer dates appearing before older dates" ) ("Older first" '(,ATTR T) "Sort files with older dates appearing before newer dates" ))) NIL))))))))) ) (DEFINEQ (FB.EXPUNGECOMMAND (LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 22-Feb-2021 12:36 by rmk:") (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER 'DELETED)) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER 'BOTH)) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;|  "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " No") (T (CONCAT (COND (FAILED " Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T)))) (FB.NEWPATTERNCOMMAND (LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER)))))) (FB.NEWINFOCOMMAND (LAMBDA (BROWSER) (* \; "Edited 22-Feb-2021 12:35 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW 'BOTTOM 'JUSTIFY 'LOCALCLOSE) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW 'REGION))) 0) (* \;  "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW 'CLOSEFN (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) 'FILEBROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER 'CLEAR "Select from the lower menu which attributes are to be displayed, then click Recompute")))) (FB.DEPTHCOMMAND (LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL ) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH))))) (FB.SHAPECOMMAND (LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW 'EXTENT)) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW 'WIDTH))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW 'HEIGHT) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER )))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW 'REGION)) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) 'REGION))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \;  "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT)))))) (FB.REMOVE.FILE (LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM 'REMOVE)))) (FB.COUNT.FILE.CHANGE (LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE)))))))) (FB.SETNEWPATTERN (LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| ( DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN 'HOST))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) 'ICONWINDOW)) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN))) (FB.GET.NEWPATTERN (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN)))))) (FB.OPTIONSCOMMAND (LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire."))) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS (LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW 'MENU))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW))))) (FB.INFO.ITEM.NAMED (LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM)))) ) (DEFINEQ (FB.MAKECOUNTERWINDOW (LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 22-Feb-2021 12:41 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW 'TOP) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW 'FILEBROWSER) |with| COUNTERW) (WINDOWPROP COUNTERW 'REPAINTFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'RESHAPEFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'PAGEFULLFN (FUNCTION NILL)) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP COUNTERW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) COUNTERW))) (FB.COUNTERW.REDISPLAYFN (LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) 'FILEBROWSER))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \;  "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.UPDATE.COUNTERS (LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE 'DELETED) (* \;  "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE 'TOTAL) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT 'REPLACE))))) (FB.DISPLAY.COUNTERS (LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW 'WIDTH)) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)) )) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \;  "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT 'REPLACE) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING) ))) (FB.COUNTER.STRING (LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES))))) ) (DEFINEQ (FB.MAKEHEADINGWINDOW (LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Feb-2021 12:29 by rmk:") (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW 'TOP) (WINDOWPROP HEADINGW 'PASSTOMAINCOMS T) (* \;  "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW 'REPAINTFN (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW 'RESHAPEFN (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \;  "This is a white on black window") (DSPOPERATION 'INVERT HEADINGW) (DSPFILL NIL BLACKSHADE 'REPLACE HEADINGW) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP HEADINGW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HEADINGW))) (FB.HEADINGW.REDISPLAYFN (LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER) WINDOW))) (FB.HEADINGW.RESHAPEFN (LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW)))) (FB.HEADINGW.DISPLAY (LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW 'DSP)) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) 'BORDER)) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE 'REPLACE STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \;  "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \;  "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC)))))) ) (DEFINEQ (FB.ICONFN (LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW 'FILEBROWSER)) FB.ICONFONT POSITION NIL NIL 'FILE)))) (FB.INFOMENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (BROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN)))) (FB.CLOSEFN (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) 'DON\'T) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER 'DELETED) 0) (* \;  "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) 'DON\'T)))))) (FB.EXPUNGE?.MENU (LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT))))) (FB.AFTERCLOSEFN (LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL)))) (FB.CLOSE&EXPUNGE (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W 'MENU))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC '|Expunge| (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG))))))) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY (LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (TBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER)) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \;  "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \;  "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \;  "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER ))) (STREAMPROP IMAGESTREAM 'PRINTOPTIONS (LIST* 'DOCUMENT.NAME TITLE (STREAMPROP IMAGESTREAM 'PRINTOPTIONS))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW ) |of| FBROWSER) 'TITLE)) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES ) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) 'DATE) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \;  "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \;  "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \;  "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM) ) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \;  "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \;  "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \;  "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM))))) (FB.HARDCOPY.PRINT.TITLE (LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T))) (FB.HARDCOPY.MAXWIDTH (LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;|  "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \;  "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001 2021)) (DECLARE\: DONTCOPY (FILEMAP (NIL (28292 50928 (FB 28302 . 29258) (FB.COPYBINARYCOMMAND 29260 . 29606) (FB.COPYTEXTCOMMAND 29608 . 29950) (FILEBROWSER 29952 . 43058) (FB.TABLEBROWSER 43060 . 43277) (FB.SELECTEDFILES 43279 . 43916) (FB.FETCHFILENAME 43918 . 44310) (FB.DIRECTORYP 44312 . 44640) (FB.PROMPTWPRINT 44642 . 45688) (FB.PROMPTW.FORMAT 45690 . 46427) (FB.PROMPTFORINPUT 46429 . 48681) (FB.YES-OR-NO-P 48683 . 49717) ( FB.ALLOW.ABORT 49719 . 50573) (\\FB.HARDCOPY.TOFILE.EXTENSION 50575 . 50926)) (50952 51905 (FB.STARTUP 50962 . 51477) (FB.MAKERIGIDWINDOW 51479 . 51903)) (51906 57278 (FB.PRINTFN 51916 . 57069) (FB.COPYFN 57071 . 57276)) (57328 62653 (FB.MENU.WHENSELECTEDFN 57338 . 57696) (FB.COMMANDSELECTEDFN 57698 . 59237) (FB.SUBITEMP 59239 . 59674) (FB.MAKE.BROWSER.BUSY 59676 . 60228) (FB.FINISH.COMMAND 60230 . 61664) (FB.HANDLE.ABORT.BUTTON 61666 . 62651)) (62654 68170 (FB.DELETECOMMAND 62664 . 62945) ( FB.DELVERCOMMAND 62947 . 66140) (FB.IS.NOT.SUBDIRECTORY.ITEM 66142 . 66323) (FB.DELVER.FILES 66325 . 67414) (FB.DELETE.FILE 67416 . 68168)) (68171 69496 (FB.UNDELETECOMMAND 68181 . 68466) ( FB.UNDELETEALLCOMMAND 68468 . 68747) (FB.UNDELETE.FILE 68749 . 69494)) (69497 93678 (FB.COPYCOMMAND 69507 . 69776) (FB.RENAMECOMMAND 69778 . 70053) (FB.COPY/RENAME.COMMAND 70055 . 70978) ( FB.COPY/RENAME.ONE 70980 . 73302) (FB.COPY/RENAME.MANY 73304 . 79524) (FB.MERGE.DIRECTORIES 79526 . 79944) (FB.GREATEST.PREFIX 79946 . 81302) (FB.MAYBE.INSERT.FILE 81304 . 88744) (FB.GET.NEW.FILE.SPEC 88746 . 92577) (FB.CANONICAL.DIRECTORY 92579 . 93676)) (93679 101463 (FB.HARDCOPYCOMMAND 93689 . 94819 ) (FB.HARDCOPY.TOFILE 94821 . 101461)) (101464 111702 (FB.EDITCOMMAND 101474 . 102265) ( FB.EDITCOMMAND.ONEFILE 102267 . 105918) (FB.EDITLISPFILE 105920 . 106959) (FB.BROWSECOMMAND 106961 . 111700)) (111703 123496 (FB.FASTSEECOMMAND 111713 . 115163) (FB.FASTSEE.ONEFILE 115165 . 118194) ( FB.SEEFULLFN 118196 . 122327) (FB.SEEBUTTONFN 122329 . 123494)) (123497 125243 (FB.LOADCOMMAND 123507 . 124014) (FB.COMPILECOMMAND 124016 . 124554) (FB.OPERATE.ON.FILES 124556 . 125241)) (125244 172293 ( FB.UPDATECOMMAND 125254 . 125479) (FB.MAYBE.EXPUNGE 125481 . 126476) (FB.UPDATEBROWSERITEMS 126478 . 139693) (FB.DATE 139695 . 140436) (FB.ADJUST.DATE.WIDTH 140438 . 143406) (FB.SET.BROWSER.TITLE 143408 . 144265) (FB.MAYBE.WIDEN.NAMES 144267 . 146386) (FB.SET.DEFAULT.NAME.WIDTH 146388 . 147752) ( FB.CREATE.FILEBUCKET 147754 . 154974) (FB.CHECK.NAME.LENGTH 154976 . 157397) (FB.ADD.FILEGROUP 157399 . 158926) (FB.INSERT.DIRECTORY 158928 . 159166) (FB.MAKE.SUBDIRECTORY.ITEM 159168 . 160577) ( FB.ADD.FILE 160579 . 161192) (FB.INSERT.FILE 161194 . 164606) (FB.ANALYZE.PATTERN 164608 . 169872) ( FB.CANONICALIZE.PATTERN 169874 . 171186) (FB.GETALLFILEINFO 171188 . 172291)) (172294 180453 ( FB.SORT.VERSIONS 172304 . 175075) (FB.DECREASING.VERSION 175077 . 175746) (FB.INCREASING.VERSION 175748 . 176369) (FB.NAMES.DECREASING.VERSION 176371 . 177406) (FB.NAMES.INCREASING.VERSION 177408 . 178405) (FB.DECREASING.NUMERIC.ATTR 178407 . 179087) (FB.INCREASING.NUMERIC.ATTR 179089 . 179763) ( FB.ALPHABETIC.ATTR 179765 . 180451)) (180454 190296 (FB.SORTCOMMAND 180464 . 187294) ( FB.INSERT.SUBDIRECTORIES 187296 . 188093) (FB.GET.SORT.MENU 188095 . 190294)) (190297 206386 ( FB.EXPUNGECOMMAND 190307 . 192826) (FB.NEWPATTERNCOMMAND 192828 . 193226) (FB.NEWINFOCOMMAND 193228 . 195994) (FB.DEPTHCOMMAND 195996 . 197771) (FB.SHAPECOMMAND 197773 . 201115) (FB.REMOVE.FILE 201117 . 202938) (FB.COUNT.FILE.CHANGE 202940 . 204385) (FB.SETNEWPATTERN 204387 . 205557) (FB.GET.NEWPATTERN 205559 . 206143) (FB.OPTIONSCOMMAND 206145 . 206384)) (206421 207433 ( FB.INFOMENU.SHADEINITIALSELECTIONS 206431 . 207078) (FB.INFO.ITEM.NAMED 207080 . 207431)) (207434 216900 (FB.MAKECOUNTERWINDOW 207444 . 208906) (FB.COUNTERW.REDISPLAYFN 208908 . 209495) ( FB.UPDATE.COUNTERS 209497 . 211569) (FB.DISPLAY.COUNTERS 211571 . 216631) (FB.COUNTER.STRING 216633 . 216898)) (216901 221544 (FB.MAKEHEADINGWINDOW 216911 . 218459) (FB.HEADINGW.REDISPLAYFN 218461 . 218727) (FB.HEADINGW.RESHAPEFN 218729 . 219105) (FB.HEADINGW.DISPLAY 219107 . 221542)) (221545 225728 (FB.ICONFN 221555 . 221902) (FB.INFOMENU.WHENSELECTEDFN 221904 . 222634) (FB.CLOSEFN 222636 . 223839) (FB.EXPUNGE?.MENU 223841 . 224253) (FB.AFTERCLOSEFN 224255 . 224616) (FB.CLOSE&EXPUNGE 224618 . 225726 )) (225729 237787 (FB.HARDCOPY.DIRECTORY 225739 . 236096) (FB.HARDCOPY.PRINT.TITLE 236098 . 236424) ( FB.HARDCOPY.MAXWIDTH 236426 . 237785))))) STOP \ No newline at end of file diff --git a/library/FILEBROWSER.LCOM b/library/FILEBROWSER.LCOM index 25db45b4819d1f5e2a0b2c9621245e8615af86b8..7ea8b6f0dd7abdb999658b7829dcd4b1b584cf93 100644 GIT binary patch delta 5294 zcmds5du&_P8PCb1dEUI!rq1h&TZ+>*#`pSd+B7%zO>^m`sg9 zdJ3!{W$p?k_TRm0a5gnF+jDGWdU9l{C!8J~ne4eGH8z<#?zFpmj!w*VXL~)96Gvu7 zW{&st>tU@gZX^?0+1NP~MAT@=ZbUT>a~IeSs__K< z`rn&sR=|#{67(c#x^XoGiZkH!24p8f^i^0^Ui_3))GvhexE3^x_)rW2A)jOmgUtcr za$Qi+QBY7oddGf&KLw92^={z5zbO=(n*G*w77i4>R6Jfw#Nd$lvh3XHj-z~`7<#l<4^{Hs{k>{mu!^^q1_}?IextzV zMeX|R{c6HYXvkAx5AcY=wH6AXKH!#NcsPXSifW-4IQ@Kg);;o@oeEq5F{(zi7$_ck zV8p-E*=x}I*QvgrjJZxD&YU^emDB(u-0ZrdKV4_tH z6crVa@k9kzD-LKKg2xGaH8W?ftTVeE5Hw;#cCMA(H0*jr-K&91S>7wQ($3+QX2lJ` zu#wREF-(CTjSZTJ0C*L8Vz{k7?*uAF6`6mW^r5!E3JiL_41;^W5CdH>U~wPqy}0H0rM$yyc=JVc6nfFA8PkO2@!N8g|ZgIXd% zVYqd#*9qoOOaqTM_bWqGOM=@2eTF%}d3IOSKq3W=xOO)eI4TG{5(5fyk6859Y(!zp?-a2bhvb`_~mO4_L z+$hX+W+>S_CRlsv$73wldVDFlF=-JjeWBoFcJ_=l*;?0GN?&Pjw$`7%E!li7C*jz> z(?_q!IJ0GmFRS3oj@F;vl@s{X*z+h-94J1gw`7Grp0o%T5J!D4+5FSI%>C73-KbTp zL*Gzj4~BurLB!Go#o>dMD*^40w|A#mQ+)928=Y_Da;t*y`7=!Vk z$V)MFQ$=w?AZo-TY8Z3AQ>;J>`}1l#AgEPxM zdcwcuIv$(^e|5-_S_em-$H>p&;(~&rzGuF{1L2Y4CHlU=4D&W})nC4Ijxf520a=}kV8)}ENV7GRVv&Er6 z#28Fqc8&Jy@dzMou^CiN@XCl>BmI2z&@S&fc5rW4FB)Uafk6WUn(XjH*ib{@chgg2 z+x8$oZMN(b0ubx!5^%w_qO%78%T})!tTwUdS}S=IFKpo9uS4zdB~cWv_O*X=Hv=iGo>A zFr`LztZ;g~K2oL7?ZHKx7cd-PTFe&8{N{ilY@R0^<~vh2!&<3uJIpHonYS0ZJjg3wu>?-X;<4MbDk3eO`Bt11I_1R; z_iZcWzxMC+?rN4o>8aFCID*xCdTR1G0xc^(uu6*$yiSX8Q~R$=s>vgC>-h}5_k4}3 zR|L_U1q}z#ePj%at96#0t~Dd{>GKb`c!)4!5jDP7k8&)rhyA2IVuZAKR6mTIK!@ua zG)=6h4`QL!ABDvo?+lld$LReZelsY}6(4c-x_e;CU3(Aznh{!c;RzQy?TUNgU9WNv z|Jr-}=)#{jvxlll=Ryo@XoA6L7%Ks=@p=k!ywwiHjJTPwtKo2$lpo|F8OdzJ_Y)S# zfCZn87s@hNqv!?!5Lr2&gJ)8=&QHvwX3_nwh_Z@3SGI3lA*!p3pTkc`u%!mFWdUV_ zZ98PHzn(w15~(?upN5;#Gw8s1jBlTq8cW|kyAy67PtA>|W&me-P+nd!F$>c(sqV@2 z$XII3iua8e2Sa=E`r!K@jAL0(l~zMnd>B<-eD3m}2-AzmRwA*fRuW=&wvsCLN)f5W zfj<DpW*}*<*BPnc;wv%hwciYJpY}a<+`d_t^c6PCy?8puT zHf4h8>Eq&!%PZh~`7g1N4x+PXJ4j0vPfC1_7sqTbkX@`ANHy+n1=5zE?9-!ae2Bf> zL3Xom18J$pO>vFC9F|3%24Xbg_<$M@tv;-wljzk}GmS}6Bto!B?B-5#k)7N^EN4fo zWVpP7(?>ufu{(;%cJ_GbYkD!K(?~u8%S?4*OYxCA%^ES z2q~LO@lbCm>A_|5rQ{m=nzMmDUrM^M|6VBp+E=uZ)t3<)k?7K%CT5h821>4PVt160 zCVI)(#GWoA7WN9R*t9C~FXw%Bv5W*bWVxqZzC=drJIhJ11!u6rk7H?!Gj`zuIc+6& zqMY>7w@)+{f=&E9z1EatrljU9KW_Y)-w?%z7onM18lBjU%vlvwJ1dO<%vTk^NF4 zTM8whPh4!NL}}R<7mBH=CO+JI`qL&hTunC9kN(lf9;_B#_Ix$j$=<6L_?OiX58G2i zcB0HT=)h`)gnh5Cqr5= ztj4wB0I;Px^aKeoieOm7DKtXX>ly1M$Jt}`M5&SZ)?7%$HSGO*a-dRLA;i}}2J5*A zbET5KpBJ_!JJ~?A9bX)+RtGDLRcHUwK%OQn(n@~+NFyn!TNid%R~rc;K>zO_Zja`j1F+jlf&mLl-Syutu0z#X{kf2Or5}h`v#3VFrJfulX42gZ`*lz5k zsX*&Pnx))(?svZT`JL~4_vS;r;>=enzB9UA5QY-zqeBk6T>!g3;P36r}ERy5^s zpicp}!!lsBj>r)y6qiIz3WMbmzPr}?y0O^VtSk2sB0Xs%(TrW@C56$mCHht{G zcKr>5k$9KhF;v$r9W=euV{kk4Sm1GX`{YaAOQxI8gPz(Q)_e9gC0VQkQ1;{oLm8Qy ztS-afePo|`e7HS>Xu%NyCuv+@qkyS!sDp5tBGv8wy%AYh)@+E5cV0Z`Xe8>h*Q5X-J$RKn$O||W*Rl%WP*PovTBA`H5)&ZhjaJw1V3FFcf8@NE$q$nG?Au1`8Y~;F`Cx6GA=zL^HkxZmd9vz;R5`!DCNmNKyq>mU-Cs^$&%-Jc!k(jEcQUM?%DkF7kA{; z9cboGF?{&kkV-{&;$mqac)buE&x)FgDDijz_oa+fT=eL8j_7uFjd7TA4AvGFhKxE6zE)H;e*xZPi z&=QiAp9XX$l?o%`6e%1-d;h0r{{HRhdO`x-3!05?upRU%X1 z;0Ztj;$%eQiBRLZxVv6|@779V47_>x;7&nMwd;^-%|Z+?8w`RnxC*e7!I{I73Y0$%CSJk-*{AKTP?Z9=2@*QarB4!EG-r2HU!RKUhYl`MI<| zePH^I+tYB5h=+w!e{I_~{g#90Dlq}44P|=Y>^5tdJDGDecg@wfIkA%Y{nBRc{x4Mh z!C9!-$4L6=*&&O4%>oPP&>y;K>SO|O zri{q(DEJ&$2$hgNJC};O*V@2Zl{H)vy}coe)vQFeX_4WUjAA z@PgHvn?g0QfdTM(@Zj#}54TtVF>29g=DV7}%EkIE;BkRPn@ht%%qJ|}H-ECa-0rb2 z8IFHc&IWiO?S)@fld=ktZ+#Adr;5f;K3(>Ze%qJz;T+6ZX~5Ep>zb>Xh5aR5V#^2~ zXHiDoK7H_n+2C^MTLe>$t7yjV(@&+%Sr1p6-?uhZ;m1R+e7jwMO+_weELLz~^~W?L z^qiRRh$P07Yzs~*F)=jG_LL$X$Z*m4~@0Tv?&4j))h;K#qyH!#6%FIUu%lX~clOgSc7H=O_a((~tU zy@6!)wzu!)q_^IFbm{cp{?hWjAQ?RKF8LG5VplV4lQAQSm=uCMLag0`R;;65`+$0h zpArlPFF{rrJ%WF$ebHtK~6%rp^6u83li}tUUfr7v5=+CaCqQIHIuOo1U`Low%n-#}a64=H3BS*nA4qePp4(uO}9i`FA~W(V+&?L5zBIs)Noq zkS_Yo2GWCbKW`vGeX+JlztCr*ttMoQnYf|DCbFIW%tU(iE_VZc+eC&~6UE-Q3oR5r z#(CdTAn4P+W-2#gGHz=mR()c$kv`Q(O!|drBR$_p%xLakI6+-a#NS{<@m0MO(0iLm zsFls&t9~3mr(joQW8G0AA0K_Qi3CwiXETQAZYE)j=q=f#fAFY@{-~Ms;^Py)F>gi% zm|iXk^!;WMK#{=~GC;K!aubeEwGf~F@~>L;r_Z#}_gc``_kZ1jbis@5*ieSSR`Bn)Z4Go_AxRL&}jWpx)i}*}GZsX2a+sP2!*-ku2f1n-ZpJ^v99RIVOw4;oP zLI+2|jt*j>hdYQJ=L#rjAVB}Xr}dxInQ2WYvIw1o#d2>qX`p*LiMKU|pSbvk5ca`> zWiq0M#0bNikuG+UFg@2vjGMwzC?dwCQ~)E~3`A|kk^ZBLNN4w2$m1j%kBJkvuq0ofUNFlG!`cFH zt$IOT2iI$*u0b!DWz8V3g~f-(XEnTD0EHsU?#237=oo+T#Ckp7di4Lf7tCJQQ!p4T zIR}d~v67ely%L^}v-nor z3r?(_SgR-Z^0*#-Z7=vyH~FJ^f*ol^jhxk*38xRGkEb*A!41Srt9nTXembFjy~KxS z=$>9|P44d{H{$r!4J6H`TKah75bPt}^i&0J4j%5q4im@C^sjxaMR};7G}5MiBBR*8 ze$u)Ljk5lX{ZE5_+)uXAH!DdEeYcYLbG$3;sv>F~>#s^1H+s-YRMhfX6{)8$S&3X@ zv}g-3%|F87|J~??Mr Date: Mon, 22 Feb 2021 14:09:14 -0800 Subject: [PATCH 19/31] Delete TWODINSPECTOR.LCOM.~2~ --- sources/TWODINSPECTOR.LCOM.~2~ | Bin 55458 -> 0 bytes 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 sources/TWODINSPECTOR.LCOM.~2~ diff --git a/sources/TWODINSPECTOR.LCOM.~2~ b/sources/TWODINSPECTOR.LCOM.~2~ deleted file mode 100644 index e5f3facc44239cd4c99eb9e509e7213f2e8c66f0..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 55458 zcmeHwYj9lGeIIt0FG<95cL^adOheZ&LxYR}V|Vc&X;;AlSO5zw_CmW0E-A}eQ3NCa zgh+)C+sb3A*iGX$4@YwRtR1)Mhcro>EFVZMQq*=blZiE*cG4NCrQAHeBx%}yA;-z| zL&sr%|NlAXo^$TKO9GT^D^pV=?7ipSd(OG%{LlY=ez$KjKUFB@`=<)Ue1D-dlbl&MLl&bl1u~1p)b$ZJA++;O3Ui1}@=PG$8J$SIak1CkJUDf=g)0xxA3J^Wh4qtX z9xI+bb#nc&=a-k(mtV{d3_rHMdj5q|XU{D^cK+O!J(tskzVIrnCtYx z_9q324cJsrEmVv7`Fv^7IXZc`y;LYVZKKh)wzjA7f7>HVXX&S7TXX3-K5*2*zUJD} znSXp|X{8(glF`V_QlaC)W}*!hwD)C>I9M9F#bT8zp2-&{G5H|piDDV!G`~=FhMb?> z7Nd*R6ASqd{Ve7a2qFc>7<@{8>Ixz!El~Y`)$;vr|s$vU-}d^wM!A!icerkFb+m@-O+9pXwA9F0g`%2bGOb?G=g=u8*$Q&l=lJ5z3nk222mOrAJ96=$7k!Rv86f9*i6r`Eez zJ5=jze~@lHwQH%?DUNnmYkjqWT4Fbs$7}l@po1%O75@E-_<3W;=fuI)SmlY0PH}ws z!Uain%oEwVaLBv` zE5KOC7$on$!NbOVcq_@Acu5!YSiV@XfiiULps80V#^CXUv~zr-cod9*X`grksy2y# zftIjbpco~!J{Pd&)yiG~KM)Ih0X)Lw1Pkbscw@mS7QkQBn5hy;5X=sUNy&pjZ#@>! z1CJ9F&;`Mv3X1FK6Y01)f+om!%2SOp_zIoUz9(tIMa*F?Z7G;9de$WbO+Gd^f6~- zh$rKyoQ!_vR~2V?)L&dKkoJ!&gXWdO6L}|_aV9GZJcQtAQfcDTA!j}}M`ndo*ZXBF zppX%3r702-vLiF<)S&vD{Zw`J!us+gEP(ZsFIFy`TR!=CCA zs@k!9wJ?#xtj(9p&;)29SxZMyV$tb4B4!>OL-OHKISF!3^;G&rL11F_wCYL4Xs}2E zb(4TQc+iO)jbKK{c#>WjYdpNRw7#^&%y?xzy2=O1NZX8$^}XBYXYSmYVal0KiC@t` zjv28y9yg9BjN{3Totm7)t$E|}RPge2+_=t!YMke$ zkZIs@QUGJcWd~7{TsxV=qk`L2;6cbcnUP^}D#v*Ug2=7m<^_2jFQ*Ei{R~?ZB)P}{ zb5^|yGwFcJl^KK}7xn7<(h#zyNK@7Mw6Qb(#sRo#bUfA8wrh+T z67#cr9wz@XIWEMf_<7?|<}CGu`6O3W?<(Z@!0o!3<44|jR9r|+ZHx#GKEvhTSrKQd zuI}cU$lto%w_kC)KZB#!-9+i;GrOCgbrWyDp5MsK&W&+BH`P<3)_u+OZ@c^O(7vBv z|8_mzbW?8p<}(jAf5A50pE4pzv_2%if->P@4xgEE^zE|sktOOY+=LRIQM7U7;`t*|^mHN6XG&##gn&yn7# zv*(;ov99iu51u61x;qHkzhL-N(BLc8T)BEIU#>#`nIkt41RNFd?7<&1=oE7m?@TG& zxZsIym{FCT;D>B4Dc?yn0$)k07H2;B?FUZ3o&3;_xf`>wjctwI$m{d5s~@O!&PUdx zwXQw!Qn40i4%eJts&(9Yc_k6OF&llN@n%~eR2-YwC}hH}Xfj8j(-7rM<{^>`3-Ah2 zcLV0~W=v?qaiJt_T8@%fst3u4&Iau2!1$2~?F|^&(0VZ0PG)ljZWY5WRi-({@vr0X zJLQ&sO9-%Mz_D|R!RDe7Q-t12Bqv9973Y(^yWI}R7B^MzihaZFT#9|I>2^hCzIXfb zakukzx2vAm3*o76i*3xgo%Q(M(&a&;v1Fv(?Pf__7eDfh`@mvjuMi3=3AZy!?R7;P zpO4hLn$+awOU;7Yb^FS{k=IhudaCi2w!So$oSdtHLWwA_f|;El508@u>((YTY4zmL z@Y~So5#i`C%9RnFhDv2TLQ9kYqF7j10GpQN z)83bc3^Hliw}8_yt+D3VSqbYwu?YvXj6D&I5sYt}T{$Rn?&8UysPXe_`-%X+C-jpH(N z%u_o=QH7TwD_TCC1M<`y4#O~qIT9QVu+%^yh5~+J^GVIV;BA*y+x>E0V_cO3b0olL zt>!7jp$5$%Z=RrSIDZ~#Cj!$0cF)5V!D*8ZZ!cWwH||bGc9fVNpW?sb*x+}6g+4)#wmn@vSf$uOfV7Vz&;Lq<4l|7r*FAS}&yeETklxwa-3u5bIR zwOdzmBKC&JojBmvHV)TTjtM>aL0;7Sr=6LBVC%K`(&dlw9dGQ27|&h5W}Lic9N(Cm zU60PkXXlQsZ!6MhhAThmP=ZA&OUMd`6=)l?GL$z^EhC+2VzFF-`YnQLVyHY55E@L7 zVTd;7UEBo?xtb^G3k^uce#r~VglD)M!7-Gm5vsv}C#)ST0b7@p1~wR*xdeh#AgC0} z#%D;tx2G2poCTh|!AjB1VkHu5;@1#$L&>;bL1=YOQztPdGn6-Iv~LQ(wj3xis9j-o z8NwkMi4>TyPAu_{IMIR)qyny>Rd39l!5E2UBHCVYpbPto6(_|U8dr#uh6;ohni%|) z@FtMHF?x@AgVWSwUUya7v?F+`^d96(f$r&v-$Y`Eigbgk{^>TbRf`ez#za=Y%C+?| z!Hl;5A-K`YYcHJ!Px{&QU7~QOQTUv?^C6?KJiByxUT~l2toUt{zuVTM)%NXe_}3Ka z2F%&68^`j-9WeFhgokw{A^2l;*0{|$TtlGF&jv5uc?=REEtkE?aVX6ogu5ILl^&ym z&Un$Cn1dmZb;jo^Co1EMQv=iaQofuk!axkI3jUyw2H<>B3}*_Kp1~53exj&2Gw6j- z2mE*0@r3{x2)>kt?xWdI8Xh)}52c}!6KgY=U>Yt=$srM4@>nStlK(~sW?zwv=NPqt zCq7BcZ7zR;IWz^P?E)BLcENqKKJ)d}0uW(v&G{@|*AHSh6@7~7GDABq_?kGe_!=}+ z&DS9K3^wKQwMl5@oJ|AW8-J%ZcFch@koB`D~C;FnNJ$j^!eZ7f%~S`0P&uA-!j)Miee6BEhr zMaeCjVAQ16OZ^dx1ilvXw4yOXxn`Ftt_Y7z1=ei*fo(pPo{H8we)Ce>?qY@>e__kOmP;)Q{1F=UNNHB%itkleqk z7~4oRIwQ5t+pnxN{$w`V_~Qs7RCBS7)L!+ds38%7EsFqHErs|HytkT3ueEb0nh1F% zN;Q#f&@4t@n~Pp={AMj>Or>3;|BP?s*%w_FPwD~?LI#GJm@va-n}N;}q=t+z*Wi-M z!)OX+?itX6xmxu~$bc14W`KAYtKYmW;Bta9+`MjBTF7Yj2dcc4?APbK`~T zcoFV7FcT$Z0xnYMRc0;zK7oC=dK9%91~yhi2I`i%3NjER<~f<<2Bnhp#7Gq>2_X$d zxeDtO>37bNfEEpl+oxCGw}|i-pO6m-g{Ns9k=>28f@L_&3|h+za=z>3gganB)4HSd zHREMWu@ZSGL8j?O$>6K^dDu+mcO?fO$~8U`yK*JB()~=d+4$WhT3H1*4ik4z93COJ zW8(ogMb4tnxTynh7-8xDncJEA1V1^C+Y`;X*<>p2cE>hipNrJ@!L=US*t?Pv5APQb zHy(+&iNF1lyKm!vt~UPK?T*&F$psH@RO8!Ty;o81Q^w0ABYWH)US@UiBhPpZ@^WTh z5vE#8%?$D!3@NC^W@~#O6Ep}YV=}l}zaNhHa34a5KF4doHWfX36U;t?x|Fj7W1d?vRZ zgUlZjDHb%9m(}$FSQ}@(yGx1+xOLA%~`#pWnKegsLM`%sK0c zvb2XhMV4~ag%pJX@krD!8>5kO1?I?}_@WSrBrGUA=XnyT`}b>`>z7jMDOf%&1(V-^ z{R!_Ac#P7-RobcTr+xr_>ZmbeUlL)DX6|b2Gnd-FV_ezFVKX_obG9CjZ9Kg42NKG2;1KbRzgcbkl^c&Xz7rw;bZ2bi`4#1hW;vUT>~^~ZTM$3;OtXd5 zQ)~03F{wz53F}Yv@@Xh_*bP*ooj_|H(dN>8M_Y5L*s-H2`APBCm%#E~UTyrUOHn|y zAH8&^j(G~Icd$@w@g*HPl>eX^QW|@%!WdE-absV(a!`=KGA@b8V3;x~ay5LuEX4c+ z%fdm8!9w_qf`!P)3l>6awO>^;mlmrqgGe;CM$vNC2AkL<1%1PGP^IAm_Df*6(M?96 zNn5PfG-YS1Y~5jJ#w|Y~QUeeQ(EN-t-ej_&1ItPgJ~DU23PxItisrW95G1+pheL>Z z^ON*E_=AdUf+uuG{k~Z6gh)lR1450ewS=1$PkzcE*&fIbJKI-tcj-iM|C#RBUFg=pi?A{?NPZT!qi zN@knMg@3Oge+t@&3{BPJNMKVuU`Bd?M6V?ia1+D@+&Hm;60w1K%?9RgeHmf0&#qp& z^OD;UB|g*zK2Rn;;CC`po~gY!6dypYj4_$)(J}Z!3q>W}T2UeIv!5@7D=J}LqR^n2 z86Wbz;aDN|3wi4VHcA+G2p7Z|B*3<20Y)4fdv1bRGT>N27N8eo+EjK-EyhSOcHjtC z9Ds9~U?b^Qxw~h;XR8nw$a->hGv>6ZC!kTu3R+- z!oZ;;(*hc%hv&sUca5E9f3E6wC@P*mJcVC`;btZbe@#o~kv3WOAaAuH3 zPpPk=Sw)6{r8*(h8Y7QR?e3C_HwBsx!bI4XOQvJ!*0$M1d8nCd}DdXw7b;M+B!I^}sd*>3qLy6|yCWg@%U@K3~pPg6L!z}s)C zOU4RKZi@*)FSgL%`l?KdYBu(<=6&nx!*f5z)$p@(Ji=tvVM_?60lVedi$toZ$=J1# z2U)~hvLRuEG|XjIEOr#Rc~wf@#b09jVuL-UUI~f;f%^lWpd1H8Nt^ATIeQTs>#?gI zdmGZu`}*zyDu5kiW~bF4^Q`OmuNq{f@R47fsaMQA=#d{d=#Bj;jQut_)ck`%9{a*r zHu3VzOLJ`E1O_`ROD?~^Ic5y^(=_rtG}$ugh%ICNRNR?K%p`h4<{`Ff`2uZ(DJ?GaPr2p!3hg-ud!h%} zf$9}f!imffXVsk;^r1ZFt$%8<#HpY3=#c05zzRAZ+13`}K`-;10ZU?~`|<8mB1XtF zW0$Wk@l5fI3rCFR&;4%MJ zAY)RLGQr!6^HmX;BZVO_*py?;uQO9XTGl4R6i8>F5uisf^!?lYA?0XfG5Nu5JR3ad z{7102{W~HUPs)zKwDYVBT5;fFe{%j9>V*^D=1#_YF|pC$i8nEye+NDrUWbZrsC;fI zxX4lq=5rf9HySdJS}_`*hcrQMHor0wv)8xtFbMzJcbMA5@y+kueq}xO(rKo`9N)x; z!8E5m@l-NuXF|mUWBNF^B96HRcA)GP+oW=1vz~vJtQM2^C?8@PYDqayiMoOZ$>~DL z+6JY%sGy)7f1!OD=8k(t+)yAJum@$*Hb)SJ4CLUU+R={_%!yFiaEwGtw~Q1AuQ7y5 zyiJ6-{;nZz$Tx$?m)fQl-VDDn;T9L?OPG%Z>w<*g0OJRBdU`6(z?;1%C|+tP#yC;C zSQyR&(NZV&zCg6JQtOm}9fxX<)_QA$wM=bjv0bE2?^;^qg?VasRUX9E!9E~T0mq|L z+?c3|2+5{VJW_<>(ZMJlgx?{sJc1}5`*@2?2P1j(NF{{} zw|mbll$-F)B9dPMqKME)l&~Q*5?yZv?RbomPL$#5w4H%RcsFZRtlr)Ol;mIU&Jjw{ zm&Z=$_QVlp9+zh@bf4MQoVoYrEw>ANfl}$UW&n%Ekn)~l5X`GrdI1bS;{i_lgn71Q z&=Oj+Aw)^qVVXJqyNy~xjd`nC&^~1rh(rdW7o|M_qQN7H3P{D1QvtjLBI}@>18w^; z6z&({(BCI6q|tibQ0)_N9UTD^wFMwl$d$(q3ob{rWu z!GwVBBO{^`p2aJW6J$nDGO(0Q>QGKE7C~B;P_B%>h+t4cI7~~Nmat}gzP0nw!hq)8UJC8za9Yeqb?zTrQE4NFZAN%E-fy5%2}b_LqaHR@&g7?BcNYxNe{QDD&Ug$f zO`t*6!bfVJU9c&{A|=2vAY!jxjXc1%nhopR+Q&zFpdSSSg9r>MOWO;ZNC~Ecsnd!v zv}6-wM}Y*BX{c>l)Nh&Yt-x~_1A=u-QuYk+975Icz;h(7j?`c!t`6(4pfyq&r6CPS z5u*=K?o92K^-g&sG&@ssMQ9?H?Ie^ko=vtvw{n>LyS+*0;Ypc+voguXp~A*V{i%&1d3(;pu!Er_&Y z$c^b#^z}wQf4O7ooB8QDLGVmXC-C!nV{ke?o$z7tIDn%8#*M(@dEGS-Z*I(Ehi)h1 z?R2dHiU3$VU5vNW`4(C%A#1tgO^Mahz2|Be#X5j_eb3Q z^2O2XZh{QbRZcLKp-lEAaPC!eAmSeIs_{zuFs^-STp2vb=MuagKoqa>0UAzdbkjM5$! z#6vVT=qT-ZwK(G_62pBZQ01&9MuB*07eK11HVJFYY;yz>$!>E5s)es4(B=sEs@;nb zSm3ga5%^=RHiltt*);f*(w!sNqOR^7fqPKhISlug zDj!BFf>#c;f}SIsE_Ho~?giPA2Vn^0sg5bpgVZYn>IYlnd?g51`%0j3YgJh)@=9&z z`K^#w!BX4dQ#2kSpOjSUSrdc{`mP8~7C|ViKjFUEN(2GM2IB^)w&DDS_l=9p&atCk zDjDqP=R0)X2gmYRBYk5UDb6qZfhgFoJOu54-BJ<$8%45t zt@G+yt?TNuwSBeDWbgL5*BIvMSmZ`AcJ*=i-@9tvLMeG5`Jo40+W1f+9H;?KGD^iR z|9EYGG2*5o>#sq%=Ds)pzwO*t{>@6IY)qboVdCzTR{X5FQmas{Mw$pOVfF)c5Um_qiSV zUTl3qQv5IBa_3&?YAJmMwcx3x*uS7!W~q|T;Vyu%9H{r~b$i?{eQRvv)40^V*XVyT z(&6^8u3HyB@=V)U8rEuml)8NYX{s}k`hg}j`kR;T{1i6x9Ju|;r900;|Kj(G)}2dt z9+ziydtKdr`JdqVIlB3$t(#X7lYw<62{M3$mBCJC?U&6!%o~1I&oN88;(X=GGn+v~ z!?;9@l{Ur&Y&4Kin8-lag13G@Qscuxvof$#Lsy`536mlv}r3P|hElSDcC-S2(qmktV9>%h+0D~}nECnLLD5znrRA9<#^Zt9x2 zU1Yg5MPB6T;yj?Xpd7dvsIm`2J62#Wq?!E&s;sLeQ zm3nGcpq!k3{!Vf-;iiN<`6IVGRga67N@6K;7hHj+E-tJI;ID`)perIpd44xUE^K;W zp<)i79!R!qjplgR__Aut7%Tl)NW&}GkL{5Aq~p5~DnoA9+)dZHS?{X%G_e!3+wH-~ z?4zBaofsLyfQ06B>CSey2NJf~_}`#n=o_{{Hsm)nhhW{3{s-KDBX5*4IFSBtlz4g5 zSxTbg2SgxUD5v@|6mq-CEKnIOGck*dCU32XmcW3#5?z(lToFnMOF$xQZM!9M-dZgY z8ZY-XqdHA!XQCt|1Hx~;(hdyIT!fm;-`{}_=WjO+by`dCklZSf$&QgW#I%{oj-fZM zkN^)IdZ+*}cRg@2bNqQ2G4zHsvB1mppoXacTd^9ma1t;hM4q_~V3tKfzeFj^BGb|I zm1beq%RGWCWlDN^QCZNV0zHF2LSLW_>*@jsNGsME48OL2D3#t~&S^4L4OwRJOd(^) zEiUy5bW(LnnT#}!5?i0#*`#bpu75YH(RNK+;R|k*{%D{yNG{|BOfYL^xU>%wpCfH4(VZhYb%my8moCW!7Y)6E^{m(o7d-Qr^yP&36cxg|{ zR3?1sC?OB|)i-x69pKD7`HuyqmbmI#)g<_K;HuT+(XL1`w!^&Tnt5`)IA2kW9TG*5tJLL(P(>Hnm5utOF1WZr#Z1Su=ITvJO*5^dDujz zQUedK<^ZsCJd+rLMfVsQ8FBjiM{aA`alKB6Yn#f~yM)}v+JzsujrJiRXI%>#NH9Zc zc$OkmS6{I*6odO8;eQKKRtufp!@PnMwdK$V9*dz@Joc^zKma=FJ;^8oz0~uMxxd$! z`IH$6&iH?~2H^I}rM7<>2I2NX7=+u$0pTVfCf|4m5N;C7Z5JGMo5XT6VBL(vFnqU1 zU;tANq@U%HgFi@w^qHEFQfOqs(pCs@z`hn(aNr*ySa4wtq(kAp)3AV*`^Jy*2Azep z7T9`(sng;v)M_r707VJ9r+9{DdKowdO|F-L{;1g=;l_D43}JQFnuHxH{qU@QH3s;?tt;Ik8RgdR%irIUzY@merLoh%H=|akT28T>b#Jy$OPHI@^#$mEImXqLn zITL*E+DvW@;Cr(G-?PB^g!F!+=X!y``R4rKeDGz8u9@I`foLFNWdzQL;jp8G*!x4} zTd~_9)lG{G3`rSbfiY95U24cohvNb}9GOa(Vwl22CV?0&Ghd1C;Ct^@3cV(P`;9k4l6_*(tjk{P8kwV-fGN1^F@bTRMd3~D9 zG$ZQQjd;tSAm-OiF+Vufej!4Ezszb1<=?6a^dMYz@UdKct5#ZN>fnLo)I;;JjSnY+}79|LClX@_(h5sq75Ju%Id`rJYk)TOxWe7 zC`09K`fOH-NsIq@_=NEO;ZnTTC8LY;(HjD$5Di|sbFS89kfYs%|BP?cG%laqN&yI) z93O%#udJ(oN!Ud2b)R_~ zOk}uk<;Y_nLNmhVhKyeR?9YNj2Wwqvi?l5k2Abb=Mf;i|;Fcr&4DD&E;0#_mfvgCx zoR77bidXcXcf*yH+c-DAVPYQ`a`c@aHj`i8lN?Ot8lQ+=`NlYK7q>MVUyNP(yo6x< zMPMp+HIsu6k2enBu#-Mb}ziC zMi=7N`|G__dd=MrI3#Z9A`7{Cuj{<8@z-240XKHz8-K}EmpcHq1vHhxru(P>Zsb<> zi&hA@u^X^#g95m5AX*>5ebM@(1l*`Pa5c08U!e}f@6v&N&H1@abzt8+=s+si0la&U z7~q*Aper{q0zLQYz^i%$a(W7Q1Ud|gNk-o1X2fKOA9=>CnnNxtGVsK6bps9)WSFtP ze}odt^e3CK>U~ZU_R){P>hzT>=g9~bh;fOW^dn%$LB=`+g@K#Q!rtNo0(0Yo(2dkc z3JX?(I)a6!!{2l0LkS7q8R~+BN)o&?%-I9BNZE=e+xM7^G*TdSl!pgf#>M0Kt4$b}6IQ900!)|n< zK?Sf}SzM1D+Y_$}OVFicA>XAgWL)pcSU(*XW8Kct(CB;8&q ze)vb8X^xkwcg*24fV#Er#s^El;Og1<_p6Po?!G9+(H-O|T~uwjE2Khqyj@Q%QEIx{ z6c7gV>2@&2Uy3mPfcFQGzY?In2=s54Li}XFubz$HTW$QV(by+xPn|#FL0jT%O-%X+ zXoIt6&h!-sgVTDBZNk0ul`G~C?I9Q0SdBH+NID>_oPuT^9 z+wZR#C)QD*W>QbVpMeiX3_^S3Bn~KTSko0`;G**>nHi*<+>N!+o-oD5A)2)75h6)* zV{*@Uo6#z?eO|M0{W%{<9Ko{*??`^+F~GFN75Vtqtz9Haa@F}s&D<1L6gb%T7aTM= zkg5|(1bKVC?+FpAo-|eG$d6D$e}ob$zKsgyG{6fe|2I&G1@?|nLR-?cSfAeypwM8G zn!&siuApmyZu3KA3`RdRZ_tIr9)fv$aA!;Arth>Anzq05L5gn$MmRaXa~9aaGb^vH z-7xf=O{D5!a~vU!hrkX0!D{0Q;D&!k!42nGuZX|>)Vv#4N<}zwaGbP?QY-xM&W%@B z8-L*81~>j0)J{k;+o?+#47My)u?9#*txKeB#lX`g?2Icj7YoXOPm_R66Igl9=7m0d z^>#-+`M4!GV8Z!sg%nEQs=8K!O!sL5v^nYCtBy8%$8CbEd=wq?{{hTbKk#`ngaWfT0|El-&0 zHX-L2?+5>!vU|ZQ6yCa}EPNC@JIwS``Z^XHG)ZH1-{+wM5SG8Yl7}B63u6yHCJrM- zf2X7;wo%~klo;(KBMH|L_KNtCXO_LvECP$T1N%h!u+1X20fU8&ho zjW6)VioV#!KT-xur`)H@af(Nl+!R?P(njfI8-~&1TVQVlB0PY%mz+)WrWgK6*GD2u~p>c_g5O}JCydyN33_jxEoj*Y2V*2t+ zD@!ATy?G{ov9lR`L@)IQ_)8QsQJ6p4f+4sr;zvda__^jd7<_GjARJ+`pRGb2n|!YY z28WW;o{NaRCO;%}U$eiS+l@lN?`3pfv(svjeMyCCkUe*l${w`bIi3*(e;rq#(SDbZ zKDC`ee5y-Oq6dGHg?XebU*R)GY4Kpc=<195lw+5Wzx6Ni+lCbTLgFQWQ#t2 zjQTh(x2npoC&XugR2`XFD%}2;7)g9bVSGI{u_rEXx^8|*;Y|d?Xm2~R_ap@Iy$9Gp z?NGxjj8t?{?6(03yRqGd_qJksV)b>kTg7XT;?a~&{=B|qnn}h}v7L@__g#==s{{xH_ zNjhZb11rD}BbY`8uYEtkWZS4X{#|UaUhF&G1xzr)R57z@((q!IT$%WoD_0yqq{uVl z8^v(Wh(e@!g7wM#DQmwHeS5(!0RL0yV!-M0&~g!klF#b|Cm3b=B$%7$zklm~3u|wb zbp9AA&jj}EgN8tUo*&-x*X#9n+jnZmUDq!VSS74{RS zbXX9Ymh^sNzlbC?A)DayQRk#PY1afiqt=2XltQoiyWuu;P@=7%Lh~=_1S#wUc%{m^xD!35PBnh_K*#3ft5P z4PI*3NO|Y>wbKrX4>l8!;Sxj@?m;qO3W~*-3kyI!r;in><-j<&SUGx0kZ_fFTJ!-y z-2>?UlmvJG`!U1%sR%OcJ1>5!VqdyJl9W=UyJrcEkAwKs^3g_H4vKHd_`mXkRStDb^IhmN1`qYvuFYDhSaDtZ+qZ1dh54CHoCPmm5Yu3cL0I}9 zn2NWjt%dp}SSBU-NRCNq?qb%xMNI08H@ut*63)X!U96OEa_c$gfym~5kdfZ-{woqh zk|)igsmO3HjOwUGV1JGe0GJAgq$^lp{K3cHGpH&2Pz7m{L%Zy+!BQ?VX$G;4Reb){ zc=+C*2|&8B_xaa^47JQGF+b!Fydv$3zWACDfm`pBkMoGIbZ&fcwegA%&~whjp6!B?&p0(}_BxWwuQxN(qOB8CtwL?j_t2&*Sph-G3f zn($PNbnqLE6fN@B0Cwnraf+{m_~f`)18lX)1%)N<7pw}9btu+3A#Veu?ra5djmEJxbJLc@)ZTTd5C zu(149{E&=dkb&MrLL|Iplb9YKuynkw7{vUvwt#)+u-7$_zGrPW+B&bcOkuX!bd=At zgU#?BTf(F$=t8K2Pw(`rg8-#W)Kay$(C8irv3E;k*$Scp9vi?sIG5YDcROr*7fupk z?*gwB8&RvSLvXiRYa@qtU@s3W_n?jMece&p{UPINEJ@)>HSFThj|uxhCIL`n4Ha}8 zGPHmbsfSN|dPe0%x4lJaL?Onofd-kZ>@=*>j~mBNlCXIQpB@JgR{~kjUw1o}VqXOU zRir?sZpRJacEy3=2#Z+V72B9~JD%D*@3VAwyJBZwUHr&1)~a}(G%}<3fH<ife!jO^~TeP$ssPYcO96J0lI<#Sk2x&Xoq6@s)eB29m+J#Ih!IO9eJL z1SJS0U9b?go*`CRSgZuM5wZvgoLFgJ^aV>JMHl?VTVy8D-OV62J-X>Bn}Nj4<{_!rJ+w!I%& zniom`r1!;1?M#07OZfkQQAI4U~Wad3#RU4cIIfh~MAgCFBX>XZIuYi6OT)|tZj<=hX zh`B<1+)ktq$b4>q{%qE-!@acBhOMu-&3kn;OY&?&Nb;997IfsSiq9*u z>`2_(lY@lPAPFJxU{fxLGT_H~XFeJN9uVKO#-gx^%K@R=(o6DGB%rpKIWhULJA57* zXf2wqpx^1Kz=x?!+I`1PnPA5h8w{GmX8hD6i641oNOW!4D-#@dv6O9}jGlKr-T}7^ z)`9v|rV5Sf)GYoS4x5W$a`b5&IL!j_(qD$zXl|$6=rBHiblUswkw9ksR;z;8W^TR`gnp!?_rJG)+Hi9i_AC&5F)5r zZ^23DI5e4ba^@LPF9O zu=kjpSi0J87=y`3be1Ra3H~dN_3~!GLUUs$3?oC4^E5w9x35@feo&8$E2R0s&m0un zSjWLa)6I>^#%hpM8#3F-QcyY?Xx%q`6w?bR0gB*xn?&IWWMSlr{j{xT1`ekpIi32k z1V?F8dVc|Xx#>)O9|oG8{PGyEi1Skbd%^IR=kTEt>IF1E!*7nMk%l`kdVUIF><5!i zZ_iymAie?iM%%aKLG)F5uW*l|5M_P{QzK{I0Z%B6_>uITH+(tx@@ow~9-F`n#g zhv`lz+p&#Nx9c*#zx5g-*kkL_Vth>rgdG8rhwGq6UuwF&rQ2721^b}6ee8+8bm!;huI|rm?2>j4yOCzezg-|RXNJt4 zIoLX6`9fDTd_eeMhqYhCfqLczwoW)u#=NuR1Q7+&w6IsR$cOVOepw&~w%Xf+MdQ^c zNS9SOUk#vOf61V~1cKkbNAN&O!>^We6LS-bzRhTT6?Hl68DSv zUfu)J{3R0qh@xXf;=2@ywI-iC@@bH22^jGp)|e(%gjtY?0b;GE@Xfi)Q!7u^ z;`ZLY@(qLR8ov^$9|8&ui1M3g0FPbyBEG%G?c)0)jbA9u-1@Q`FA%k- zXTDkZ#@uXC(e}#mS4*JxZa0pbJWqYg0?q*h(RR z%n1)}vO0rRCPfUm5kw57Q)0(h+jeMQlRz~QUkGg9N#cPfAIWrpcbdsf=Fur+nTftz z<7MNX-d7KPjC$}iwHeX}Fj=z?6{oN7kn_=xI__a zy|P#;y1B{41?N+%7go+*yx;(>a~?HUSC(INPMv-Jg^TFN`q`69&INP=C1=iGICQsA@Kd+m&%+-fkk%S+!dVpjDBH#%f*g(oxL@6ilX7x!$p5-m2^mvrMuc zD2H}a?DQi=(6K7^xyr3)=x(v@%?5b;lqj}pQv0)PJ=dyG-QwHAW!5e-{1sia_f|i3 z)*uW;7Y0FEbV22sE{Iap$CiyJ0yJV?(*~ZozSD%Tqfm?Yc5=6lPl&#hbl*FCdz_EXNYXU;34BytmZ z7%Ck@6O+u((BvWuY=Tfpp1wt?Rzq*~>-%tOS}YtDs#mZy~p}Vr7?04Mr7OS_PUf zlnPbkxglg-sw^Nw)Gd>KgbVG{MRz<`481m)p8!B~{>P6xlWraqI7Z4r0j|nPJWK1< z=_|t@Q=asyHS|W}Y5KICiAtZ7;G;gN=k2@wH#>c1S4vgx3<-aK$J%wzfKV@AYruh? zc2KG>KWUGE13wY2d_>ld5JHY(QBL3Ei*7Z~yxZusD(+iw@p*!L8K2w@{iU}P74-G7 zh|qPw@gN_t4kwJySk>^JxuT0>aCc@JVMfamDQ-GTK(!)@OE}x z*4z0mnQ!O2WWJs6lJRy Date: Mon, 22 Feb 2021 14:09:43 -0800 Subject: [PATCH 20/31] MACINTERFACE: first step towards renaming to MODERNIZE --- lispusers/MACINTERFACE | 2 +- lispusers/MACINTERFACE.LCOM | Bin 7715 -> 7588 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/MACINTERFACE b/lispusers/MACINTERFACE index 76123d56..2b9baacb 100644 --- a/lispusers/MACINTERFACE +++ b/lispusers/MACINTERFACE @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Feb-2021 20:50:07"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;75 21496 changes to%: (FNS MACWINDOW.BUTTONEVENTFN) previous date%: "14-Feb-2021 21:51:47" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;74) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP) (INITVARS (MACWINDOWMARGIN 25))) (* ;; "Internals") [COMS (FNS MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (FNS FB.MAKEHEADINGWINDOW.MACINTERFACE TOTOPW.MACINTERFACE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (specialized to filebrowser)") (MACWINDOW.SETUP 'FB.MAKEHEADINGWINDOW 'FB.MAKEHEADINGWINDOW.MACINTERFACE) (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 13-Feb-2021 19:53 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMACWINDOW [LAMBDA (WINDOW) (* ; "Edited 7-Dec-2020 17:57 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL)) WINDOW]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACWINDOWMARGIN 25) (* ;; "Internals") (DEFINEQ (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 14-Feb-2021 21:51 by rmk:") (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MACWINDOWMARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW WINDOW STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 3-Dec-2020 14:24 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:22 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:58 by rmk:") (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (FB.MAKEHEADINGWINDOW.MACINTERFACE [LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* ; "Edited 13-Feb-2021 23:21 by rmk:") (* ;; "This makes the heading window for a filebrowser, the little black window that has the column headings over the main window. It looks like a titlebar of the main window, our goal here is to make clicking in the heading window behave as if the click had happened in a true title window, so that corners will cause a SHAPE and middle will cause a MOVE. This is achieved by replacing the TOTOPW BUTTONEVENTFN of this window by a function that does the TOTOPW and then invokes the BUTTONEVENTFN of the main window") (* ;; "This function essentially advises the FB.MAKEHEADINGWINDOW in FILEBROWSER--works only if FILEBROWSER was loaded first.") (LET ((HW (MACORIG-FB.MAKEHEADINGWINDOW BROWSERWINDOW WIDTH HEIGHT FONT))) (* ;; "We also mark the height of the attached %"title%" window as the TOPMARGIN of the main window, so that MACWINDOW.BUTTONEVENTFN knows to look outside the putative region.") (WINDOWPROP HW 'BUTTONEVENTFN 'TOTOPW.MACINTERFACE) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HW]) (TOTOPW.MACINTERFACE [LAMBDA (WINDOW) (* ; "Edited 13-Feb-2021 23:27 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MACWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (specialized to filebrowser)") (MACWINDOW.SETUP 'FB.MAKEHEADINGWINDOW 'FB.MAKEHEADINGWINDOW.MACINTERFACE) (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4304 8063 (MACWINDOW 4314 . 4955) (MACWINDOW.SETUP 4957 . 6873) (UNMACWINDOW 6875 . 7254) (MACWINDOW.UNSETUP 7256 . 8061)) (8123 16305 (MACWINDOW.BUTTONEVENTFN 8133 . 13155) ( MACWINDOW.BUTTONEVENTFN.ANYWHERE 13157 . 13522) (NEARTOP 13524 . 13960) (NEARESTCORNER 13962 . 14841) (INCORNER.REGION 14843 . 16303)) (16363 17340 (MACINT-ADD-EXEC 16373 . 16797) (MACINT-SNAPW 16799 . 17338)) (17341 18300 (TEDIT.MACINTERFACE 17351 . 17969) (TEDIT.SELECTALL 17971 . 18298)) (18301 19950 (FB.MAKEHEADINGWINDOW.MACINTERFACE 18311 . 19518) (TOTOPW.MACINTERFACE 19520 . 19948))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 14:01:07"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;78 20371 changes to%: (VARS MACINTERFACECOMS) previous date%: "22-Feb-2021 12:56:21" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;77) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP) (INITVARS (MACWINDOWMARGIN 25))) (* ;; "Internals") [COMS (FNS MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (FNS TOTOPW.MACINTERFACE) (P (MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE) (MOVD 'MACWINDOW 'MODERNWINDOW) (MOVD 'UNMACWINDOW 'UNMODERNWINDOW)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 13-Feb-2021 19:53 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMACWINDOW [LAMBDA (WINDOW) (* ; "Edited 7-Dec-2020 17:57 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL)) WINDOW]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACWINDOWMARGIN 25) (* ;; "Internals") (DEFINEQ (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 14-Feb-2021 21:51 by rmk:") (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MACWINDOWMARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW WINDOW STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 3-Dec-2020 14:24 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:22 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MACWINDOWMARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF MAINREGION ))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 22-Feb-2021 12:56 by rmk:") (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN) (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE))]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (TOTOPW.MACINTERFACE [LAMBDA (WINDOW) (* ; "Edited 13-Feb-2021 23:27 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MACWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE) (MOVD 'MACWINDOW 'MODERNWINDOW) (MOVD 'UNMACWINDOW 'UNMODERNWINDOW) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MACWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MACWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MACWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4238 7997 (MACWINDOW 4248 . 4889) (MACWINDOW.SETUP 4891 . 6807) (UNMACWINDOW 6809 . 7188) (MACWINDOW.UNSETUP 7190 . 7995)) (8057 16239 (MACWINDOW.BUTTONEVENTFN 8067 . 13089) ( MACWINDOW.BUTTONEVENTFN.ANYWHERE 13091 . 13456) (NEARTOP 13458 . 13894) (NEARESTCORNER 13896 . 14775) (INCORNER.REGION 14777 . 16237)) (16297 17274 (MACINT-ADD-EXEC 16307 . 16731) (MACINT-SNAPW 16733 . 17272)) (17275 18358 (TEDIT.MACINTERFACE 17285 . 18027) (TEDIT.SELECTALL 18029 . 18356)) (18359 18799 (TOTOPW.MACINTERFACE 18369 . 18797))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.LCOM b/lispusers/MACINTERFACE.LCOM index 71a2a9eeed84acc4a890206543d6d9b489b420fe..c01be2b83571d4cc166bcddd0e1eb550f0101e16 100644 GIT binary patch delta 801 zcmah_zi-n(7>!eP0Lh3Zl?iE)K1BjKL#^130P9AD7j;6=M@c@QnDA{3u6rO@CC}7S;Bk)fr(QFE7 zB|#8M(CDK$+JsVt+$R`%naEic1lGJ_0V zx0c%{gZ#dWvZ_j2Tls8FPL67w9@~tvEavo==+v&|7;aba5e_`4!=Zsp%Rz=mLs6?V zkA;O+U|~?ybXAovDj(70SZ_8#s$YY|8XT@9o(34Z4(cEWn+{YdyqQRoFZulY+}HR= z{&|)-9LIXV+iu4Iz7@EbG`Yfjc|pKp7rS0puw4VS9qRy<%V{S1mxbc1mKAjsaGf1E zm)S4*ECmzwzb*8|K;($y$XiZkSfUpSYuW6rHIW6Dv&t%SWlnm81$$8r}>8Wi*BX-Y~C)85kZ;;-U$*lZu)`OEry~ zF5ODr+LaoA09%c5(Vc(7zu?+L-+*l)nOVG?d)~X}+)q?_$>3M*brn*&*@ggXg`@Y@_%yEo_a=0sjj7%-E0kC!D9DGD3qGVI z`;bLwXcdQ;Rm<^YJ59c*QvCn0)gcse=dKSXrF`kfvxd6DHq zKf-!>qoHkM18Y@c)+TQ3PbhY3I6y!K-7+Z$5*V1&3=bl3NR=8KWua_aP8-|P8Pg!# z=W$#uY30gIfqy|!F!nt#ITk%sn!pzmY%B{Yxd_b;o%T0vs|iwJO6+)BPnb Date: Mon, 22 Feb 2021 14:59:33 -0800 Subject: [PATCH 21/31] CLIPBOARD: Added xclip as default (non-mac) stream names, added .txt file Other platforms may require different clipboard-stream names --- library/CLIPBOARD | 2 +- library/CLIPBOARD.LCOM | Bin 4556 -> 5112 bytes library/CLIPBOARD.TXT | 17 +++++++++++++++++ 3 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 library/CLIPBOARD.TXT diff --git a/library/CLIPBOARD b/library/CLIPBOARD index df4a12fb..ad645445 100644 --- a/library/CLIPBOARD +++ b/library/CLIPBOARD @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Aug-2020 15:48:08"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;53 7823 changes to%: (VARS CLIPBOARDCOMS) previous date%: " 8-Aug-2020 15:25:18" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;52) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:56 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 8-Aug-2020 07:56 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1216 5170 (INSTALL-CLIPBOARD 1226 . 3048) (GETCLIPBOARD 3050 . 3649) (PUTCLIPBOARD 3651 . 4126) (PASTEFROMCLIPBOARD 4128 . 4745) (LISPINTERRUPTS.PASTE 4747 . 5168)) (5171 5930 ( TEDIT.COPYTOCLIPBOARD 5181 . 5462) (TEDIT.EXTRACTTOCLIPBOARD 5464 . 5928)) (5931 7470 ( SEDIT.COPYTOCLIPBOARD 5941 . 7468))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 14:39:46"  {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;48 8988 changes to%: (VARS CLIPBOARDCOMS) (FNS GETCLIPBOARD PUTCLIPBOARD CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) previous date%: "15-Feb-2021 23:48:39" {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;47) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 22-Feb-2021 14:23 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-PASTE-STREAM)) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 22-Feb-2021 14:38 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-COPY-STREAM)) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 15-Feb-2021 23:43 by rmk:") (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;; "If for some reason TTY process doesn't have a window (e.g. TEXEC), we can only do the character printing. Presumably the right thing to do--no image objects in an exec.") (* ;; "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string quotes.") (LET [(STR (GETCLIPBOARD)) (WINDOW (PROCESS.WINDOW (TTY.PROCESS] (IF (AND WINDOW (WINDOWPROP WINDOW 'COPYINSERTFN)) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) (CLIPBOARD-COPY-STREAM [LAMBDA NIL (* ; "Edited 22-Feb-2021 14:38 by rmk:") (LET ((OST (UNIX-GETENV "OSTYPE"))) (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbcopy" "xclip")]) (CLIPBOARD-PASTE-STREAM [LAMBDA NIL (* ; "Edited 22-Feb-2021 14:23 by rmk:") (LET ((OST (UNIX-GETENV "OSTYPE"))) (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbpaste" "xclip")]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1376 6335 (INSTALL-CLIPBOARD 1386 . 3208) (GETCLIPBOARD 3210 . 3832) (PUTCLIPBOARD 3834 . 4336) (PASTEFROMCLIPBOARD 4338 . 5256) (LISPINTERRUPTS.PASTE 5258 . 5679) (CLIPBOARD-COPY-STREAM 5681 . 6005) (CLIPBOARD-PASTE-STREAM 6007 . 6333)) (6336 7095 (TEDIT.COPYTOCLIPBOARD 6346 . 6627) ( TEDIT.EXTRACTTOCLIPBOARD 6629 . 7093)) (7096 8635 (SEDIT.COPYTOCLIPBOARD 7106 . 8633))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.LCOM b/library/CLIPBOARD.LCOM index 3d96ce94d2a6cc431cc00d15a66b7900087aed8c..4fe0bc17dfff199c7e7a39757c956db307d70f77 100644 GIT binary patch delta 1441 zcmb7^&rj1}7{|9^U_&dNS&#$|Pf7+GvSsZ$=t{(lu7ly$mbLtt@xaCwvShHap@IjA z(LX@)#=9Pj9*xAS9`vZ3Jo*QinCO+8KJ9QnFbi^M-}d{yef#---{*Zlj~tIZO?x;l zkSOK@T!>?V<;8GRQr;%B6fQSKFJBQb}!Ajb-A&X#y-9!FZZ7l5?XV}`(Qeu?Z@u0w91hYOW=Fqyd;7g1(^lt)H{Wc& zhyb&<^sFw;$1;){mmz}x!zxcIx}3=y!1HE+jejqpq-9h@io%>CS;JW#P?BU_51s%< z!7#GH6A@Es&mX;pqpkUkghIYte7)K<-BFVmfayO3s&1g&>vnWdF>N%Q+8ZzPma}J8 z$CFk!ZS!HBJ#-H4o0WrsX{ruUSW=R!0VI-@Wk01PQNz=E}omVnyc>=yW<+uy_1y3xUY`ZoNs_3De22~djKUb{$m z!h;~IlA`j;LGwmxw-W{}zvmsio>-8@0&p;2)Pf!gc@&~bP({MQR?lnscZ1HZw+*cK zAn1kDDs=t+PN&<3P8TSjm|7j2Q7V-<*lzYw&kgo*wn$W&a0NEMSgjelZD_7hIU|Yz z>7(TIAfY9Tz|JW|gw{^8+x9}}`^b@B(`*OyTGc9>nqAS&6{i3}&%598_re$gMW-o< ztP0A(y_v!LlQKE{l6-S+NDw5tGjbH?jnvJ{xCaY(2n)bmPcjVS<6_eEQ);#-@i Date: Mon, 22 Feb 2021 15:12:52 -0800 Subject: [PATCH 22/31] CLIPBOARD: Delete old versions --- library/CLIPBOARD.~21~ | 1 - library/CLIPBOARD.~22~ | 1 - library/CLIPBOARD.~33~ | 1 - library/CLIPBOARD.~37~ | 1 - library/CLIPBOARD.~40~ | 1 - library/CLIPBOARD.~41~ | 1 - library/CLIPBOARD.~44~ | 1 - 7 files changed, 7 deletions(-) delete mode 100644 library/CLIPBOARD.~21~ delete mode 100644 library/CLIPBOARD.~22~ delete mode 100644 library/CLIPBOARD.~33~ delete mode 100644 library/CLIPBOARD.~37~ delete mode 100644 library/CLIPBOARD.~40~ delete mode 100644 library/CLIPBOARD.~41~ delete mode 100644 library/CLIPBOARD.~44~ diff --git a/library/CLIPBOARD.~21~ b/library/CLIPBOARD.~21~ deleted file mode 100644 index e6a179c9..00000000 --- a/library/CLIPBOARD.~21~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Apr-2018 16:07:41"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;21 12278 changes to%: (FNS FILETOCODETABLE FILETOARRAYBLOCK CODECONVERT) (VARS CLIPBOARDCOMS) previous date%: "25-Apr-2018 17:56:28" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;18) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (NTHCHARCODE STRING I) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 24-Apr-2018 20:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (LISTP SEL)) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 25-Apr-2018 17:56 by rmk:") (* ;; "PRINT UTF8 sequence for CHARACODE. Doesn't do XNS to Unicode character conversion, just does the transport encoding.") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 25-Apr-2018 17:23 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1323 6343 (INSTALL-CLIPBOARD 1333 . 2706) (GETCLIPBOARD 2708 . 3192) (PUTCLIPBOARD 3194 . 3706) (PASTEFROMCLIPBOARD 3708 . 4325) (TEDIT.COPYTOCLIPBOARD 4327 . 4608) (SEDIT.COPYTOCLIPBOARD 4610 . 5918) (LISPINTERRUPTS.PASTE 5920 . 6341)) (6344 10759 (UTF8.PRINTCCODE 6354 . 8236) ( UTF8.READCCODE 8238 . 10757)) (10816 11984 (FILETOCODETABLE 10826 . 11711) (CODECONVERT 11713 . 11982) )))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~22~ b/library/CLIPBOARD.~22~ deleted file mode 100644 index 04ed7e7f..00000000 --- a/library/CLIPBOARD.~22~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 5-May-2018 09:46:37"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;22 12280 changes to%: (FNS SEDIT.COPYTOCLIPBOARD) previous date%: "28-Apr-2018 16:07:41" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;21) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (NTHCHARCODE STRING I) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 25-Apr-2018 17:56 by rmk:") (* ;; "PRINT UTF8 sequence for CHARACODE. Doesn't do XNS to Unicode character conversion, just does the transport encoding.") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 25-Apr-2018 17:23 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1259 6345 (INSTALL-CLIPBOARD 1269 . 2642) (GETCLIPBOARD 2644 . 3128) (PUTCLIPBOARD 3130 . 3642) (PASTEFROMCLIPBOARD 3644 . 4261) (TEDIT.COPYTOCLIPBOARD 4263 . 4544) (SEDIT.COPYTOCLIPBOARD 4546 . 5920) (LISPINTERRUPTS.PASTE 5922 . 6343)) (6346 10761 (UTF8.PRINTCCODE 6356 . 8238) ( UTF8.READCCODE 8240 . 10759)) (10818 11986 (FILETOCODETABLE 10828 . 11713) (CODECONVERT 11715 . 11984) )))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~33~ b/library/CLIPBOARD.~33~ deleted file mode 100644 index 2ada3b0d..00000000 --- a/library/CLIPBOARD.~33~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Feb-2020 10:08:32"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;33 21122 changes to%: (FNS PUTCLIPBOARD UTF8.PRINTCCODE MAKECHARCODEMAPS GETCLIPBOARD UTF8.READCCODE) (VARS CLIPBOARDCOMS) previous date%: " 1-Feb-2020 18:01:03" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;32) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:07 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT (CBMAPCCODE UNICODE2XEROXRENDERINGMAP C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (CBMAPCCODE XEROXRENDERING2UNICODEMAP (NTHCHARCODE STRING I)) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. .") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 3-Feb-2020 10:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DEFINEQ (MAKECHARCODEMAPS [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:03 by rmk:") (* ; "Edited 1-Feb-2020 17:45 by rmk:") (* ; "Edited 30-Jan-2020 23:03 by rmk:") (* ;; "Clipboard is UNICODE. Uses an array for character set 0 and for any other highly populated segment, ALIST for relatively unpopulated ones.") (* ;; "Charset 0 is special also because it contains most input characters in both directions.") (* ;; "It sets TOCLIPBOARDMAP and FROMCLIPBOARDMAP each to a pair (array . list)") (LET ((TOCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FROMCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (TOCLIPBOARDLIST NIL) (FROMCLIPBOARDLIST NIL)) [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (IF (ILESSP (CADR C) 256) THEN (CL:SETF (CL:SVREF TOCLIPBOARDARRAY (CADR C)) (CAR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CADR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CADR C) 8] C)) FINALLY (SETQ TOCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CADR PAIR) 255)) (CAR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CADR PAIR) (CAR PAIR] [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (IF (ILESSP (CAR C) 256) THEN (CL:SETF (CL:SVREF FROMCLIPBOARDARRAY (CAR C)) (CADR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CAR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CAR C) 8] C)) FINALLY (SETQ FROMCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR PAIR) 255)) (CADR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CAR PAIR) (CADR PAIR] (SETQ XEROXRENDERING2UNICODEMAP (CONS TOCLIPBOARDARRAY TOCLIPBOARDLIST)) (SETQ UNICODE2XEROXRENDERINGMAP (CONS FROMCLIPBOARDARRAY FROMCLIPBOARDLIST]) (CBMAPCCODE [LAMBDA (CHARMAP CODE) (* ; "Edited 1-Feb-2020 17:49 by rmk:") (* ; "Edited 30-Jan-2020 22:47 by rmk:") (OR [IF (ILESSP CODE 256) THEN (CL:SVREF (CAR CHARMAP) CODE) ELSE (LET [(CS (CDR (ASSOC (LRSH CODE 8) (CDR CHARMAP] (CL:WHEN CS (IF (LISTP CS) THEN (CDR (ASSOC CODE CS)) ELSE (CL:SVREF CS (LOGAND CODE 255))))] CODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) ) (RPAQQ CBUNICODETOXEROXRENDERING ((146 39) (160 61217) (166 61291) (168 8994) (169 211) (170 227) (172 61290) (173 61219) (174 210) (175 9086) (180 39) (184 203) (185 209) (186 235) (192 61729) (193 61730) (194 61731) (195 61732) (196 61735) (197 61736) (198 225) (199 61741) (200 61744) (201 61745) (202 61746) (203 61749) (204 61758) (205 61759) (206 61760) (207 61764) (208 226) (209 61772) (210 61775) (211 61776) (212 61777) (213 61778) (214 61780) (215 180) (216 233) (217 61791) (218 61792) (219 61793) (220 61797) (221 61803) (222 236) (223 251) (224 61857) (225 61858) (226 61859) (227 61860) (228 61863) (229 61864) (230 241) (231 61869) (232 61872) (233 61873) (234 61874) (235 61877) (236 61886) (237 61887) (238 61888) (239 61892) (240 243) (241 61900) (242 61903) (243 61904) (244 61905) (245 61906) (246 61908) (247 184) (248 249) (249 61919) (250 61920) (251 61921) (252 61925) (253 61931) (254 252) (255 61933) (376 61805) (8594 174) (8592 172) (8593 173) (8595 175) (8712 61258) (8713 61259) (10 13))) (MAKECHARCODEMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PUTCLIPBOARD]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PUTCLIPBOARD) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1582 6951 (INSTALL-CLIPBOARD 1592 . 2965) (GETCLIPBOARD 2967 . 3629) (PUTCLIPBOARD 3631 . 4248) (PASTEFROMCLIPBOARD 4250 . 4867) (TEDIT.COPYTOCLIPBOARD 4869 . 5150) (SEDIT.COPYTOCLIPBOARD 5152 . 6526) (LISPINTERRUPTS.PASTE 6528 . 6949)) (6952 11504 (UTF8.PRINTCCODE 6962 . 8872) ( UTF8.READCCODE 8874 . 11502)) (11561 12729 (FILETOCODETABLE 11571 . 12456) (CODECONVERT 12458 . 12727) ) (12730 17725 (MAKECHARCODEMAPS 12740 . 17034) (CBMAPCCODE 17036 . 17723))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~37~ b/library/CLIPBOARD.~37~ deleted file mode 100644 index 7b0728d0..00000000 --- a/library/CLIPBOARD.~37~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Apr-2020 12:18:20"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;37 21262 changes to%: (VARS CLIPBOARDCOMS CBUNICODETOXEROXRENDERING) (FNS INSTALL-CLIPBOARD TEDIT.EXTRACTTOCLIPBOARD MAKECHARCODEMAPS) previous date%: " 3-Feb-2020 10:08:32" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;33) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD SEDIT.COPYTOCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (ALISTS (CHARACTERNAMES RSQ LSQ LDQ RDQ NEQ)) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:07 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT (CBMAPCCODE UNICODE2XEROXRENDERINGMAP C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (CBMAPCCODE XEROXRENDERING2UNICODEMAP (NTHCHARCODE STRING I)) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. .") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 3-Feb-2020 10:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DEFINEQ (MAKECHARCODEMAPS [LAMBDA NIL (* ; "Edited 19-Apr-2020 11:43 by rmk:") (* ; "Edited 3-Feb-2020 10:03 by rmk:") (* ; "Edited 1-Feb-2020 17:45 by rmk:") (* ; "Edited 30-Jan-2020 23:03 by rmk:") (* ;; "Clipboard is UNICODE. Uses an array for character set 0 and for any other highly populated segment, ALIST for relatively unpopulated ones.") (* ;; "Charset 0 is special also because it contains most input characters in both directions.") (* ;; "It sets TOCLIPBOARDMAP and FROMCLIPBOARDMAP each to a pair (array . list)") (LET ((TOCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FROMCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (TOCLIPBOARDLIST NIL) (FROMCLIPBOARDLIST NIL)) [FOR C XC CSETLIST IN CBUNICODETOXEROXRENDERING DO (SETQ XC (CADR C)) (CL:UNLESS (FIXP XC) (SETQ XC (CHARCODE.DECODE XC))) (IF (ILESSP XC 256) THEN (CL:SETF (CL:SVREF TOCLIPBOARDARRAY XC) (CAR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH XC 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH XC 8] C)) FINALLY (SETQ TOCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CADR PAIR) 255)) (CAR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CADR PAIR) (CAR PAIR] [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (CL:UNLESS (FIXP (CADR C)) [SETQ C (LIST (CAR C) (CHARCODE.DECODE (CADR C]) (IF (ILESSP (CAR C) 256) THEN (CL:SETF (CL:SVREF FROMCLIPBOARDARRAY (CAR C)) (CADR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CAR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CAR C) 8] C)) FINALLY (SETQ FROMCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR PAIR) 255)) (CADR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CAR PAIR) (CADR PAIR] (SETQ XEROXRENDERING2UNICODEMAP (CONS TOCLIPBOARDARRAY TOCLIPBOARDLIST)) (SETQ UNICODE2XEROXRENDERINGMAP (CONS FROMCLIPBOARDARRAY FROMCLIPBOARDLIST]) (CBMAPCCODE [LAMBDA (CHARMAP CODE) (* ; "Edited 1-Feb-2020 17:49 by rmk:") (* ; "Edited 30-Jan-2020 22:47 by rmk:") (OR [IF (ILESSP CODE 256) THEN (CL:SVREF (CAR CHARMAP) CODE) ELSE (LET [(CS (CDR (ASSOC (LRSH CODE 8) (CDR CHARMAP] (CL:WHEN CS (IF (LISTP CS) THEN (CDR (ASSOC CODE CS)) ELSE (CL:SVREF CS (LOGAND CODE 255))))] CODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) ) (RPAQQ CBUNICODETOXEROXRENDERING ((8217 RSQ) (8216 LSQ) (8221 RDQ) (8220 LDQ) (8800 NEQ) (146 39) (160 61217) (166 61291) (168 8994) (169 211) (170 227) (172 61290) (173 61219) (174 210) (175 9086) (180 39) (184 203) (185 209) (186 235) (192 61729) (193 61730) (194 61731) (195 61732) (196 61735) (197 61736) (198 225) (199 61741) (200 61744) (201 61745) (202 61746) (203 61749) (204 61758) (205 61759) (206 61760) (207 61764) (208 226) (209 61772) (210 61775) (211 61776) (212 61777) (213 61778) (214 61780) (215 180) (216 233) (217 61791) (218 61792) (219 61793) (220 61797) (221 61803) (222 236) (223 251) (224 61857) (225 61858) (226 61859) (227 61860) (228 61863) (229 61864) (230 241) (231 61869) (232 61872) (233 61873) (234 61874) (235 61877) (236 61886) (237 61887) (238 61888) (239 61892) (240 243) (241 61900) (242 61903) (243 61904) (244 61905) (245 61906) (246 61908) (247 184) (248 249) (249 61919) (250 61920) (251 61921) (252 61925) (253 61931) (254 252) (255 61933) (376 61805) (8594 174) (8592 172) (8593 173) (8595 175) (8712 61258) (8713 61259) (10 13))) (ADDTOVAR CHARACTERNAMES (RSQ "0,271") (LSQ "0,251") (LDQ "0,252") (RDQ "0,272") (NEQ "041,142")) (MAKECHARCODEMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1679 7877 (INSTALL-CLIPBOARD 1689 . 3425) (GETCLIPBOARD 3427 . 4089) (PUTCLIPBOARD 4091 . 4708) (PASTEFROMCLIPBOARD 4710 . 5327) (TEDIT.COPYTOCLIPBOARD 5329 . 5610) ( TEDIT.EXTRACTTOCLIPBOARD 5612 . 6076) (SEDIT.COPYTOCLIPBOARD 6078 . 7452) (LISPINTERRUPTS.PASTE 7454 . 7875)) (7878 12430 (UTF8.PRINTCCODE 7888 . 9798) (UTF8.READCCODE 9800 . 12428)) (12487 13655 ( FILETOCODETABLE 12497 . 13382) (CODECONVERT 13384 . 13653)) (13656 18815 (MAKECHARCODEMAPS 13666 . 18124) (CBMAPCCODE 18126 . 18813))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~40~ b/library/CLIPBOARD.~40~ deleted file mode 100644 index b6c8b3d1..00000000 --- a/library/CLIPBOARD.~40~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-May-2020 17:34:19"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;40 21963 changes to%: (FNS INSTALL-CLIPBOARD TEDIT.SELECTALL) (VARS CLIPBOARDCOMS) previous date%: " 3-May-2020 17:33:15" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;39) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD TEDIT.SELECTALL) (FNS SEDIT.COPYTOCLIPBOARD) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (ALISTS (CHARACTERNAMES RSQ LSQ LDQ RDQ NEQ)) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 3-May-2020 17:33 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:07 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT (CBMAPCCODE UNICODE2XEROXRENDERINGMAP C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (CBMAPCCODE XEROXRENDERING2UNICODEMAP (NTHCHARCODE STRING I)) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. .") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 3-Feb-2020 10:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DEFINEQ (MAKECHARCODEMAPS [LAMBDA NIL (* ; "Edited 19-Apr-2020 11:43 by rmk:") (* ; "Edited 3-Feb-2020 10:03 by rmk:") (* ; "Edited 1-Feb-2020 17:45 by rmk:") (* ; "Edited 30-Jan-2020 23:03 by rmk:") (* ;; "Clipboard is UNICODE. Uses an array for character set 0 and for any other highly populated segment, ALIST for relatively unpopulated ones.") (* ;; "Charset 0 is special also because it contains most input characters in both directions.") (* ;; "It sets TOCLIPBOARDMAP and FROMCLIPBOARDMAP each to a pair (array . list)") (LET ((TOCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FROMCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (TOCLIPBOARDLIST NIL) (FROMCLIPBOARDLIST NIL)) [FOR C XC CSETLIST IN CBUNICODETOXEROXRENDERING DO (SETQ XC (CADR C)) (CL:UNLESS (FIXP XC) (SETQ XC (CHARCODE.DECODE XC))) (IF (ILESSP XC 256) THEN (CL:SETF (CL:SVREF TOCLIPBOARDARRAY XC) (CAR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH XC 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH XC 8] C)) FINALLY (SETQ TOCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CADR PAIR) 255)) (CAR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CADR PAIR) (CAR PAIR] [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (CL:UNLESS (FIXP (CADR C)) [SETQ C (LIST (CAR C) (CHARCODE.DECODE (CADR C]) (IF (ILESSP (CAR C) 256) THEN (CL:SETF (CL:SVREF FROMCLIPBOARDARRAY (CAR C)) (CADR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CAR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CAR C) 8] C)) FINALLY (SETQ FROMCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR PAIR) 255)) (CADR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CAR PAIR) (CADR PAIR] (SETQ XEROXRENDERING2UNICODEMAP (CONS TOCLIPBOARDARRAY TOCLIPBOARDLIST)) (SETQ UNICODE2XEROXRENDERINGMAP (CONS FROMCLIPBOARDARRAY FROMCLIPBOARDLIST]) (CBMAPCCODE [LAMBDA (CHARMAP CODE) (* ; "Edited 1-Feb-2020 17:49 by rmk:") (* ; "Edited 30-Jan-2020 22:47 by rmk:") (OR [IF (ILESSP CODE 256) THEN (CL:SVREF (CAR CHARMAP) CODE) ELSE (LET [(CS (CDR (ASSOC (LRSH CODE 8) (CDR CHARMAP] (CL:WHEN CS (IF (LISTP CS) THEN (CDR (ASSOC CODE CS)) ELSE (CL:SVREF CS (LOGAND CODE 255))))] CODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) ) (RPAQQ CBUNICODETOXEROXRENDERING ((8217 RSQ) (8216 LSQ) (8221 RDQ) (8220 LDQ) (8800 NEQ) (146 39) (160 61217) (166 61291) (168 8994) (169 211) (170 227) (172 61290) (173 61219) (174 210) (175 9086) (180 39) (184 203) (185 209) (186 235) (192 61729) (193 61730) (194 61731) (195 61732) (196 61735) (197 61736) (198 225) (199 61741) (200 61744) (201 61745) (202 61746) (203 61749) (204 61758) (205 61759) (206 61760) (207 61764) (208 226) (209 61772) (210 61775) (211 61776) (212 61777) (213 61778) (214 61780) (215 180) (216 233) (217 61791) (218 61792) (219 61793) (220 61797) (221 61803) (222 236) (223 251) (224 61857) (225 61858) (226 61859) (227 61860) (228 61863) (229 61864) (230 241) (231 61869) (232 61872) (233 61873) (234 61874) (235 61877) (236 61886) (237 61887) (238 61888) (239 61892) (240 243) (241 61900) (242 61903) (243 61904) (244 61905) (245 61906) (246 61908) (247 184) (248 249) (249 61919) (250 61920) (251 61921) (252 61925) (253 61931) (254 252) (255 61933) (376 61805) (8594 174) (8592 172) (8593 173) (8595 175) (8712 61258) (8713 61259) (10 13))) (ADDTOVAR CHARACTERNAMES (RSQ "0,271") (LSQ "0,251") (LDQ "0,252") (RDQ "0,272") (NEQ "041,142")) (MAKECHARCODEMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1657 6102 (INSTALL-CLIPBOARD 1667 . 3775) (GETCLIPBOARD 3777 . 4439) (PUTCLIPBOARD 4441 . 5058) (PASTEFROMCLIPBOARD 5060 . 5677) (LISPINTERRUPTS.PASTE 5679 . 6100)) (6103 10655 ( UTF8.PRINTCCODE 6113 . 8023) (UTF8.READCCODE 8025 . 10653)) (10656 11744 (TEDIT.COPYTOCLIPBOARD 10666 . 10947) (TEDIT.EXTRACTTOCLIPBOARD 10949 . 11413) (TEDIT.SELECTALL 11415 . 11742)) (11745 13131 ( SEDIT.COPYTOCLIPBOARD 11755 . 13129)) (13188 14356 (FILETOCODETABLE 13198 . 14083) (CODECONVERT 14085 . 14354)) (14357 19516 (MAKECHARCODEMAPS 14367 . 18825) (CBMAPCCODE 18827 . 19514))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~41~ b/library/CLIPBOARD.~41~ deleted file mode 100644 index e2ba3c5a..00000000 --- a/library/CLIPBOARD.~41~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "24-Jun-2020 20:17:42"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;41 22191 changes to%: (FNS INSTALL-CLIPBOARD) previous date%: " 3-May-2020 17:34:19" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;40) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS UTF8.PRINTCCODE UTF8.READCCODE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD TEDIT.SELECTALL) (FNS SEDIT.COPYTOCLIPBOARD) (COMS (* ;; "To read/access code translation tables") (FNS FILETOCODETABLE CODECONVERT) (FNS MAKECHARCODEMAPS CBMAPCCODE) (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) (VARS CBUNICODETOXEROXRENDERING) (ALISTS (CHARACTERNAMES RSQ LSQ LDQ RDQ NEQ)) (P (MAKECHARCODEMAPS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 24-Jun-2020 20:14 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 3-Feb-2020 10:07 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION UTF8.READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (UTF8.READCCODE s)) COLLECT (CBMAPCCODE UNICODE2XEROXRENDERINGMAP C]) (PUTCLIPBOARD [CL:LAMBDA (STRING) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (FOR I FROM 1 TO (NCHARS STRING) DO (UTF8.PRINTCCODE (CBMAPCCODE XEROXRENDERING2UNICODEMAP (NTHCHARCODE STRING I)) s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (UTF8.PRINTCCODE [LAMBDA (CHARCODE FILE) (* ; "Edited 3-Feb-2020 10:01 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. .") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (* ; "Output raw bytes") (IF (ILESSP CHARCODE 128) THEN (\BOUT STRM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STRM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STRM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STRM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STRM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.READCCODE [LAMBDA (FILE) (* ; "Edited 3-Feb-2020 10:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (LET ((STRM (\GETSTREAM FILE 'INPUT)) BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (\BIN STRM)) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STRM)) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STRM)) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (\BIN STRM)) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) ) (* ;; "To read/access code translation tables") (DEFINEQ (FILETOCODETABLE [LAMBDA (FILE) (* ; "Edited 28-Apr-2018 16:07 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (RESETLST (LET (LENGTH BLOCK STREAM) (CL:UNLESS (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) [RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE]) (* ;; "Blocks are allocated in 4-byte units") (SETQ BLOCK (\ALLOCBLOCK (LRSH LENGTH 2))) (\BINS STREAM BLOCK 0 LENGTH) BLOCK))]) (CODECONVERT [LAMBDA (TABLE CODE) (* ; "Edited 28-Apr-2018 16:01 by rmk:") (* ;;  "Get the CODEth value from the arrayblock TABLE. CODE is a 16-bit index, 16 bits are returned.") (\GETBASE TABLE CODE]) ) (DEFINEQ (MAKECHARCODEMAPS [LAMBDA NIL (* ; "Edited 19-Apr-2020 11:43 by rmk:") (* ; "Edited 3-Feb-2020 10:03 by rmk:") (* ; "Edited 1-Feb-2020 17:45 by rmk:") (* ; "Edited 30-Jan-2020 23:03 by rmk:") (* ;; "Clipboard is UNICODE. Uses an array for character set 0 and for any other highly populated segment, ALIST for relatively unpopulated ones.") (* ;; "Charset 0 is special also because it contains most input characters in both directions.") (* ;; "It sets TOCLIPBOARDMAP and FROMCLIPBOARDMAP each to a pair (array . list)") (LET ((TOCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FROMCLIPBOARDARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (TOCLIPBOARDLIST NIL) (FROMCLIPBOARDLIST NIL)) [FOR C XC CSETLIST IN CBUNICODETOXEROXRENDERING DO (SETQ XC (CADR C)) (CL:UNLESS (FIXP XC) (SETQ XC (CHARCODE.DECODE XC))) (IF (ILESSP XC 256) THEN (CL:SETF (CL:SVREF TOCLIPBOARDARRAY XC) (CAR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH XC 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH XC 8] C)) FINALLY (SETQ TOCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CADR PAIR) 255)) (CAR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CADR PAIR) (CAR PAIR] [FOR C CSETLIST IN CBUNICODETOXEROXRENDERING DO (CL:UNLESS (FIXP (CADR C)) [SETQ C (LIST (CAR C) (CHARCODE.DECODE (CADR C]) (IF (ILESSP (CAR C) 256) THEN (CL:SETF (CL:SVREF FROMCLIPBOARDARRAY (CAR C)) (CADR C)) ELSE (PUSH [CDR (OR (ASSOC (LRSH (CAR C) 8) CSETLIST) (CAR (PUSH CSETLIST (CONS (LRSH (CAR C) 8] C)) FINALLY (SETQ FROMCLIPBOARDLIST (FOR CS CSA IN CSETLIST COLLECT (CONS (CAR CS) (IF (IGREATERP (LENGTH (CDR CS)) 20) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR PAIR IN (CDR CS) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR PAIR) 255)) (CADR PAIR))) CSA ELSE (FOR PAIR IN (CDR CS) COLLECT (CONS (CAR PAIR) (CADR PAIR] (SETQ XEROXRENDERING2UNICODEMAP (CONS TOCLIPBOARDARRAY TOCLIPBOARDLIST)) (SETQ UNICODE2XEROXRENDERINGMAP (CONS FROMCLIPBOARDARRAY FROMCLIPBOARDLIST]) (CBMAPCCODE [LAMBDA (CHARMAP CODE) (* ; "Edited 1-Feb-2020 17:49 by rmk:") (* ; "Edited 30-Jan-2020 22:47 by rmk:") (OR [IF (ILESSP CODE 256) THEN (CL:SVREF (CAR CHARMAP) CODE) ELSE (LET [(CS (CDR (ASSOC (LRSH CODE 8) (CDR CHARMAP] (CL:WHEN CS (IF (LISTP CS) THEN (CDR (ASSOC CODE CS)) ELSE (CL:SVREF CS (LOGAND CODE 255))))] CODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XEROXRENDERING2UNICODEMAP UNICODE2XEROXRENDERINGMAP) ) (RPAQQ CBUNICODETOXEROXRENDERING ((8217 RSQ) (8216 LSQ) (8221 RDQ) (8220 LDQ) (8800 NEQ) (146 39) (160 61217) (166 61291) (168 8994) (169 211) (170 227) (172 61290) (173 61219) (174 210) (175 9086) (180 39) (184 203) (185 209) (186 235) (192 61729) (193 61730) (194 61731) (195 61732) (196 61735) (197 61736) (198 225) (199 61741) (200 61744) (201 61745) (202 61746) (203 61749) (204 61758) (205 61759) (206 61760) (207 61764) (208 226) (209 61772) (210 61775) (211 61776) (212 61777) (213 61778) (214 61780) (215 180) (216 233) (217 61791) (218 61792) (219 61793) (220 61797) (221 61803) (222 236) (223 251) (224 61857) (225 61858) (226 61859) (227 61860) (228 61863) (229 61864) (230 241) (231 61869) (232 61872) (233 61873) (234 61874) (235 61877) (236 61886) (237 61887) (238 61888) (239 61892) (240 243) (241 61900) (242 61903) (243 61904) (244 61905) (245 61906) (246 61908) (247 184) (248 249) (249 61919) (250 61920) (251 61921) (252 61925) (253 61931) (254 252) (255 61933) (376 61805) (8594 174) (8592 172) (8593 173) (8595 175) (8712 61258) (8713 61259) (10 13))) (ADDTOVAR CHARACTERNAMES (RSQ "0,271") (LSQ "0,251") (LDQ "0,252") (RDQ "0,272") (NEQ "041,142")) (MAKECHARCODEMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1600 6330 (INSTALL-CLIPBOARD 1610 . 4003) (GETCLIPBOARD 4005 . 4667) (PUTCLIPBOARD 4669 . 5286) (PASTEFROMCLIPBOARD 5288 . 5905) (LISPINTERRUPTS.PASTE 5907 . 6328)) (6331 10883 ( UTF8.PRINTCCODE 6341 . 8251) (UTF8.READCCODE 8253 . 10881)) (10884 11972 (TEDIT.COPYTOCLIPBOARD 10894 . 11175) (TEDIT.EXTRACTTOCLIPBOARD 11177 . 11641) (TEDIT.SELECTALL 11643 . 11970)) (11973 13359 ( SEDIT.COPYTOCLIPBOARD 11983 . 13357)) (13416 14584 (FILETOCODETABLE 13426 . 14311) (CODECONVERT 14313 . 14582)) (14585 19744 (MAKECHARCODEMAPS 14595 . 19053) (CBMAPCCODE 19055 . 19742))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.~44~ b/library/CLIPBOARD.~44~ deleted file mode 100644 index a9f7e62d..00000000 --- a/library/CLIPBOARD.~44~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Jul-2020 21:33:30"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;44 8581 changes to%: (VARS CLIPBOARDCOMS CBUNICODETOXEROXRENDERING) (FNS GETCLIPBOARD PUTCLIPBOARD) previous date%: "24-Jun-2020 20:17:42" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;41) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD TEDIT.SELECTALL) (FNS SEDIT.COPYTOCLIPBOARD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PUTCLIPBOARD]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 24-Jun-2020 20:14 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;  "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 30-Jul-2020 21:23 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) (\EXTERNALFORMAT s :UTF8) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD (CL:LAMBDA (STRING) (* ; "Edited 30-Jul-2020 21:26 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (\EXTERNALFORMAT s :UTF8) (PRIN3 STRING s)))) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 5-May-2018 09:43 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") (LET (SEL SELTYPE STRING) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (CL:MULTIPLE-VALUE-SETQ (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT)) (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (IF SELTYPE THEN (SETQ STRING (MKSTRING SEL T)) (* ; " Readtable of caller?") (CL:WHEN (OR (EQ SELTYPE :CHARACTERS) (AND (EQ SELTYPE :SUB-LIST) (LISTP SEL))) (GNC STRING) (* ;  "Peel off outer parens for structures or quotes for atom/string characters") (GLC STRING)) (PUTCLIPBOARD STRING))) T]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PUTCLIPBOARD) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1279 5776 (INSTALL-CLIPBOARD 1289 . 3682) (GETCLIPBOARD 3684 . 4300) (PUTCLIPBOARD 4302 . 4732) (PASTEFROMCLIPBOARD 4734 . 5351) (LISPINTERRUPTS.PASTE 5353 . 5774)) (5777 6865 ( TEDIT.COPYTOCLIPBOARD 5787 . 6068) (TEDIT.EXTRACTTOCLIPBOARD 6070 . 6534) (TEDIT.SELECTALL 6536 . 6863 )) (6866 8252 (SEDIT.COPYTOCLIPBOARD 6876 . 8250))))) STOP \ No newline at end of file From b7458b24be0bb058cbf624c3a0545b3431ab9b68 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Mon, 22 Feb 2021 18:09:07 -0800 Subject: [PATCH 23/31] Restore fontprofile (#200) * restore FONTPROFILE and PATCH * extra (dup) version --- sources/FONTPROFILE | 1 + sources/FONTPROFILE.~1~ | 1 + sources/FONTPROFILEPATCH | 1 + sources/FONTPROFILEPATCH.LCOM | Bin 0 -> 10893 bytes 4 files changed, 3 insertions(+) create mode 100644 sources/FONTPROFILE create mode 100644 sources/FONTPROFILE.~1~ create mode 100644 sources/FONTPROFILEPATCH create mode 100644 sources/FONTPROFILEPATCH.LCOM diff --git a/sources/FONTPROFILE b/sources/FONTPROFILE new file mode 100644 index 00000000..23f0bb6a --- /dev/null +++ b/sources/FONTPROFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 22:10:46" {DSK}medley3.5>sources>FONTPROFILE.;2 29960 changes to%: (VARS FONTPROFILECOMS) (ALISTS (FONTDEFS NS) (FONTDEFS BIGGERNS)) previous date%: " 9-Jul-91 18:38:04" {DSK}medley3.5>sources>FONTPROFILE.;1) (* ; " Copyright (c) 1986, 1988, 1990, 1991, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FONTPROFILECOMS) (RPAQQ FONTPROFILECOMS ( (* ;; "FONT") (ALISTS (FONTDEFS HUGE BIG MEDIUM STANDARD BIGGER NS BIGGERNS)) (ADDVARS (CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu)) [VARS (FONTVARS '( (* ;; "standard size fonts. Assumes only DEFAULTFONT set") (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD)) (* ; "default BOLD") (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC)) (LITTLEFONT DEFAULTFONT) (* ; " should usually be smaller") (TINYFONT LITTLEFONT) (* ; "and this one smaller still") (BIGFONT BOLDFONT) (* ; "should be bigger still") (TEXTFONT DEFAULTFONT) (* ; "default for text") (TEXTBOLDFONT BOLDFONT) (* ; "default for bold text") (* ;; "") (* ;; "Fonts for window system, processes") (* ;; "") (MENUFONT DEFAULTFONT T) (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD)) (* ; "if not supplied") (INTERRUPTMENUFONT DEFAULTFONT T) (* ; "used by control-B") (DEFAULTICONFONT MENUFONT) (* ; "for shrinking windows") (BACKTRACEFONT TINYFONT T) (* ; " for backtrace in debugger") (WINDOWTITLEFONT MENUFONT) ((WINDOWTITLEFONT WINDOWTITLEFONT) NIL) (* ; " used for titles of all windows") (* ;; "") (* ;; "Fonts for Exec") (* ;; "") (PROMPTFONT LITTLEFONT) (* ; "for printing out prompts") (INPUTFONT BOLDFONT) (* ; "for user typein in Exec") (PRINTOUTFONT DEFAULTFONT) (* ; " for intermediate typin in Exec") (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT)) (VALUEFONT DEFAULTFONT) (* ;  " for printing out values returned in Exec") (* ;; "") (* ;; "Fonts for prettyprinting") (* ;; "") (COMMENTFONT LITTLEFONT) (* ; "for comments ") (PRETTYCOMFONT BOLDFONT) (* ; " for words being defined") (CLISPFONT BOLDFONT) (* ; " for keywords & CLISP") (SYSTEMFONT DEFAULTFONT) (* ; " for %"system%" words(?)") (LAMBDAFONT BIGFONT) (* ; "for words being defined") (USERFONT BOLDFONT) (* ; " for %"user%" defined words")] (P (MOVD? 'NILL 'WINDOWTITLEFONT)) (FNS FONTSET FONTPROFILE FONTPROFILE.ADDDEVICE) (INITVARS (FONTESCAPECHAR (CHARACTER 6)) (FONTFNS) (FONTWORDS)) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (FONTSET 'STANDARD] (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS) (FNS FONTMAPARRAY) (INITVARS (\FONTMAPCACHE)) (P (SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) 1 FILERDTBL)))) (* ;; "FONT") (ADDTOVAR FONTDEFS [HUGE (FONTPROFILE (DEFAULTFONT 1 (MODERN 24) NIL (TERMINAL 8)) (BOLDFONT 2 (MODERN 24 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 18 MRR) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 36 BRR) NIL (MODERN 10 BRR)) (TEXTFONT 5 (CLASSIC 24) NIL (CLASSIC 10)) (TEXTBOLDFONT 7 (CLASSIC 24 BRR) NIL (CLASSIC 10 BRR] [BIG (FONTPROFILE (DEFAULTFONT 1 (MODERN 18) NIL (TERMINAL 8)) (TEXTFONT 5 (CLASSIC 18) NIL (CLASSIC 10)) (BOLDFONT 2 (MODERN 18 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 12 MRR) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 24 BRR) NIL (MODERN 10 BRR)) (TEXTBOLDFONT 7 (CLASSIC 18 BRR) NIL (CLASSIC 10 BRR] [MEDIUM (FONTPROFILE (DEFAULTFONT 1 (MODERN 14) NIL (TERMINAL 8)) (BOLDFONT 2 (MODERN 14 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 10) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 18) NIL (MODERN 10 BRR)) (TEXTFONT 5 (CLASSIC 14) NIL (CLASSIC 10)) (TEXTBOLDFONT 7 (CLASSIC 14 BRR) NIL (CLASSIC 10 BRR] [STANDARD (FONTCHANGEFLG . ALL) (FILELINELENGTH . 102) (FONTPROFILE (DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 10 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 8) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 12 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 10)) (COMMENTFONT 6 (HELVETICA 10) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 10) NIL (CLASSIC 10] [BIGGER (FONTPROFILE (DEFAULTFONT 1 (GACHA 12) NIL (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 12 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 12 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 10) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 10) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 14 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 12)) (COMMENTFONT 6 (HELVETICA 12) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 12) NIL (CLASSIC 10] [NS (FONTCHANGEFLG . ALL) (FILELINELENGTH . 102) (COMMENTLINELENGTH 116 . 126) (FIRSTCOL . 60) (PRETTYLCOM . 25) (FONTESCAPECHAR . %) (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 10) (TERMINAL 8) (TERMINAL 8)) (ITALICFONT 1 (MODERN 10 BIR) (MODERN 8 BIR) (MODERN 8 BIR)) (BOLDFONT 2 (MODERN 10 BRR) (MODERN 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 8) (MODERN 6 MIR) (MODERN 8 MIR)) (BIGFONT 4 (MODERN 12 BRR) (MODERN 10 BRR) (MODERN 10 BRR] [BIGGERNS (FONTCHANGEFLG . ALL) (FILELINELENGTH . 102) (COMMENTLINELENGTH 116 . 126) (FIRSTCOL . 60) (PRETTYLCOM . 25) (FONTESCAPECHAR . %) (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 12) (TERMINAL 8) (TERMINAL 8)) (ITALICFONT 1 (MODERN 12 BIR) (MODERN 8 BIR) (MODERN 8 BIR)) (BOLDFONT 2 (MODERN 12 BRR) (MODERN 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 10) (MODERN 6 MIR) (MODERN 8 MIR)) (BIGFONT 4 (MODERN 14 BRR) (MODERN 10 BRR) (MODERN 10 BRR]) (ADDTOVAR CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu) (RPAQQ FONTVARS ( (* ;; "standard size fonts. Assumes only DEFAULTFONT set") (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD)) (* ; "default BOLD") (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC)) (LITTLEFONT DEFAULTFONT) (* ; " should usually be smaller") (TINYFONT LITTLEFONT) (* ; "and this one smaller still") (BIGFONT BOLDFONT) (* ; "should be bigger still") (TEXTFONT DEFAULTFONT) (* ; "default for text") (TEXTBOLDFONT BOLDFONT) (* ; "default for bold text") (* ;; "") (* ;; "Fonts for window system, processes") (* ;; "") (MENUFONT DEFAULTFONT T) (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD)) (* ; "if not supplied") (INTERRUPTMENUFONT DEFAULTFONT T) (* ; "used by control-B") (DEFAULTICONFONT MENUFONT) (* ; "for shrinking windows") (BACKTRACEFONT TINYFONT T) (* ; " for backtrace in debugger") (WINDOWTITLEFONT MENUFONT) ((WINDOWTITLEFONT WINDOWTITLEFONT) NIL) (* ; " used for titles of all windows") (* ;; "") (* ;; "Fonts for Exec") (* ;; "") (PROMPTFONT LITTLEFONT) (* ; "for printing out prompts") (INPUTFONT BOLDFONT) (* ; "for user typein in Exec") (PRINTOUTFONT DEFAULTFONT) (* ; " for intermediate typin in Exec") (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT)) (VALUEFONT DEFAULTFONT) (* ;  " for printing out values returned in Exec") (* ;; "") (* ;; "Fonts for prettyprinting") (* ;; "") (COMMENTFONT LITTLEFONT) (* ; "for comments ") (PRETTYCOMFONT BOLDFONT) (* ; " for words being defined") (CLISPFONT BOLDFONT) (* ; " for keywords & CLISP") (SYSTEMFONT DEFAULTFONT) (* ; " for %"system%" words(?)") (LAMBDAFONT BIGFONT) (* ; "for words being defined") (USERFONT BOLDFONT) (* ; " for %"user%" defined words"))) (MOVD? 'NILL 'WINDOWTITLEFONT) (DEFINEQ (FONTSET [LAMBDA (NAME CHANGE-WINDOWS?) (* ; "Edited 23-Jun-88 10:46 by jds") (COND [NAME (LET [(TEM (FASSOC NAME FONTDEFS)) (OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY] (OR TEM (ERROR NAME "not a defined font configuration")) (* ;; "Looks up NAME on FONTSLST and sets apropriate parameters. entries are added to fontslst by FONTNAME.") (for X in FONTVARS when (AND (CL:SYMBOLP (CAR X)) (NEQ (CAR X) '*) (NEQ (CAR X) (CADR X))) do (SETTOPVAL (CAR X))) [MAPC (CDR TEM) (FUNCTION (LAMBDA (X) (/SETTOPVAL (CAR X) (CDR X] [PROG (BASICCLASSES) (for X in FONTPROFILE do (PROG (SEEN (NAME (CAR X)) (FONTS X)) LP [COND ((MEMB (CAR FONTS) SEEN) (ERROR "Circular font profile specification" X)) (T (push SEEN (CAR FONTS] [SETQ FONTS (CDR (COND ((OR (NULL (CADR FONTS)) (LISTP (CADR FONTS))) (*) (* ;  "This skips over the now-defunct NIL or list-of-escape sequence") (CDR FONTS)) (T FONTS] (COND ((OR (NLISTP FONTS) (LITATOM (CAR FONTS)))(* ;  "Indirect thru another's font spec") (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) ((NIL DEFAULTFONT) (* ;  "Don't let DEFAULTFONT loop thru itself") (AND (NOT (MEMB 'DEFAULTFONT SEEN )) 'DEFAULTFONT)) (CAR FONTS)) FONTPROFILE)) (GO LP))) (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* ;  "Now we have a font class datastructure") )) (AND NAME (/SETTOPVAL NAME FONTS)) (* ;; "NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.") )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] [for X in FONTVARS when (NEQ (CAR X) '*) do (COND ((LISTP (CAR X)) (EVAL (CAR X))) [(CADDR X) (SET (CAR X) (FONTCREATE (OR (GETTOPVAL (CAR X)) (EVAL (CADR X)) DEFAULTFONT) NIL NIL NIL 'DISPLAY] (T (OR (GETTOPVAL (CAR X)) (AND (CADR X) (SET (CAR X) (EVAL (CADR X] (CL:WHEN CHANGE-WINDOWS? (CL:WHEN (NEQ OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY)) (for X in (OPENWINDOWS) when (EQ OLDDEFAULT (DSPFONT NIL X)) do (DSPFONT DEFAULTFONT X))) (DSPFONT WINDOWTITLEFONT WindowTitleDisplayStream) (SETQ MaxValueLeftMargin (ITIMES 35 (STRINGWIDTH 'A DEFAULTFONT))) (MAPC CACHEDMENUS 'SET) [for W in (OPENWINDOWS) do [COND [(OR (EQ (WINDOWPROP W 'RESHAPEFN) 'DONT) (WINDOWPROP W 'MAINWINDOW] (T (* ;;  "don't reshape if can't or if this window is attached to another.") (SHAPEW W (WINDOWREGION W] (COND ((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN) (FUNCTION \TEDIT.PROCIDLEFN)) (WINDOWPROP W 'REPAINTFN)) (REDISPLAYW W]) (* ;; "Set the new font profile name, and return the old one, so he can restore later.") (PROG1 FONTNAME (SETQ FONTNAME NAME] (T (* ;  "He passed in NIL, so return font profile name in effect.") FONTNAME]) (FONTPROFILE [LAMBDA (PROFILE) (* lmm "10-Sep-86 12:33") [PROG (BASICCLASSES) (for X in PROFILE do (PROG (SEEN (NAME (CAR X)) (FONTS X)) LP [COND ((MEMB (CAR FONTS) SEEN) (ERROR "Circular font profile specification" X)) (T (push SEEN (CAR FONTS] [SETQ FONTS (CDR (COND ((OR (NULL (CADR FONTS)) (LISTP (CADR FONTS))) (* ; "This skips over the now-defunct NIL or list-of-escape sequence") (CDR FONTS)) (T FONTS] (COND ((OR (NLISTP FONTS) (LITATOM (CAR FONTS))) (* Indirect thru another's font spec) (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) ((NIL DEFAULTFONT) (* Don't let DEFAULTFONT loop thru itself) (AND (NOT (MEMB 'DEFAULTFONT SEEN)) 'DEFAULTFONT)) (CAR FONTS)) PROFILE)) (GO LP))) (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* Now we have a font class datastructure) )) (AND NAME (/SETATOMVAL NAME FONTS)) (* NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.) )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] T]) (FONTPROFILE.ADDDEVICE [LAMBDA (NEWDEVICE OLDDEVICE) (* ; "Edited 3-Mar-93 14:46 by rmk:") (* ;; "Fills in all fontprofile specifications so that an entry for NEWDEVICE is present for each fontclass. Nothing is changed if the entry is already there, otherwise the specification for the class currently provided for OLDDEVICE will be used for NEWDEVICE.") (DECLARE (USEDFREE FONTDEFS FONTNAME)) (SETQ NEWDEVICE (U-CASE NEWDEVICE)) (SETQ OLDDEVICE (U-CASE OLDDEVICE)) [FOR FD IN FONTDEFS DO (FOR FC OLDSPEC IN (CDR (ASSOC 'FONTPROFILE (CDR FD))) UNLESS (LITATOM (CADR FC)) DO (SETQ FC (CDR FC)) (* ; "Skip over name") (CL:WHEN [SETQ OLDSPEC (SELECTQ OLDDEVICE (DISPLAY (CADR FC)) (INTERPRESS (CADDDR FC)) (PRESS (CADDR FC)) (CADR (ASSOC OLDDEVICE (CDDDDR FC] [SETQ FC (OR (CDR FC) (CDR (RPLACD FC (CONS] (* ;  "Fill in NIL's for missing DISPLAY, PRESS, or INTERPRESS") [SELECTQ NEWDEVICE (DISPLAY (OR (CAR FC) (RPLACA FC OLDSPEC))) (INTERPRESS (OR (CADDR FC) (RPLACA [PROGN [SETQ FC (OR (CDR FC) (CDR (RPLACD FC (CONS] (OR (CDR FC) (CDR (RPLACD FC (CONS] OLDSPEC))) (PRESS (OR (CADDR FC) (RPLACA [OR (CDR FC) (CDR (RPLACD FC (CONS] OLDSPEC))) (OR (CADR (ASSOC NEWDEVICE (CDDDR FC))) (PROGN (PROGN [SETQ FC (OR (CDR FC) (CDR (RPLACD FC (CONS] [SETQ FC (OR (CDR FC) (CDR (RPLACD FC (CONS] (PUSH (CDR FC) (LIST NEWDEVICE OLDSPEC])] (FONTSET FONTNAME]) ) (RPAQ? FONTESCAPECHAR (CHARACTER 6)) (RPAQ? FONTFNS ) (RPAQ? FONTWORDS ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FONTSET 'STANDARD) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS) ) (DEFINEQ (FONTMAPARRAY [LAMBDA (FONTCLASSES) (* lmm "28-Sep-86 14:23") (* ;; "Makes a font array from a font-mapping list of fontclasses. The array provides a fast map from font# to font classes/descriptors. This function caches the last array. If IMAGETYPES is given, then the FD's are pre-computed for the imagetypes it. Otherwise, the first use of the fontclass for that imagetype would cause the fontcreate to be done.") (PROG (FA (MAXFONT 0) (MINFONT 100)) [COND ((NULL \FONTMAPCACHE)) ((OR (NULL FONTCLASSES) (EQUAL FONTCLASSES (CAR \FONTMAPCACHE))) (RETURN (CDR \FONTMAPCACHE] [for F PRETTYFONT# in FONTCLASSES do (SETQ PRETTYFONT# (fetch (FONTCLASS PRETTYFONT#) of F)) (COND ((IGREATERP PRETTYFONT# MAXFONT) (SETQ MAXFONT PRETTYFONT#))) (COND ((ILESSP PRETTYFONT# 1) (ERROR "Invalid font number" PRETTYFONT# F)) ((ILESSP PRETTYFONT# MINFONT) (SETQ MINFONT PRETTYFONT#] (SETQ FA (ARRAY MAXFONT)) (for F in FONTCLASSES do (SETA FA (fetch (FONTCLASS PRETTYFONT#) of F) F)) (for I from 1 to MAXFONT unless (ELT FA I) do (SETA FA I (ELT FA MINFONT))) (SETQ \FONTMAPCACHE (CONS (COPY FONTCLASSES) FA)) (RETURN FA]) ) (RPAQ? \FONTMAPCACHE ) (SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) 1 FILERDTBL) (PUTPROPS FONTPROFILE COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990 1991 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (16000 27584 (FONTSET 16010 . 22351) (FONTPROFILE 22353 . 24702) (FONTPROFILE.ADDDEVICE 24704 . 27582)) (27820 29719 (FONTMAPARRAY 27830 . 29717))))) STOP \ No newline at end of file diff --git a/sources/FONTPROFILE.~1~ b/sources/FONTPROFILE.~1~ new file mode 100644 index 00000000..0d47afa2 --- /dev/null +++ b/sources/FONTPROFILE.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-Jul-91 18:38:04" |{PELE:MV:ENVOS}SOURCES>FONTPROFILE.;3| 25066 changes to%: (VARS FONTPROFILECOMS) previous date%: "16-May-90 18:00:27" |{PELE:MV:ENVOS}SOURCES>FONTPROFILE.;2|) (* ; " Copyright (c) 1986, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FONTPROFILECOMS) (RPAQQ FONTPROFILECOMS ( (* ;; "FONT") (ALISTS (FONTDEFS HUGE BIG MEDIUM STANDARD BIGGER)) (ADDVARS (CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu)) [VARS (FONTVARS '( (* ;; "standard size fonts. Assumes only DEFAULTFONT set") (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD)) (* ; "default BOLD") (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC)) (LITTLEFONT DEFAULTFONT) (* ; " should usually be smaller") (TINYFONT LITTLEFONT) (* ; "and this one smaller still") (BIGFONT BOLDFONT) (* ; "should be bigger still") (TEXTFONT DEFAULTFONT) (* ; "default for text") (TEXTBOLDFONT BOLDFONT) (* ; "default for bold text") (* ;; "") (* ;; "Fonts for window system, processes") (* ;; "") (MENUFONT DEFAULTFONT T) (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD)) (* ; "if not supplied") (INTERRUPTMENUFONT DEFAULTFONT T) (* ; "used by control-B") (DEFAULTICONFONT MENUFONT) (* ; "for shrinking windows") (BACKTRACEFONT TINYFONT T) (* ; " for backtrace in debugger") (WINDOWTITLEFONT MENUFONT) ((WINDOWTITLEFONT WINDOWTITLEFONT) NIL) (* ; " used for titles of all windows") (* ;; "") (* ;; "Fonts for Exec") (* ;; "") (PROMPTFONT LITTLEFONT) (* ; "for printing out prompts") (INPUTFONT BOLDFONT) (* ; "for user typein in Exec") (PRINTOUTFONT DEFAULTFONT) (* ; " for intermediate typin in Exec") (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT)) (VALUEFONT DEFAULTFONT) (* ;  " for printing out values returned in Exec") (* ;; "") (* ;; "Fonts for prettyprinting") (* ;; "") (COMMENTFONT LITTLEFONT) (* ; "for comments ") (PRETTYCOMFONT BOLDFONT) (* ; " for words being defined") (CLISPFONT BOLDFONT) (* ; " for keywords & CLISP") (SYSTEMFONT DEFAULTFONT) (* ; " for %"system%" words(?)") (LAMBDAFONT BIGFONT) (* ; "for words being defined") (USERFONT BOLDFONT) (* ; " for %"user%" defined words")] (P (MOVD? 'NILL 'WINDOWTITLEFONT)) (FNS FONTSET FONTPROFILE) (INITVARS (FONTESCAPECHAR (CHARACTER 6)) (FONTFNS) (FONTWORDS)) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (FONTSET 'STANDARD] (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS) (FNS FONTMAPARRAY) (INITVARS (\FONTMAPCACHE)) (P (SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) 1 FILERDTBL)))) (* ;; "FONT") (ADDTOVAR FONTDEFS [HUGE (FONTPROFILE (DEFAULTFONT 1 (MODERN 24) NIL (TERMINAL 8)) (BOLDFONT 2 (MODERN 24 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 18 MRR) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 36 BRR) NIL (MODERN 10 BRR)) (TEXTFONT 5 (CLASSIC 24) NIL (CLASSIC 10)) (TEXTBOLDFONT 7 (CLASSIC 24 BRR) NIL (CLASSIC 10 BRR] [BIG (FONTPROFILE (DEFAULTFONT 1 (MODERN 18) NIL (TERMINAL 8)) (TEXTFONT 5 (CLASSIC 18) NIL (CLASSIC 10)) (BOLDFONT 2 (MODERN 18 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 12 MRR) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 24 BRR) NIL (MODERN 10 BRR)) (TEXTBOLDFONT 7 (CLASSIC 18 BRR) NIL (CLASSIC 10 BRR] [MEDIUM (FONTPROFILE (DEFAULTFONT 1 (MODERN 14) NIL (TERMINAL 8)) (BOLDFONT 2 (MODERN 14 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 10) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 18) NIL (MODERN 10 BRR)) (TEXTFONT 5 (CLASSIC 14) NIL (CLASSIC 10)) (TEXTBOLDFONT 7 (CLASSIC 14 BRR) NIL (CLASSIC 10 BRR] [STANDARD (FONTCHANGEFLG . ALL) (FILELINELENGTH . 102) (FONTPROFILE (DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 10 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 8) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 12 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 10)) (COMMENTFONT 6 (HELVETICA 10) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 10) NIL (CLASSIC 10] [BIGGER (FONTPROFILE (DEFAULTFONT 1 (GACHA 12) NIL (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 12 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 12 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 10) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 10) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 14 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 12)) (COMMENTFONT 6 (HELVETICA 12) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 12) NIL (CLASSIC 10]) (ADDTOVAR CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu) (RPAQQ FONTVARS ( (* ;; "standard size fonts. Assumes only DEFAULTFONT set") (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD)) (* ; "default BOLD") (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC)) (LITTLEFONT DEFAULTFONT) (* ; " should usually be smaller") (TINYFONT LITTLEFONT) (* ; "and this one smaller still") (BIGFONT BOLDFONT) (* ; "should be bigger still") (TEXTFONT DEFAULTFONT) (* ; "default for text") (TEXTBOLDFONT BOLDFONT) (* ; "default for bold text") (* ;; "") (* ;; "Fonts for window system, processes") (* ;; "") (MENUFONT DEFAULTFONT T) (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD)) (* ; "if not supplied") (INTERRUPTMENUFONT DEFAULTFONT T) (* ; "used by control-B") (DEFAULTICONFONT MENUFONT) (* ; "for shrinking windows") (BACKTRACEFONT TINYFONT T) (* ; " for backtrace in debugger") (WINDOWTITLEFONT MENUFONT) ((WINDOWTITLEFONT WINDOWTITLEFONT) NIL) (* ; " used for titles of all windows") (* ;; "") (* ;; "Fonts for Exec") (* ;; "") (PROMPTFONT LITTLEFONT) (* ; "for printing out prompts") (INPUTFONT BOLDFONT) (* ; "for user typein in Exec") (PRINTOUTFONT DEFAULTFONT) (* ; " for intermediate typin in Exec") (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT)) (VALUEFONT DEFAULTFONT) (* ;  " for printing out values returned in Exec") (* ;; "") (* ;; "Fonts for prettyprinting") (* ;; "") (COMMENTFONT LITTLEFONT) (* ; "for comments ") (PRETTYCOMFONT BOLDFONT) (* ; " for words being defined") (CLISPFONT BOLDFONT) (* ; " for keywords & CLISP") (SYSTEMFONT DEFAULTFONT) (* ; " for %"system%" words(?)") (LAMBDAFONT BIGFONT) (* ; "for words being defined") (USERFONT BOLDFONT) (* ; " for %"user%" defined words"))) (MOVD? 'NILL 'WINDOWTITLEFONT) (DEFINEQ (FONTSET [LAMBDA (NAME CHANGE-WINDOWS?) (* ; "Edited 23-Jun-88 10:46 by jds") (COND [NAME (LET [(TEM (FASSOC NAME FONTDEFS)) (OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY] (OR TEM (ERROR NAME "not a defined font configuration")) (* ;; "Looks up NAME on FONTSLST and sets apropriate parameters. entries are added to fontslst by FONTNAME.") (for X in FONTVARS when (AND (CL:SYMBOLP (CAR X)) (NEQ (CAR X) '*) (NEQ (CAR X) (CADR X))) do (SETTOPVAL (CAR X))) [MAPC (CDR TEM) (FUNCTION (LAMBDA (X) (/SETTOPVAL (CAR X) (CDR X] [PROG (BASICCLASSES) (for X in FONTPROFILE do (PROG (SEEN (NAME (CAR X)) (FONTS X)) LP [COND ((MEMB (CAR FONTS) SEEN) (ERROR "Circular font profile specification" X)) (T (push SEEN (CAR FONTS] [SETQ FONTS (CDR (COND ((OR (NULL (CADR FONTS)) (LISTP (CADR FONTS))) (*) (* ;  "This skips over the now-defunct NIL or list-of-escape sequence") (CDR FONTS)) (T FONTS] (COND ((OR (NLISTP FONTS) (LITATOM (CAR FONTS)))(* ;  "Indirect thru another's font spec") (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) ((NIL DEFAULTFONT) (* ;  "Don't let DEFAULTFONT loop thru itself") (AND (NOT (MEMB 'DEFAULTFONT SEEN )) 'DEFAULTFONT)) (CAR FONTS)) FONTPROFILE)) (GO LP))) (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* ;  "Now we have a font class datastructure") )) (AND NAME (/SETTOPVAL NAME FONTS)) (* ;; "NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.") )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] [for X in FONTVARS when (NEQ (CAR X) '*) do (COND ((LISTP (CAR X)) (EVAL (CAR X))) [(CADDR X) (SET (CAR X) (FONTCREATE (OR (GETTOPVAL (CAR X)) (EVAL (CADR X)) DEFAULTFONT) NIL NIL NIL 'DISPLAY] (T (OR (GETTOPVAL (CAR X)) (AND (CADR X) (SET (CAR X) (EVAL (CADR X] (CL:WHEN CHANGE-WINDOWS? (CL:WHEN (NEQ OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY)) (for X in (OPENWINDOWS) when (EQ OLDDEFAULT (DSPFONT NIL X)) do (DSPFONT DEFAULTFONT X))) (DSPFONT WINDOWTITLEFONT WindowTitleDisplayStream) (SETQ MaxValueLeftMargin (ITIMES 35 (STRINGWIDTH 'A DEFAULTFONT))) (MAPC CACHEDMENUS 'SET) [for W in (OPENWINDOWS) do [COND [(OR (EQ (WINDOWPROP W 'RESHAPEFN) 'DONT) (WINDOWPROP W 'MAINWINDOW] (T (* ;;  "don't reshape if can't or if this window is attached to another.") (SHAPEW W (WINDOWREGION W] (COND ((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN) (FUNCTION \TEDIT.PROCIDLEFN)) (WINDOWPROP W 'REPAINTFN)) (REDISPLAYW W]) (* ;; "Set the new font profile name, and return the old one, so he can restore later.") (PROG1 FONTNAME (SETQ FONTNAME NAME] (T (* ;  "He passed in NIL, so return font profile name in effect.") FONTNAME]) (FONTPROFILE [LAMBDA (PROFILE) (* lmm "10-Sep-86 12:33") [PROG (BASICCLASSES) (for X in PROFILE do (PROG (SEEN (NAME (CAR X)) (FONTS X)) LP [COND ((MEMB (CAR FONTS) SEEN) (ERROR "Circular font profile specification" X)) (T (push SEEN (CAR FONTS] [SETQ FONTS (CDR (COND ((OR (NULL (CADR FONTS)) (LISTP (CADR FONTS))) (* ; "This skips over the now-defunct NIL or list-of-escape sequence") (CDR FONTS)) (T FONTS] (COND ((OR (NLISTP FONTS) (LITATOM (CAR FONTS))) (* Indirect thru another's font spec) (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) ((NIL DEFAULTFONT) (* Don't let DEFAULTFONT loop thru itself) (AND (NOT (MEMB 'DEFAULTFONT SEEN)) 'DEFAULTFONT)) (CAR FONTS)) PROFILE)) (GO LP))) (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* Now we have a font class datastructure) )) (AND NAME (/SETATOMVAL NAME FONTS)) (* NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.) )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] T]) ) (RPAQ? FONTESCAPECHAR (CHARACTER 6)) (RPAQ? FONTFNS ) (RPAQ? FONTWORDS ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FONTSET 'STANDARD) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS) ) (DEFINEQ (FONTMAPARRAY [LAMBDA (FONTCLASSES) (* lmm "28-Sep-86 14:23") (* ;; "Makes a font array from a font-mapping list of fontclasses. The array provides a fast map from font# to font classes/descriptors. This function caches the last array. If IMAGETYPES is given, then the FD's are pre-computed for the imagetypes it. Otherwise, the first use of the fontclass for that imagetype would cause the fontcreate to be done.") (PROG (FA (MAXFONT 0) (MINFONT 100)) [COND ((NULL \FONTMAPCACHE)) ((OR (NULL FONTCLASSES) (EQUAL FONTCLASSES (CAR \FONTMAPCACHE))) (RETURN (CDR \FONTMAPCACHE] [for F PRETTYFONT# in FONTCLASSES do (SETQ PRETTYFONT# (fetch (FONTCLASS PRETTYFONT#) of F)) (COND ((IGREATERP PRETTYFONT# MAXFONT) (SETQ MAXFONT PRETTYFONT#))) (COND ((ILESSP PRETTYFONT# 1) (ERROR "Invalid font number" PRETTYFONT# F)) ((ILESSP PRETTYFONT# MINFONT) (SETQ MINFONT PRETTYFONT#] (SETQ FA (ARRAY MAXFONT)) (for F in FONTCLASSES do (SETA FA (fetch (FONTCLASS PRETTYFONT#) of F) F)) (for I from 1 to MAXFONT unless (ELT FA I) do (SETA FA I (ELT FA MINFONT))) (SETQ \FONTMAPCACHE (CONS (COPY FONTCLASSES) FA)) (RETURN FA]) ) (RPAQ? \FONTMAPCACHE ) (SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) 1 FILERDTBL) (PUTPROPS FONTPROFILE COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (13991 22695 (FONTSET 14001 . 20342) (FONTPROFILE 20344 . 22693)) (22931 24830 ( FONTMAPARRAY 22941 . 24828))))) STOP \ No newline at end of file diff --git a/sources/FONTPROFILEPATCH b/sources/FONTPROFILEPATCH new file mode 100644 index 00000000..5704dd91 --- /dev/null +++ b/sources/FONTPROFILEPATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Mar-93 11:02:28" {DSK}medley2.0>patches>FONTPROFILEPATCH.;4 30621 changes to%: (ALISTS (FONTDEFS HUGE) (FONTDEFS BIG) (FONTDEFS MEDIUM) (FONTDEFS STANDARD) (FONTDEFS BIGGER) (FONTDEFS BIGGERNS) (FONTDEFS NS)) previous date%: "11-Mar-93 11:51:49" {DSK}medley2.0>patches>FONTPROFILEPATCH.;3) (* ; " Copyright (c) 1993 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FONTPROFILEPATCHCOMS) (RPAQQ FONTPROFILEPATCHCOMS ( (* ;; "FONT") (ALISTS (FONTDEFS HUGE BIG MEDIUM STANDARD BIGGER BIGGERNS NS)) (ADDVARS (CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu)) [VARS (FONTVARS '( (* ;; "standard size fonts. Assumes only DEFAULTFONT set") (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD)) (* ; "default BOLD") (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC)) (LITTLEFONT DEFAULTFONT) (* ; " should usually be smaller") (TINYFONT LITTLEFONT) (* ; "and this one smaller still") (BIGFONT BOLDFONT) (* ; "should be bigger still") (TEXTFONT DEFAULTFONT) (* ; "default for text") (TEXTBOLDFONT BOLDFONT) (* ; "default for bold text") (* ;; "") (* ;; "Fonts for window system, processes") (* ;; "") (MENUFONT DEFAULTFONT T) (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD)) (* ; "if not supplied") (INTERRUPTMENUFONT DEFAULTFONT T) (* ; "used by control-B") (DEFAULTICONFONT MENUFONT) (* ; "for shrinking windows") (BACKTRACEFONT TINYFONT T) (* ; " for backtrace in debugger") (WINDOWTITLEFONT MENUFONT) ((WINDOWTITLEFONT WINDOWTITLEFONT) NIL) (* ; " used for titles of all windows") (* ;; "") (* ;; "Fonts for Exec") (* ;; "") (PROMPTFONT LITTLEFONT) (* ; "for printing out prompts") (INPUTFONT BOLDFONT) (* ; "for user typein in Exec") (PRINTOUTFONT DEFAULTFONT) (* ; " for intermediate typin in Exec") (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT)) (VALUEFONT DEFAULTFONT) (* ;  " for printing out values returned in Exec") (* ;; "") (* ;; "Fonts for prettyprinting") (* ;; "") (COMMENTFONT LITTLEFONT) (* ; "for comments ") (PRETTYCOMFONT BOLDFONT) (* ; " for words being defined") (CLISPFONT BOLDFONT) (* ; " for keywords & CLISP") (SYSTEMFONT DEFAULTFONT) (* ; " for %"system%" words(?)") (LAMBDAFONT BIGFONT) (* ; "for words being defined") (USERFONT BOLDFONT) (* ; " for %"user%" defined words")] (P (MOVD? 'NILL 'WINDOWTITLEFONT)) (FNS FONTSET FONTPROFILE FONTPROFILE.ADDDEVICE) (INITVARS (FONTESCAPECHAR (CHARACTER 6)) (FONTFNS) (FONTWORDS)) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (FONTSET 'STANDARD] (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS) (FNS FONTMAPARRAY) (INITVARS (\FONTMAPCACHE)) (P (SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) 1 FILERDTBL)))) (* ;; "FONT") (ADDTOVAR FONTDEFS [HUGE (FONTPROFILE (DEFAULTFONT 1 (MODERN 24) NIL (TERMINAL 8)) (BOLDFONT 2 (MODERN 24 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 18 MRR) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 36 BRR) NIL (MODERN 10 BRR)) (TEXTFONT 5 (CLASSIC 24) NIL (CLASSIC 10)) (TEXTBOLDFONT 7 (CLASSIC 24 BRR) NIL (CLASSIC 10 BRR] [BIG (FONTPROFILE (DEFAULTFONT 1 (MODERN 18) NIL (TERMINAL 8)) (TEXTFONT 5 (CLASSIC 18) NIL (CLASSIC 10)) (BOLDFONT 2 (MODERN 18 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 12 MRR) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 24 BRR) NIL (MODERN 10 BRR)) (TEXTBOLDFONT 7 (CLASSIC 18 BRR) NIL (CLASSIC 10 BRR] [MEDIUM (FONTPROFILE (DEFAULTFONT 1 (MODERN 14) NIL (TERMINAL 8)) (BOLDFONT 2 (MODERN 14 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 10) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 18) NIL (MODERN 10 BRR)) (TEXTFONT 5 (CLASSIC 14) NIL (CLASSIC 10)) (TEXTBOLDFONT 7 (CLASSIC 14 BRR) NIL (CLASSIC 10 BRR] [STANDARD (FONTCHANGEFLG . ALL) (FILELINELENGTH . 102) (FONTPROFILE (DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 10 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 8) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 12 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 10)) (COMMENTFONT 6 (HELVETICA 10) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 10) NIL (CLASSIC 10] [BIGGER (FONTPROFILE (DEFAULTFONT 1 (GACHA 12) NIL (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 12 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 12 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 10) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 10) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 14 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 12)) (COMMENTFONT 6 (HELVETICA 12) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 12) NIL (CLASSIC 10] [BIGGERNS (FONTCHANGEFLG . ALL) (FILELINELENGTH . 102) (COMMENTLINELENGTH 116 . 126) (FIRSTCOL . 60) (PRETTYLCOM . 25) (FONTESCAPECHAR . %) (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 12) (TERMINAL 8) (TERMINAL 8)) (ITALICFONT 1 (MODERN 12 BIR) (MODERN 8 BIR) (MODERN 8 BIR)) (BOLDFONT 2 (MODERN 12 BRR) (MODERN 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 10) (MODERN 6 MIR) (MODERN 8 MIR)) (BIGFONT 4 (MODERN 14 BRR) (MODERN 10 BRR) (MODERN 10 BRR] [NS (FONTCHANGEFLG . ALL) (FILELINELENGTH . 102) (COMMENTLINELENGTH 116 . 126) (FIRSTCOL . 60) (PRETTYLCOM . 25) (FONTESCAPECHAR . %) (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 10) (TERMINAL 8) (TERMINAL 8)) (ITALICFONT 1 (MODERN 10 BIR) (MODERN 8 BIR) (MODERN 8 BIR)) (BOLDFONT 2 (MODERN 10 BRR) (MODERN 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 8) (MODERN 6 MIR) (MODERN 8 MIR)) (BIGFONT 4 (MODERN 12 BRR) (MODERN 10 BRR) (MODERN 10 BRR]) (ADDTOVAR CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu) (RPAQQ FONTVARS ( (* ;; "standard size fonts. Assumes only DEFAULTFONT set") (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD)) (* ; "default BOLD") (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC)) (LITTLEFONT DEFAULTFONT) (* ; " should usually be smaller") (TINYFONT LITTLEFONT) (* ; "and this one smaller still") (BIGFONT BOLDFONT) (* ; "should be bigger still") (TEXTFONT DEFAULTFONT) (* ; "default for text") (TEXTBOLDFONT BOLDFONT) (* ; "default for bold text") (* ;; "") (* ;; "Fonts for window system, processes") (* ;; "") (MENUFONT DEFAULTFONT T) (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD)) (* ; "if not supplied") (INTERRUPTMENUFONT DEFAULTFONT T) (* ; "used by control-B") (DEFAULTICONFONT MENUFONT) (* ; "for shrinking windows") (BACKTRACEFONT TINYFONT T) (* ; " for backtrace in debugger") (WINDOWTITLEFONT MENUFONT) ((WINDOWTITLEFONT WINDOWTITLEFONT) NIL) (* ; " used for titles of all windows") (* ;; "") (* ;; "Fonts for Exec") (* ;; "") (PROMPTFONT LITTLEFONT) (* ; "for printing out prompts") (INPUTFONT BOLDFONT) (* ; "for user typein in Exec") (PRINTOUTFONT DEFAULTFONT) (* ; " for intermediate typin in Exec") (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT)) (VALUEFONT DEFAULTFONT) (* ;  " for printing out values returned in Exec") (* ;; "") (* ;; "Fonts for prettyprinting") (* ;; "") (COMMENTFONT LITTLEFONT) (* ; "for comments ") (PRETTYCOMFONT BOLDFONT) (* ; " for words being defined") (CLISPFONT BOLDFONT) (* ; " for keywords & CLISP") (SYSTEMFONT DEFAULTFONT) (* ; " for %"system%" words(?)") (LAMBDAFONT BIGFONT) (* ; "for words being defined") (USERFONT BOLDFONT) (* ; " for %"user%" defined words"))) (MOVD? 'NILL 'WINDOWTITLEFONT) (DEFINEQ (FONTSET [LAMBDA (NAME CHANGE-WINDOWS?) (* ; "Edited 23-Jun-88 10:46 by jds") (COND [NAME (LET [(TEM (FASSOC NAME FONTDEFS)) (OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY] (OR TEM (ERROR NAME "not a defined font configuration")) (* ;; "Looks up NAME on FONTSLST and sets apropriate parameters. entries are added to fontslst by FONTNAME.") (for X in FONTVARS when (AND (CL:SYMBOLP (CAR X)) (NEQ (CAR X) '*) (NEQ (CAR X) (CADR X))) do (SETTOPVAL (CAR X))) [MAPC (CDR TEM) (FUNCTION (LAMBDA (X) (/SETTOPVAL (CAR X) (CDR X] [PROG (BASICCLASSES) (for X in FONTPROFILE do (PROG (SEEN (NAME (CAR X)) (FONTS X)) LP [COND ((MEMB (CAR FONTS) SEEN) (ERROR "Circular font profile specification" X)) (T (push SEEN (CAR FONTS] [SETQ FONTS (CDR (COND ((OR (NULL (CADR FONTS)) (LISTP (CADR FONTS))) (*) (* ;  "This skips over the now-defunct NIL or list-of-escape sequence") (CDR FONTS)) (T FONTS] (COND ((OR (NLISTP FONTS) (LITATOM (CAR FONTS)))(* ;  "Indirect thru another's font spec") (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) ((NIL DEFAULTFONT) (* ;  "Don't let DEFAULTFONT loop thru itself") (AND (NOT (MEMB 'DEFAULTFONT SEEN )) 'DEFAULTFONT)) (CAR FONTS)) FONTPROFILE)) (GO LP))) (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* ;  "Now we have a font class datastructure") )) (AND NAME (/SETTOPVAL NAME FONTS)) (* ;; "NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.") )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] [for X in FONTVARS when (NEQ (CAR X) '*) do (COND ((LISTP (CAR X)) (EVAL (CAR X))) [(CADDR X) (SET (CAR X) (FONTCREATE (OR (GETTOPVAL (CAR X)) (EVAL (CADR X)) DEFAULTFONT) NIL NIL NIL 'DISPLAY] (T (OR (GETTOPVAL (CAR X)) (AND (CADR X) (SET (CAR X) (EVAL (CADR X] (CL:WHEN CHANGE-WINDOWS? (CL:WHEN (NEQ OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY)) (for X in (OPENWINDOWS) when (EQ OLDDEFAULT (DSPFONT NIL X)) do (DSPFONT DEFAULTFONT X))) (DSPFONT WINDOWTITLEFONT WindowTitleDisplayStream) (SETQ MaxValueLeftMargin (ITIMES 35 (STRINGWIDTH 'A DEFAULTFONT))) (MAPC CACHEDMENUS 'SET) [for W in (OPENWINDOWS) do [COND [(OR (EQ (WINDOWPROP W 'RESHAPEFN) 'DONT) (WINDOWPROP W 'MAINWINDOW] (T (* ;;  "don't reshape if can't or if this window is attached to another.") (SHAPEW W (WINDOWREGION W] (COND ((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN) (FUNCTION \TEDIT.PROCIDLEFN)) (WINDOWPROP W 'REPAINTFN)) (REDISPLAYW W]) (* ;; "Set the new font profile name, and return the old one, so he can restore later.") (PROG1 FONTNAME (SETQ FONTNAME NAME] (T (* ;  "He passed in NIL, so return font profile name in effect.") FONTNAME]) (FONTPROFILE [LAMBDA (PROFILE) (* lmm "10-Sep-86 12:33") [PROG (BASICCLASSES) (for X in PROFILE do (PROG (SEEN (NAME (CAR X)) (FONTS X)) LP [COND ((MEMB (CAR FONTS) SEEN) (ERROR "Circular font profile specification" X)) (T (push SEEN (CAR FONTS] [SETQ FONTS (CDR (COND ((OR (NULL (CADR FONTS)) (LISTP (CADR FONTS))) (* ;  "This skips over the now-defunct NIL or list-of-escape sequence") (CDR FONTS)) (T FONTS] (COND ((OR (NLISTP FONTS) (LITATOM (CAR FONTS))) (* Indirect thru another's font spec) (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) ((NIL DEFAULTFONT) (* Don't let DEFAULTFONT loop thru  itself) (AND (NOT (MEMB 'DEFAULTFONT SEEN)) 'DEFAULTFONT)) (CAR FONTS)) PROFILE)) (GO LP))) (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* Now we have a font class  datastructure) )) (AND NAME (/SETATOMVAL NAME FONTS)) (* NIL for the class-name means just establish the font-correspondences but  don't connect them up with a pretty class name.) )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] T]) (FONTPROFILE.ADDDEVICE [LAMBDA (NEWDEVICE OLDDEVICE) (* ; "Edited 3-Mar-93 14:46 by rmk:") (* ;; "Fills in all fontprofile specifications so that an entry for NEWDEVICE is present for each fontclass. Nothing is changed if the entry is already there, otherwise the specification for the class currently provided for OLDDEVICE will be used for NEWDEVICE.") (DECLARE (USEDFREE FONTDEFS FONTNAME)) (SETQ NEWDEVICE (U-CASE NEWDEVICE)) (SETQ OLDDEVICE (U-CASE OLDDEVICE)) [FOR FD IN FONTDEFS DO (FOR FC OLDSPEC IN (CDR (ASSOC 'FONTPROFILE (CDR FD))) UNLESS (LITATOM (CADR FC)) DO (SETQ FC (CDR FC)) (* ; "Skip over name") (CL:WHEN [SETQ OLDSPEC (SELECTQ OLDDEVICE (DISPLAY (CADR FC)) (INTERPRESS (CADDDR FC)) (PRESS (CADDR FC)) (CADR (ASSOC OLDDEVICE (CDDDDR FC] [SETQ FC (OR (CDR FC) (CDR (RPLACD FC (CONS] (* ;  "Fill in NIL's for missing DISPLAY, PRESS, or INTERPRESS") [SELECTQ NEWDEVICE (DISPLAY (OR (CAR FC) (RPLACA FC OLDSPEC))) (INTERPRESS (OR (CADDR FC) (RPLACA [PROGN [SETQ FC (OR (CDR FC) (CDR (RPLACD FC (CONS] (OR (CDR FC) (CDR (RPLACD FC (CONS] OLDSPEC))) (PRESS (OR (CADDR FC) (RPLACA [OR (CDR FC) (CDR (RPLACD FC (CONS] OLDSPEC))) (OR (CADR (ASSOC NEWDEVICE (CDDDR FC))) (PROGN (PROGN [SETQ FC (OR (CDR FC) (CDR (RPLACD FC (CONS] [SETQ FC (OR (CDR FC) (CDR (RPLACD FC (CONS] (PUSH (CDR FC) (LIST NEWDEVICE OLDSPEC])] (FONTSET FONTNAME]) ) (RPAQ? FONTESCAPECHAR (CHARACTER 6)) (RPAQ? FONTFNS ) (RPAQ? FONTWORDS ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FONTSET 'STANDARD) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS) ) (DEFINEQ (FONTMAPARRAY [LAMBDA (FONTCLASSES) (* lmm "28-Sep-86 14:23") (* ;; "Makes a font array from a font-mapping list of fontclasses. The array provides a fast map from font# to font classes/descriptors. This function caches the last array. If IMAGETYPES is given, then the FD's are pre-computed for the imagetypes it. Otherwise, the first use of the fontclass for that imagetype would cause the fontcreate to be done.") (PROG (FA (MAXFONT 0) (MINFONT 100)) [COND ((NULL \FONTMAPCACHE)) ((OR (NULL FONTCLASSES) (EQUAL FONTCLASSES (CAR \FONTMAPCACHE))) (RETURN (CDR \FONTMAPCACHE] [for F PRETTYFONT# in FONTCLASSES do (SETQ PRETTYFONT# (fetch (FONTCLASS PRETTYFONT#) of F)) (COND ((IGREATERP PRETTYFONT# MAXFONT) (SETQ MAXFONT PRETTYFONT#))) (COND ((ILESSP PRETTYFONT# 1) (ERROR "Invalid font number" PRETTYFONT# F)) ((ILESSP PRETTYFONT# MINFONT) (SETQ MINFONT PRETTYFONT#] (SETQ FA (ARRAY MAXFONT)) (for F in FONTCLASSES do (SETA FA (fetch (FONTCLASS PRETTYFONT#) of F) F)) (for I from 1 to MAXFONT unless (ELT FA I) do (SETA FA I (ELT FA MINFONT))) (SETQ \FONTMAPCACHE (CONS (COPY FONTCLASSES) FA)) (RETURN FA]) ) (RPAQ? \FONTMAPCACHE ) (SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) 1 FILERDTBL) (PUTPROPS FONTPROFILEPATCH COPYRIGHT ("Xerox Corporation" 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (16158 27897 (FONTSET 16168 . 22509) (FONTPROFILE 22511 . 25015) (FONTPROFILE.ADDDEVICE 25017 . 27895)) (28133 30403 (FONTMAPARRAY 28143 . 30401))))) STOP \ No newline at end of file diff --git a/sources/FONTPROFILEPATCH.LCOM b/sources/FONTPROFILEPATCH.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..df5b65550e3248ca1333e5ef53d87b513f5c90c7 GIT binary patch literal 10893 zcmcIqTWllOdFD{-OA^dh+TAQ{p*4=_Y(g24!Wmw4ap2X69En5mW^%OLi|d#xQY%Ij zDew~Srf41#_$evSCJvm7fuIJ8AP5pjyICMe3+Swv}Pspys~C8Arl+;n#CHDg8xo+(Kiv86F2Wl10T_>BC(Wf~EOJD4bGA_L%`V27VJyYWC3E2< zS!1Wjnqcu*$~4&KcD-|_*=PEodu545E$Gm#vM3!63a_&4#+p5&tXG^hby=`8&PGAq zsk&A%V^uQh9+1}T3U+j#uGlJ8RWPh(*j}&sjaGNq=Nf@X5yMc3aZP^f;qaZWpM ze1}f{lj+Td}H6I-R$wRh!<#*>!vx ztd!3{JJv?t#WKcRyTBZ5r?XaZ&7Q3}#Z0MIy^6hL`mBCln ztV)&MnJjIkvv#In7dQAuoC%t)MlW&Lc-{snc?MCAcJ?hWU=TunB{&KlX zkDsNF!`kJksfpag!)GsM_vf`+S|h&v=>GJ&#&I6~dcC2ohqXulqwNJpcBj8~{;=2xYwzLz ziN6nr-)c;}FL)=56I$a(Lgq*JUp(Z3cx1L8{pNFg{q4h|#u;9I>;9$v9~X*z_j4q| zTlwjKDZF1OisM}*@g}}~@bOOmr+E(K?aOl)FIpcSXeno0QI8&6e4fY&?SMk)yBBNI zwZ9bT?N>Oh+6BJ+{pL%DwHFRTf2ZAQc#3-ruC;xq5e{qjquRPyKRgeW@;499 zjkDcSm(WRK@d zlbqkbUE*Rtdhl1J$v_#uDor-{Yr#aq#yr?da^u4L-qRr|^%u2E%bS-DCqvOxY=Kpf zDXQhXb)&|Tiwo>cr&!&n*ut$@a={qinUAw-)+*ZoPa#ryNLB1Lr&MIgozrH6AxdB#WB~m9)7ivO~ct zTa}7+gPExm`wB$&Br!pXr00nVC2XD*?7|9S9;_>sQiU0bl(!XIR1tC5fC`Qypv`%O zIm%6P0ro+iblf>;Htl4Pb4cq6R{S*|8O&mFW5M4y z7m~qqLfMZeIcu+uGSf_r?7N;8Mv>~^+VcZNLy zB`S)P-K#1ISxlOIiZEPHd5k{zMmR#;ck{&Dp1H6uxH??Xt%hZ0?2bb;iWK*kqn%| z7%?D%MpRlJuJBBCIX_ZX$;9y|wD5@S=By0r`86kP%iaKqBaaker@8r7=?fv5;Z>d& ze-6y+yIu28SJ5w!kW|xWnD*j1EfiknY4di-65rvssbcI;lVw9(m)Y>;@YKr_&cwsN z;EMhqmqSi!H^aQzeg7czAGz@FEU(=C;4ruUvPiq{<-+0p&nqv&?_wtmdfKfI4?;i5 zg&%%4*Vx{ke(^B;yJZjm$A>xX!MAejFYMnHRPKKPNZNxP75b)v3CN;EMy=(*udBcS zm?geo`{0WDLZxzZd3}3&Iv0j4PWZ;b$CpCUq=MgLS|E7<^yj+rX{1uC^bc9^)iC+0^fbT5T1vbsS5-@*S$g5uV4-1 z3TLqJWv~L>L6H8)F$&go{!IQr53*rgMUVL=ZGZ#s=n&w)cwP%>UvD?2E`)27KVAOe za&1!k;}2?+;mPHxm!Damc&J~@au>L{yuYfw`7AlizlWat>+DDWQ26am;iC_DpH#^6 zNPX8SeDwXojl=cut^I!`r#hF*OAG-)h4_E7J5%B3O6QAzc<@TD;dM&CDxJ@XEW#-r zmd@||=hx2f|Mx}VvbpKa$s7-Hw6&%34V085)eZ{}F=nIjHR9fP%zH6!cwvpC&dV08 zxTwZIijuD#iq%vC7q`wg>g|@7UOU6x+sz)`c!cWHr9v466#X)E=vk28weW%xdZlc= z@y4+)Sv2}8d+jwAAN>eq1hRFtvG*Nsc-Jw>2-&l246ZT8lq9BC2lxTL5Cz0Pj76LTwC`=?hopnM!nZy z{nj^|yzcbpnAPtOcX3bacG~wwQeeM1p!2ODD-lI;RpS;@6J?b1VEU?+rt6$o5zY(= z1XZyJ3SE8J9xz7RMAC7gwDjYNj?mNv7AKo`TzOqlWRd(>f4e(uH`uU0thaHf+bF`j zcp?X2QP(N*$YTK!4^fXmJ#4VuB4zkEtUqYA+guaQ8kbpWMDp|4fz9pKojc85fZ^KL zU5=tk344sFWvkm`gXUeXY(kLaxw;5j@{xKZgxg&lP+|#(BoX>YlQ zWBq&mL38)Z)Rb&C`~7C$2aeDaT?fbIWW<+b@n7=0J9hv**b@dHu@oT%)^BaG4*H$` zaBr{OYBq=+&!?4*vg?yk^uzg*g7nC+kM`*HJqAA?^t$cY6+-qvoped0Nl62*xLWDd z{q0_>v(xI_@y^eWyMpPBTY;PMllpF;`}*YyyNwtd^y-^U8mTmzw})g=;wyUn;GV4T zJ@Rf0b_SvDU6(`vu!bWrz+~0K^1%2cbl6eO#p%HRVWKD(~r1xgtV~- zWei9e-63yFclQQdAx^QpArPg@Nf8MPQbNLedrjy8|0H9b=gpFbsMt;7axH>kvxmu6 z3&STOGD-ur&nZftEDB3jM>3Bt--(=--w-A{iP^~cko1SpX|FjL_Ncp7L=SYvpVTnH zY-j*6Jw=Tw7$pI=7K%Dv!5G5rHYwr=(JwIE&4QzN?kS?O+iUcZm&hpIHGojlG-u>! zz5-ONo#wrFIN}!>ha?oedZUUV(RlEV7~@Jrg#VQYoucEFK0cGPt7%;HF+8h4x%jlw80NARrwnSKPCW2bD^)TyBSdyVi&e2P z9;7QMUALF>B`bp!PkeL)DUUpatncECYx&ZOl^652F@Y6nhz8u5v-gfDd&SXHj5c|A z2LYgrs$IsBgx;bC?tyW1kx5J%=g}B0(hLxTKTP}302>J!*%>K@%RDa5#v((fii;2~ zxR_#KJb-C~Zjw$gD#XaSl5tn^bQYaD6Sst;aMhEzEJ{;bp#o_NnULv7AOQ`D=Y zXBfC%A4Us)aon%<4V2I1XJ@f^>1%x2ta7IZS=O`S-C^!|)!Yk7W zA3UC7`VkJ$5$%D6U!{{2f|$rU=|FtBVZRL$A-%Ek$`Azj)>C;u^+>b4V8^G);2(8rGF!OHsXspAB$BgA%+)xZYT3D_uPh zvUdKO?K){f!j+bOqY*R^x_qVkkuDX9wvp=wZaad_Ev0OEzATf$34W{xG)UH9h0zcf zV4T0-5vF`meW6q8X?gv?WsVC=W)Em1o-wWU-S?O<@=uhuqeWlG98r%@ia9)zs)OxUr8W0{w(c;0dVY z2m}2C@&wuh&~hqOH(knOBSpR`8s0pRuwy0(0+}Rec64lCdDh$Z6UtA{cQF-oB4RQIfRP|C4ha0QmkKG9T9jCD>J>pg|3p8mM8o-Dpp)G$~% zajK_B_>fFanl_e4_Ux13gi~uJUnG&>uoU>S#^{q5++{7GpY*v1lad Date: Mon, 22 Feb 2021 22:19:07 -0800 Subject: [PATCH 24/31] Now that XQuartz supports m1 mac, don't need separate instructions (#179) --- README-mac.md | 24 ------------------------ README.md | 19 +++++++++++++------ 2 files changed, 13 insertions(+), 30 deletions(-) delete mode 100644 README-mac.md diff --git a/README-mac.md b/README-mac.md deleted file mode 100644 index 9ed40ded..00000000 --- a/README-mac.md +++ /dev/null @@ -1,24 +0,0 @@ -# Running Medley Interlisp on a Mac. - -Running on MacOS requires an X server, and building on a Mac requires X client libraries. An X-server for x86 can be freely obtained at https://www.xquartz.org/. For the new arm64 MacOS 11, you'll need https://x.org which you can get via MacPorts or Brew. - - -### Middle-mouse tweak - -if you don't have a 3-button mouse (wheel = middle mouse) -you can enable FN-left to be middle. Run in a terminal: - -```sh -defaults write org.macosforge.xquartz.X11 enable_fake_buttons -boolean true -defaults write org.macosforge.xquartz.X11 fake_button2 fn -defaults write org.macosforge.xquartz.X11 fake_button3 none -``` - -To turn the settings back to the original default values do: - -```sh -defaults write org.macosforge.xquartz.X11 enable_fake_buttons -boolean false -defaults delete org.macosforge.xquartz.X11 fake_button2 -defaults delete org.macosforge.xquartz.X11 fake_button3 -``` - diff --git a/README.md b/README.md index af140107..68295c36 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,13 @@ # Medley -This repo is for the Lisp environment of [Medley Interlisp](https://Interlisp.org). We've made great process in sorting out what we have (some dusty corners notwithstanding), but there's quite a bit more work to do. Please report problems! -See [Medley Interlisp Introduction](https://github.com/Interlisp/medley/wiki/Medley-Interlisp-Introduction) for an overview. + + + +This repository is for the Lisp environment of [Medley Interlisp](https://Interlisp.org). + +We've made great process in sorting out what we have (some dusty corners notwithstanding), but there's quite a bit more work to do. Please report problems! + +See [Medley Interlisp Wiki](https://github.com/Interlisp/medley/wiki/) for an overview, and other pointers. A sub-project is [Interlisp/maiko](https://github.com/Interlisp/maiko), which is the implementation (in C) of the Medley virtual machine. @@ -10,9 +16,10 @@ A sub-project is [Interlisp/maiko](https://github.com/Interlisp/maiko), which is ### Setting up X -Medley Interlisp needs an X-Server to manage its display. Most Linux desktops have one. -If you have a high-resolution display, note that much of the graphics was designed for a low-resolution display, so an X-server that does "pixel doublilng" is best. (E.g., Raspberry Pi does pixel doubling on 4K displayes). -* It also presumes you have a 3-button mouse (the scroll-wheel on some mice act as one with some difficulty.) See [README-mac.md](./README-mac.md) for more info on dealing with that. +Medley Interlisp needs an X-Server to manage its display. Most Linux desktops have one. There are a number of free open source X-servers for windows. Mac users should head over to [XQuartz.org](https://xquartz.org/releases) -- be sure to pick a version if you have a newer Mac. + +If you have a high-resolution display, note that much of the graphics was designed for a low-resolution display, so an X-server that does "pixel doublilng" is best. (E.g., Raspberry Pi does pixel doubling on 4K displays.) It also presumes you have a 3-button mouse; the scroll-wheel on some mice act as one with some difficulty.) XQuartz Preferences/Input has "Emulate three button mouse" option. + ### Running Medley Interlisp @@ -78,8 +85,8 @@ Each directory should have a README.md, but briefly - library -- packages that were supported (30 years ago) - lispusers -- packages that were only half supported (ditto) - loadups -- has sysouts and other builds -- makesysout -- files for making new sysouts for various configurations, based on basics - patches -- for cases where reloading doesn't wor +- scripts -- some scripts for fixing up things - sunloadup -- support information for making a new lisp.sysout from scratch - sources -- sources for Interlisp and Common Lisp implementations - unicode -- data files for support of XCCS to and from Unicode mappings From 81ce9354e27855a37229dc6cccead136e0e7e457 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Tue, 23 Feb 2021 10:21:37 -0800 Subject: [PATCH 25/31] MODERNIZE: initial push This is the rename of MACINTERFACE, including a doc file MODERNIZE.TXT. When ready to install it in a loadup, replace MACINTERFACE with MODERNIZE in sources/LOADUP-FULL. --- lispusers/MODERNIZE | 1 + lispusers/MODERNIZE.LCOM | Bin 0 -> 7748 bytes lispusers/MODERNIZE.TXT | 76 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 77 insertions(+) create mode 100644 lispusers/MODERNIZE create mode 100644 lispusers/MODERNIZE.LCOM create mode 100644 lispusers/MODERNIZE.TXT diff --git a/lispusers/MODERNIZE b/lispusers/MODERNIZE new file mode 100644 index 00000000..37ff459a --- /dev/null +++ b/lispusers/MODERNIZE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 16:47:48"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;8 20161 changes to%: (VARS MODERNIZECOMS) (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP MODERNWINDOW.BUTTONEVENTFN MODERN-ADD-EXEC MODERN-SNAPW TEDIT.MODERNIZE TOTOPW.MODERNIZE MODERNWINDOW.BUTTONEVENTFN.ANYWHERE MACWINDOW.BUTTONEVENTFN.ANYWHERE MACINT-ADD-EXEC TEDIT.MACINTERFACE TOTOPW.MACINTERFACE MACWINDOW.BUTTONEVENTFN INCORNER.REGION) previous date%: "22-Feb-2021 13:55:51" {DSK}kaplan>lisp>MACINTERFACE.;2) (PRETTYCOMPRINT MODERNIZECOMS) (RPAQQ MODERNIZECOMS [ (* ;; "Externals") (COMS (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP) (INITVARS (MODERN-WINDOW-MARGIN 25))) (* ;; "Internals") [COMS (FNS MODERNWINDOW.BUTTONEVENTFN MODERNWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE) (* ;; "Add some Meta commands") (FNS TEDIT.MODERNIZE TEDIT.SELECTALL) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MODERNIZE) (* ;; "Inspector") (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MODERNWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW) (* ;; "New execs") (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC) (* ;; "Existing exec of the load") (MODERNWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MODERNWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MODERN-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MODERNWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MODERNWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MODERNWINDOW.BUTTONEVENTFN)))) WINDOW]) (MODERNWINDOW.SETUP [LAMBDA (ORIGFN MODERNWINDOWFN ANYWHERE) (* ; "Edited 22-Feb-2021 16:42 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MODERNORIG-.") (* ;; "If MODERNWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into modern window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MODERNWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MODERNWINDOWFN THEN (MOVD MODERNWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MODERNWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMODERNWINDOW [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN NIL)) WINDOW]) (MODERNWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 22-Feb-2021 16:45 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MODERN-WINDOW-MARGIN 25) (* ;; "Internals") (DEFINEQ (MODERNWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MODERN-WINDOW-MARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW WINDOW STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MODERNWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 22-Feb-2021 16:27 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MODERN-WINDOW-MARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH BOTTOM OF MAINREGION))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MODERN-WINDOW-MARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH BOTTOM OF MAINREGION))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MODERN-ADD-EXEC [LAMBDA U (* ; "Edited 22-Feb-2021 16:41 by rmk:") (LET [(PROC (APPLY (FUNCTION MODERN-ORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MODERNWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MODERN-SNAPW [LAMBDA NIL (* ; "Edited 22-Feb-2021 16:41 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MODERN-ORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) (TOTOPW.MODERNIZE [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MODERNWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (* ;; "Add some Meta commands") (DEFINEQ (TEDIT.MODERNIZE [LAMBDA NIL (* ; "Edited 22-Feb-2021 16:28 by rmk:") (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN) (MODERNWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE))]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MODERNIZE) (* ;; "Inspector") (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MODERNWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW) (* ;; "New execs") (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC) (* ;; "Existing exec of the load") (MODERNWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MODERNWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MODERN-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4575 8401 (MODERNWINDOW 4585 . 5243) (MODERNWINDOW.SETUP 5245 . 7189) (UNMODERNWINDOW 7191 . 7585) (MODERNWINDOW.UNSETUP 7587 . 8399)) (8466 16070 (MODERNWINDOW.BUTTONEVENTFN 8476 . 13078) (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE 13080 . 13451) (NEARTOP 13453 . 13889) (NEARESTCORNER 13891 . 14770) (INCORNER.REGION 14772 . 16068)) (16128 17546 (MODERN-ADD-EXEC 16138 . 16569) (MODERN-SNAPW 16571 . 17114) (TOTOPW.MODERNIZE 17116 . 17544)) (17587 18670 (TEDIT.MODERNIZE 17597 . 18339) ( TEDIT.SELECTALL 18341 . 18668))))) STOP \ No newline at end of file diff --git a/lispusers/MODERNIZE.LCOM b/lispusers/MODERNIZE.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..dd9ee7b19a9fe657b7ca48bee61fe80eb830cebd GIT binary patch literal 7748 zcmb_hPmCK^8Mimkrhvn4R5+wG`eadRquTP{U9VH69(%^?N$eT#%s9JS7ExzC$vW$` z7u(x3LLh;9L5NFH#RU#js(M3h+Db@(a^X_W9FkK{+#7M=gy8r7%-CbE-9I$Z+VkGL z_r34$@B7~8n5tEELrYZkx|Yz5s!5kEO;H`CT-PY78;)kxb-Nj*%T1+nUD*mu#v?Jd zuYw(prcyMMNmSjNiA*Y!ru2F-w^7U$q7;iB431B_J-0)HK1C_=6V<-{(-&JKcR0Fw z)IRC8`&a9OgLd!gvD@jn_p-_S)!W^1LX58Vx}%d*zP4einq}xOYso8xI0$Vfl#?M& zOQk4XD5lcIYzEYC4qg8|_qCJZ=(!^G2jjzT|2B1TeuE!EIEAXGy&l>3MuXEaP4k{i zCZp78kHK+Jrd%Gd=n9Jc$n-4Trk5GQs+v22R?`ly%)JYXKG>z<)mWl?bI|&qlQvB>*&A&IOc?hh&)%RaDS~T70o|-dTs$> z(v6B~8Jd-}v@P8<;&d`}U+oS~N8AUX??})Kvc-J9m`_LP3`b_(dKCxxoFuPg;sLR# zs1_nIozmn>tW%1F$Z-n27z%|}O1JSD`WpLqKPd*Kr`YJD^IvCQ55%1ECSUhD|Ku-9 ztD#taotiC25Nujzld|cViA;|6b;E91npj2Y6m4m8OUu?Qwhd06PX~P{=nJ|0lD89c zWeXJCmo8A#(uA8Ng0J$6-hi2)8l^vTWj3KqOEZ*)rka+%MNR0ld3}pbkWQItMF$0f zLo?m8O;y-EG+YUV&Iv_xZLh6`YXhclZizSfh=``c(h6+36n5k5P4cWv?lq*oBUgYj%P%c9i)2Jv8!GgA9 zY1=KO&Wwj85}y-X>O7mV_Znrho{%q~!2%$!WmFtEITbvYqm5-|r1d=2l}1@rD9c!4 z2%KR0N`M}1q$uV&ZZ;Lj7wJuk?rN5~n*cgBOe4Y5NIWtFKr$FSW?+LX)E%Dk|NGBL z|L3~oikl9BL*MOl8#7*><+_}TgUsf`pk67n#o5}Sp`IcVmZ38B`_Qi zut8-LnX7@vb)N8z=(wx%LI4?JUfn3scEWDF@@Bm z8*(^@D;z|;=$arpRcVuUy8X`JuG1a&TonnT*S=?uhi>~AFA=;ls)VB^1T%38|N5zw z(7E#reIC5RK6_98v-g!x-g+;5z=wC(3?ulIUY(2Q7VPHZmY50Vmeb6uhbj%A4LoA9(I?vPtD{xL- ztazOt9eILj>qn~(O6Dr3)LkvVBSrna&V?7!bXS!>PU-08$_JNAN6I%Z%uPQjrbDqT z5Ogk20vI!A%>s`A;o1&mfhC5fSeorf_sRmA*bH;aY$i)~O=+@)X--IbST?ne7iO!j z8o>Jk$F7En>*NOIiaGmrlB_>EHdmou|C_|f#?-qPP-@>kO@c*sKuo2gl61!ugP@i?X2 zG~c)ZPNdjn8Nw53my0xWOPG}L6MF~s#=w06wugQe4toj>KUxci?$jRtq4tYAwMQ4X zAHVZ*eEc>?z|})BH_^}>iH{eOc>iyL1{747V2}VPNCHvQ0HlC( zPdn=#TsJp~i*>|{uONWje_n*6dk?U+N{6tUGHU?k7CpqRDtJm6pt$!G49A4W0 z^R=UYy!`Ip8{hlOyZ^?0$upCP7s`o)HQN@qr#z{;-Oz2D5XMTgS!X^D+>^@-o{@Q3 z>#&Qe(%?67TdU)nak%T4a-Gk9&vFhNF9=nOy$aIdYu6B!d$~H8_@Ngd)mY&&7zLFu+3GSeq8E z+)~--IPwl#BxW_0?d{+!#bV#5D_1D0y*74-{dR8@MJtZ2|3VG9K&vPzuY@3|8@j{0 zelZ!i!tdp60l*ZGW0l}U@1My@kaWz^ z9?+nO%h-0yM4`T~J6aow+{}{ww6ln4BS!w`7z%JGG+9+yECL_w!A>y zF}2YazdINnjj+dX-Oh;G#F*)}d(?4nb^G0MchJX6`>=h&`s&^}Y!kU%usDoHxSp2i z1x;lY6@3#xG*hB7wJg?WM6WbpGfUY^I=TZ>qQ3-nqJigIraE-pW4C|$DTb*wW)GGj z6p7jl(3WrKONzxnv`kn~-J7SkZ$l3YWQhppP|I7zqN}WBe(D?lAMUoo*^5;QU^|XfoY># z!}baDPlypj#6ZyUGS4xQQ{bMOYM@%0XtFuP4_adpW3z0qnzhlCt#ooAP&~2>W;o=q zgo7W_I0kXtkrS4He5hVL7-+>RV4Qu|@y&+b??66uvLlhrSgv|W=BmV8wusE3T4YJc zErqaU8yAP_vR(W0fw^q?*@3uh$Fitfwr_EqF^&H}F%{hXdEzCw^V6bW+3GWWKDc4l IyLmI=e>mHm-~a#s literal 0 HcmV?d00001 diff --git a/lispusers/MODERNIZE.TXT b/lispusers/MODERNIZE.TXT new file mode 100644 index 00000000..50138230 --- /dev/null +++ b/lispusers/MODERNIZE.TXT @@ -0,0 +1,76 @@ +MODERNIZE documentation + + Ron Kaplan, February 2021 + +[A renaming of an earlier MACINTERFACE package] + +MODERNIZE is a simple Lispusers package that changes the mouse actions on Medley windows so that moving and shaping can be done in a way that approximates the behavior of windows on modern platforms, Mac, Windows, etc. It also adds some meta keys to also emulate more conventional behavior. + +Thus, for a window that has been created or transformed in this way, you can move the window by left-clicking in the title bar and dragging the window's ghost region. Or you can reshape by clicking in a corner of the title bar or near the bottom of the window to drag out the ghost region by that corner. + +The menu behavior for other buttons or buttons clicked in other positions is unchanged. + + +For bottom corners, "near" means inside the window within MODERN-WINDOW-MARGIN (initially 25) pixels above or to the left/right of the corner. + +For top corners, "near" means within the title bar and within the margin from the left/right edges. + +(Windows that don't have a title-bar, like Snap windows, can be set up so that moving can happen by clicking anywhere, and shaping at the top is determined by the margin inside the window region.) + +When the package is loaded, this behavior is installed for the following kinds of windows: + + Tedit + Debugger/break + Sedit + Inspector + Snap + Exec + File Browser + Grapher + +The function MODERNWINDOW.SETUP establishes the new behavior for classes of windows: + +(MODERNWINDOW.SETUP ORIGFN MODERNWINDOWFN ANYWHERE) + +ORIGFN is either the name of the BUTTONEVENTFN for a class of windows (e.g. \TEDIT.BUTTONEVENTFN for Tedit windows) or it is a function that creates windows of a particulate kind (e.g. SNAPW or ADD-EXEC). + +MODERNWINDOW.SETUP moves the definition of ORIGFN to the name (PACK* 'MODERN-ORIG- ORIGFN), and then provides a new definition for ORIGFN that does the moving or reshaping for clicks in the triggering locations, and otherwise passes control through to the original definition. + +If ORIGNFN is a button event function, then MODERNWINDOWFN should not be specified. In that case a new definition for ORIGFN is constructed to provide the desired windowing behavior. + +Otherwise, if ORIGFN is the function that creates windows of a class (e.g. SNAPW), then a MODERNWINDOWFN should be provided to create such windows (by calling (PACK* MODERN-ORIG- ORIGFN)). The definition of MODERNWINDOWFN replaces the original definition of ORIGFN. + +If the flag ANYWHERE is non-NIL, especially for windows without a title bar, then the moving behavior is triggered by a click anywhere in the window (except the corners). + +Because this works by redefining existing functions, it is important that the MODERNIZE package be loaded AFTER Tedit and Sedit, if those are not already in the sysout. And it should be called to upgrade the proper functions for other window classes that might later be added. + +Provided these capabilities are already loaded, the following window classes are "modernized" when MODERNIZE is loaded are: + + TEDIT + SEDIT + INSPECTOR + SNAP + DEBUGGER + EXEC + TABLEBROWSER + FILEBROWSER + FREEMENU + GRAPHER + PROMPTWINDOW + +If it is not known or it is inconvenient to systematically upgrade a button function or a window-creation function, the new behavior can be provided after a particular window has been created, by invoking + +(MODERNWINDOW WINDOW ANYWHERE) + +This saves the windows existing BUTTONEVENTFN as a window property PREMODERN-BUTTONEVENTFN, and installs a simple stub function in its place. + +If things go awry: + +(UNMODERN.SETUP ORIGFN) is provided to restore the original behavior for windows whose buttonevent function is ORIGIN. + +(UNMODERNWINDOW WINDOW) restores a modernized window (via MACWINDOW) to its original state. + +Known issue: Clicking at the bottom-right corner of Tedit windows sometimes doesn't catch the new behavior--there seems to be a conflict with Tedit's window-splitting conventions. Clicking a little further into the window seems more reliable. + + + From 8066be6a74299333a83241f7b5f2697f1cb2a9ee Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Tue, 23 Feb 2021 17:34:09 -0800 Subject: [PATCH 26/31] CLIPBOARD: updated with the elaborated xclip commands, to be tested --- library/CLIPBOARD | 2 +- library/CLIPBOARD.LCOM | Bin 5112 -> 5104 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/library/CLIPBOARD b/library/CLIPBOARD index ad645445..1f71ea38 100644 --- a/library/CLIPBOARD +++ b/library/CLIPBOARD @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 14:39:46"  {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;48 8988 changes to%: (VARS CLIPBOARDCOMS) (FNS GETCLIPBOARD PUTCLIPBOARD CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) previous date%: "15-Feb-2021 23:48:39" {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;47) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 22-Feb-2021 14:23 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-PASTE-STREAM)) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 22-Feb-2021 14:38 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-COPY-STREAM)) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 15-Feb-2021 23:43 by rmk:") (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;; "If for some reason TTY process doesn't have a window (e.g. TEXEC), we can only do the character printing. Presumably the right thing to do--no image objects in an exec.") (* ;; "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string quotes.") (LET [(STR (GETCLIPBOARD)) (WINDOW (PROCESS.WINDOW (TTY.PROCESS] (IF (AND WINDOW (WINDOWPROP WINDOW 'COPYINSERTFN)) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) (CLIPBOARD-COPY-STREAM [LAMBDA NIL (* ; "Edited 22-Feb-2021 14:38 by rmk:") (LET ((OST (UNIX-GETENV "OSTYPE"))) (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbcopy" "xclip")]) (CLIPBOARD-PASTE-STREAM [LAMBDA NIL (* ; "Edited 22-Feb-2021 14:23 by rmk:") (LET ((OST (UNIX-GETENV "OSTYPE"))) (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbpaste" "xclip")]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1376 6335 (INSTALL-CLIPBOARD 1386 . 3208) (GETCLIPBOARD 3210 . 3832) (PUTCLIPBOARD 3834 . 4336) (PASTEFROMCLIPBOARD 4338 . 5256) (LISPINTERRUPTS.PASTE 5258 . 5679) (CLIPBOARD-COPY-STREAM 5681 . 6005) (CLIPBOARD-PASTE-STREAM 6007 . 6333)) (6336 7095 (TEDIT.COPYTOCLIPBOARD 6346 . 6627) ( TEDIT.EXTRACTTOCLIPBOARD 6629 . 7093)) (7096 8635 (SEDIT.COPYTOCLIPBOARD 7106 . 8633))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Feb-2021 17:31:20"  {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;51 9084 changes to%: (FNS CLIPBOARD-PASTE-STREAM CLIPBOARD-COPY-STREAM) previous date%: "23-Feb-2021 11:34:57" {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;50) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 23-Feb-2021 11:32 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-PASTE-STREAM)) (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 23-Feb-2021 11:32 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-COPY-STREAM)) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 15-Feb-2021 23:43 by rmk:") (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;; "If for some reason TTY process doesn't have a window (e.g. TEXEC), we can only do the character printing. Presumably the right thing to do--no image objects in an exec.") (* ;; "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string quotes.") (LET [(STR (GETCLIPBOARD)) (WINDOW (PROCESS.WINDOW (TTY.PROCESS] (IF (AND WINDOW (WINDOWPROP WINDOW 'COPYINSERTFN)) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) (CLIPBOARD-COPY-STREAM [LAMBDA NIL (* ; "Edited 23-Feb-2021 17:31 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (LET (STRM (OST (UNIX-GETENV "OSTYPE"))) [SETQ STRM (CREATE-PROCESS-STREAM '(CL:IF (STRPOS "darwin" OST) "pbcopy" "xclip -i -selection clipboard")] (\EXTERNALFORMAT STRM CLIPBOARD-FORMAT) STRM]) (CLIPBOARD-PASTE-STREAM [LAMBDA NIL (* ; "Edited 23-Feb-2021 17:29 by rmk:") (LET (STRM (OST (UNIX-GETENV "OSTYPE"))) (SETQ STRM (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbpaste" "xclip -o -selection clipboard"))) (\EXTERNALFORMAT STRM CLIPBOARD-FORMAT) [SETFILEINFO STRM 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] STRM]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1309 6431 (INSTALL-CLIPBOARD 1319 . 3141) (GETCLIPBOARD 3143 . 3517) (PUTCLIPBOARD 3519 . 3924) (PASTEFROMCLIPBOARD 3926 . 4844) (LISPINTERRUPTS.PASTE 4846 . 5267) (CLIPBOARD-COPY-STREAM 5269 . 5771) (CLIPBOARD-PASTE-STREAM 5773 . 6429)) (6432 7191 (TEDIT.COPYTOCLIPBOARD 6442 . 6723) ( TEDIT.EXTRACTTOCLIPBOARD 6725 . 7189)) (7192 8731 (SEDIT.COPYTOCLIPBOARD 7202 . 8729))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.LCOM b/library/CLIPBOARD.LCOM index 4fe0bc17dfff199c7e7a39757c956db307d70f77..f296faefa7108b89bb54eabc7c05ec251a498f93 100644 GIT binary patch delta 817 zcma))%Wl&^6hLjK4J62+DKwP;i7OWxM>Lhkj?>g2RM!vT$gy3=LR2k_ywpUB;xq}b zA7D+H1)so%MWrg@v4Njp!!NLDckE!CqEx6|FpH}@qnUfpnVDbN(U*bEeAQXfgP-ups==4S`NKj<#j5CksC)p&l8_BPC;`H1XYn&*zZ)|@$ z{83*1eE6N>MG1B*k8P_O04jmzI+_}2u5MJJ1jJ0&qDhW*EE}K1uj2>F1-yOvCoN(l z;Xn0!%Lz;eOhDjnmJKZ+sR%<7C5XTf0lQ7jP_*}M%kMJY)zs@PKN$i3#fnd`2nIUC zC_+?MI$BDeFbxFNz^{M@0=R@RDzDj=x9O_Bo;O{;q6VY~$IuiNPV1)A^x0&)dD_vM zqj*VxUE@h$_>O9y9tKgwF1v{P?1F{XfY)rrGJz*eJ+}&6vo?6q>2Xo-9B}=5BkaH8 zfP2~KcKVR-Kz`Wjwi=^O*n?=P9@Yj;E{ETP(%q&f*#qAXG?7NBYb(T}to(}hCmoGGrbVvLv9F`HPtKcNG;0EVNxCSfwv VitCX-4U#?cl>BeC$Is|5hnNwnuZYW}D(g+IPR^1ra zk`v>fa6u%-OHBF;TdYs_+;AOk3VA~g-m$DBumApi0e<7)L(e+cC@~jdg{61$$UVj(@KO? zC{`#6W^mN95_BA2A3j4q8sRhV#|?9aU;}!9$q||T`v*T9OjZI z@MrqeY1^vOEQkeQ9<{c&dJK>OnBGRK+k1@bsSJLVOlzR%GR?a1AN&^o@Ehx?m$6@? CC(4lk From 1bdbf22516df15c07b73dd71d19fc5daa1edfe5c Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Tue, 23 Feb 2021 22:13:40 -0800 Subject: [PATCH 27/31] CLIPBOARD: fix typo --- library/CLIPBOARD | 2 +- library/CLIPBOARD.LCOM | Bin 5104 -> 5094 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/library/CLIPBOARD b/library/CLIPBOARD index 1f71ea38..dbe83449 100644 --- a/library/CLIPBOARD +++ b/library/CLIPBOARD @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Feb-2021 17:31:20"  {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;51 9084 changes to%: (FNS CLIPBOARD-PASTE-STREAM CLIPBOARD-COPY-STREAM) previous date%: "23-Feb-2021 11:34:57" {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;50) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 23-Feb-2021 11:32 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-PASTE-STREAM)) (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 23-Feb-2021 11:32 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-COPY-STREAM)) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 15-Feb-2021 23:43 by rmk:") (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;; "If for some reason TTY process doesn't have a window (e.g. TEXEC), we can only do the character printing. Presumably the right thing to do--no image objects in an exec.") (* ;; "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string quotes.") (LET [(STR (GETCLIPBOARD)) (WINDOW (PROCESS.WINDOW (TTY.PROCESS] (IF (AND WINDOW (WINDOWPROP WINDOW 'COPYINSERTFN)) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) (CLIPBOARD-COPY-STREAM [LAMBDA NIL (* ; "Edited 23-Feb-2021 17:31 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (LET (STRM (OST (UNIX-GETENV "OSTYPE"))) [SETQ STRM (CREATE-PROCESS-STREAM '(CL:IF (STRPOS "darwin" OST) "pbcopy" "xclip -i -selection clipboard")] (\EXTERNALFORMAT STRM CLIPBOARD-FORMAT) STRM]) (CLIPBOARD-PASTE-STREAM [LAMBDA NIL (* ; "Edited 23-Feb-2021 17:29 by rmk:") (LET (STRM (OST (UNIX-GETENV "OSTYPE"))) (SETQ STRM (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbpaste" "xclip -o -selection clipboard"))) (\EXTERNALFORMAT STRM CLIPBOARD-FORMAT) [SETFILEINFO STRM 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] STRM]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1309 6431 (INSTALL-CLIPBOARD 1319 . 3141) (GETCLIPBOARD 3143 . 3517) (PUTCLIPBOARD 3519 . 3924) (PASTEFROMCLIPBOARD 3926 . 4844) (LISPINTERRUPTS.PASTE 4846 . 5267) (CLIPBOARD-COPY-STREAM 5269 . 5771) (CLIPBOARD-PASTE-STREAM 5773 . 6429)) (6432 7191 (TEDIT.COPYTOCLIPBOARD 6442 . 6723) ( TEDIT.EXTRACTTOCLIPBOARD 6725 . 7189)) (7192 8731 (SEDIT.COPYTOCLIPBOARD 7202 . 8729))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Feb-2021 22:13:09"  {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;52 9082 changes to%: (FNS CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) previous date%: "23-Feb-2021 11:34:57" {DSK}kaplan>Local>medley3.5>git-medley>library>CLIPBOARD.;50) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 23-Feb-2021 11:32 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-PASTE-STREAM)) (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 23-Feb-2021 11:32 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (CL:WITH-OPEN-STREAM (s (CLIPBOARD-COPY-STREAM)) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 15-Feb-2021 23:43 by rmk:") (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;; "If for some reason TTY process doesn't have a window (e.g. TEXEC), we can only do the character printing. Presumably the right thing to do--no image objects in an exec.") (* ;; "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string quotes.") (LET [(STR (GETCLIPBOARD)) (WINDOW (PROCESS.WINDOW (TTY.PROCESS] (IF (AND WINDOW (WINDOWPROP WINDOW 'COPYINSERTFN)) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) (CLIPBOARD-COPY-STREAM [LAMBDA NIL (* ; "Edited 23-Feb-2021 22:11 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (LET (STRM (OST (UNIX-GETENV "OSTYPE"))) (SETQ STRM (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbcopy" "xclip -i -selection clipboard"))) (\EXTERNALFORMAT STRM CLIPBOARD-FORMAT) STRM]) (CLIPBOARD-PASTE-STREAM [LAMBDA NIL (* ; "Edited 23-Feb-2021 17:29 by rmk:") (LET (STRM (OST (UNIX-GETENV "OSTYPE"))) (SETQ STRM (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST) "pbpaste" "xclip -o -selection clipboard"))) (\EXTERNALFORMAT STRM CLIPBOARD-FORMAT) [SETFILEINFO STRM 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] STRM]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1309 6429 (INSTALL-CLIPBOARD 1319 . 3141) (GETCLIPBOARD 3143 . 3517) (PUTCLIPBOARD 3519 . 3924) (PASTEFROMCLIPBOARD 3926 . 4844) (LISPINTERRUPTS.PASTE 4846 . 5267) (CLIPBOARD-COPY-STREAM 5269 . 5769) (CLIPBOARD-PASTE-STREAM 5771 . 6427)) (6430 7189 (TEDIT.COPYTOCLIPBOARD 6440 . 6721) ( TEDIT.EXTRACTTOCLIPBOARD 6723 . 7187)) (7190 8729 (SEDIT.COPYTOCLIPBOARD 7200 . 8727))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD.LCOM b/library/CLIPBOARD.LCOM index f296faefa7108b89bb54eabc7c05ec251a498f93..c77009e574d091f8a7c06f013ba646889dce8219 100644 GIT binary patch delta 124 zcmeyM{!D#BB!`iam7%eff#t-+P)4JP+g+G5^AskFG3qn&PIhH9LP!_7vKc8@8dw-j zKE)_Ec^5a&WIiE@%{)xcIT=kR2l1LQ3ovL*Ud8Jw;O!!A%_3} delta 259 zcmaE+{y}|0B!{87m9e3fk-@~oP)5Uv+g&E#WfWso$jnpVo%m0GvL2%mLPepgl%ay9 zfrW`eaz7E{=)czQ%H%4k%1wf0SGujgrFef zBp$JPV*`a4*N70;AU{VRH~%1C#}EZ0BL(LmSH}=n-GCr}XV>6h-QW-)-&es>A=J+^ zLf73j#MLiMlh@DFhgUo*~iM$O+f>wEWkflK`AA%s5~=INx?rjL{mYjASpS& spi)UesUkTivp_*NQ$e>lH77N>Br`uxfg2>2l%H6XqNKTbHjg(u00!?zzW@LL From a5356980f064b200dfd697e592fb11a85ede6587 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Thu, 25 Feb 2021 15:38:27 -0800 Subject: [PATCH 28/31] FILEBROWSER: minor cleanup, meta-F seems to work --- library/FILEBROWSER | 2 +- library/FILEBROWSER.LCOM | Bin 84471 -> 84365 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/library/FILEBROWSER b/library/FILEBROWSER index 8ad956ae..045202a0 100644 --- a/library/FILEBROWSER +++ b/library/FILEBROWSER @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 12:41:59"  |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;25| 259384 |changes| |to:| (FNS FB.MAKECOUNTERWINDOW FB.NEWINFOCOMMAND FB.EXPUNGECOMMAND FB.MAYBE.EXPUNGE FB.MAKEHEADINGWINDOW FB.EDITCOMMAND.ONEFILE) (VARS FB.CLOSE.MENU.ITEMS FILEBROWSERCOMS) |previous| |date:| "21-Feb-2021 23:37:13" |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;21|) ; Copyright (c) 1983-1991, 1993-1994, 1999-2001, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (DECLARE\: EVAL@COMPILE DONTCOPY (P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)))) (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (P (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE)) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (INITVARS (FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser" ))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files" ) ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files" ))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing" ))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards" ) ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards" ) ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window" ) ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory" ))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files" ) ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files")) ) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files") ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files") (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files")) ) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion" ) (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern" ) ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser" ) ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed" ) ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible" ))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice" )))) (VARS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.DIRECTORYP FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITCOMMAND.ONEFILE FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (DECLARE\: EVAL@COMPILE DONTCOPY (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)) ) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQ? FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD ) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice") )) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files. Your deletions are thus ignored."))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB (NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \;  "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',PAT ',PROPS ',OPTIONS) 'NAME 'FB))) NIL)) (FB.COPYBINARYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE BINARY)))))) (FB.COPYTEXTCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE TEXT)))))) (FILEBROWSER (LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT 'HEIGHT)) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \;  "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \;  "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \;  "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \;  "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT 'HEIGHT)))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT 'HEIGHT) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC )) (SETQ REGION (GETREGION (PROGN (* \;  "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \;  "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT ))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \;  "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW 'FILEBROWSER (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \;  "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \;  "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \;  "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW 'RIGHT 'TOP)) (PROGN (* \;  "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \;  "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ '(("--Abort--" NIL "Abort the current FileBrowser operation" )) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT 'WEIGHT 'BOLD) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W 'PASSTOMAINCOMS))) |do| (* \;  "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W 'PASSTOMAINCOMS (UNION '(HARDCOPYIMAGEW) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST 'PRINTFN (FUNCTION FB.PRINTFN) 'COPYFN (FUNCTION FB.COPYFN) 'USERDATA BROWSER 'CLOSEFN (FUNCTION FB.CLOSEFN) 'AFTERCLOSEFN (FUNCTION FB.AFTERCLOSEFN) 'HEADINGWINDOW HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW 'HARDCOPYFN (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW 'ICONFN (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \;  "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS `(,(FUNCTION FB.STARTUP) ',BROWSER ',COMMANDMENU ',(FUNCTION FB.UPDATEBROWSERITEMS)) 'NAME '|FB-Update| 'BEFOREEXIT 'DON\'T)) (RETURN BROWSERWINDOW)))) (FB.TABLEBROWSER (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (FB.SELECTEDFILES (LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)) 'SELECTED)) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL)))) (FB.FETCHFILENAME (LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM 'TABLEITEM))))) (FB.DIRECTORYP (LAMBDA (FILE) (* \; "Edited 20-Feb-2021 20:05 by rmk:") (* |;;| "Does FILE denote a directory?") (CL:WHEN (TYPE? TABLEITEM FILE) (SETQ FILE (FETCH TIDATA OF FILE))) (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE))) (FB.PROMPTWPRINT (LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) 'FILEBROWSER))) THING) (* \;  "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW)))))))) (FB.PROMPTW.FORMAT (CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS)))) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P (LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;|  "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) 'Y) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) 'N) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL))))) (FB.ALLOW.ABORT (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER 'FILEBROWSER) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) 'BOTTOM) (* \;  "And repaint it in case it was used last time") (REDISPLAYW (CAR W)))))) (\\FB.HARDCOPY.TOFILE.EXTENSION (LAMBDA NIL (* \;  "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS 'IP) (POSTSCRIPT 'PS) (DEFAULT TYPE))))) ) (* \; "Setup") (DEFINEQ (FB.STARTUP (LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC '|Recompute| (|fetch| (MENU ITEMS) |of| COMMANDMENU) ) COMMANDMENU) (CL:FUNCALL FN BROWSER)))) (FB.MAKERIGIDWINDOW (LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW 'REGION)))) (WINDOWPROP WINDOW 'MINSIZE (CONS 0 HEIGHT)) (WINDOWPROP WINDOW 'MAXSIZE (CONS SCREENWIDTH HEIGHT)) WINDOW))) ) (DEFINEQ (FB.PRINTFN (LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW 'DSP)) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \;  "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \;  "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \;  "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \;  "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT 'DATE) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM))))) (FB.COPYFN (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM))))) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS `(,(FUNCTION FB.COMMANDSELECTEDFN) ',ITEM ',MENU ',KEY) 'NAME (PACK* 'FB- (CAR ITEM)) 'BEFOREEXIT 'DON\'T))) (FB.COMMANDSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW))))))) (FB.SUBITEMP (LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) 'SUBITEMS) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I))))))) (FB.MAKE.BROWSER.BUSY (LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE)) T)))) (FB.FINISH.COMMAND (LAMBDA (BROWSER ITEM MENU) (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \;  "Take down the abort button if there was one") (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W 'MENU))))) M FB.ITEMUNSELECTEDSHADE) (DETACHWINDOW W) (CLOSEW W))) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted."))))) (FB.HANDLE.ABORT.BUTTON (LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) 'FILEBROWSER)) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER )) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \;  "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC))))) ) (DEFINEQ (FB.DELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.DELVERCOMMAND (LAMBDA (FBROWSER) (* \;  "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM)) ))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER ) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER 'DELETED) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED)))))) (FB.IS.NOT.SUBDIRECTORY.ITEM (LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES (LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \;  "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED)))) (FB.DELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T))))) ) (DEFINEQ (FB.UNDELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETEALLCOMMAND (LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE))))))))) ) (DEFINEQ (FB.COPYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE))))) (FB.RENAMECOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Rename| (CONS (FUNCTION RENAMEFILE))))) (FB.COPY/RENAME.COMMAND (LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN)))))))))) (FB.COPY/RENAME.ONE (LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \;  "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD '|Rename|) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) 'BOTH) (T 'TOTAL)))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \;  "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE 'TOTAL)))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME))))))) (FB.COPY/RENAME.MANY (LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted") ) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST) (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'DEVICE)) (OR (LISTGET FIELDS 'NAME) (LISTGET FIELDS 'EXTENSION) (LISTGET FIELDS 'VERSION))) (* \;  "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST)) (SETQ DIR (OR (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'RELATIVEDIRECTORY))) (SETQ DEVICE (LISTGET FIELDS 'DEVICE)) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM))) ) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER 'Y) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay") ) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION) ))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING 'HOST HOST 'DEVICE DEVICE 'DIRECTORY (|if| (NOT RETAIN) |then| DIR |else| (* \;  "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) 'VERSION NIL 'BODY OLDNAME) CMD MOVEFN))))))) (FB.MERGE.DIRECTORIES (LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL))))) (FB.GREATEST.PREFIX (LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL)))))))) (FB.MAYBE.INSERT.FILE (LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \;  "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;|  "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER) ))) (* |;;|  "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;|  "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \;  "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM))) ) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME 'VERSION NIL 'TENEX))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION 'CREATIONDATE (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)) )) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME 'ICREATIONDATE)) (= CRDATE2 CRDATE))) |then| (* \;  "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \;  "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING 'BODY NEWNAME 'EXTENSION "" 'VERSION VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \;  "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \;  "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD '|Rename|)) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD '|Rename|) (|fetch| TISELECTED |of| OLDITEM)) (* \;  "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T))))) (FB.GET.NEW.FILE.SPEC (LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING 'DIRECTORY (OR (|fetch| (  FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) 'VERSION NIL 'BODY OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) 'NAME))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING 'DIRECTORY NEWNAME 'VERSION NIL 'BODY OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS 'EXTENSION))) (EQ (NCHARS NAMEFIELD) 0))) (* \;  "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these") ) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) 'HOST) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME)))))))) (FB.CANONICAL.DIRECTORY (LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER 'FILEBROWSER))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \;  "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL 'ASK)) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) 'Y) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW 'PROCESS NIL))))) ) (DEFINEQ (FB.HARDCOPYCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \;  "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST 'SERVER PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS))))))) (FB.HARDCOPY.TOFILE (LAMBDA (BROWSER FILES) (* \;  "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING 'NAME '* 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ))) (T (PACKFILENAME.STRING 'VERSION NIL 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ) 'BODY (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS '* (CADR TAIL))) (|if| (NEQ (CAR TAIL) 'NAME) |then| (RETURN (SETQ MSG "Only name portion can contain *") )) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files" ))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \;  "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS 'DIRECTORY NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE 'EXTENSION))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC 'EXTENSION (CDR TYPE)))) |do| (* \;  "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE 'CONVERSION)) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) 'TEXT)) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL 'TENEX)) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS 'NAME) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) 'VERSION NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE))))))) ) (DEFINEQ (FB.EDITCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 21-Feb-2021 15:56 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (IF (DIRECTORYNAMEP FILE) THEN (FB.BROWSECOMMAND BROWSER) ELSEIF (GETD 'OPENTEXTSTREAM) THEN (FB.EDITCOMMAND.ONEFILE BROWSER FILE OPTION) ELSE (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU))))) (FB.EDITCOMMAND.ONEFILE (LAMBDA (BROWSER FILE OPTION) (* \; "Edited 21-Feb-2021 23:37 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (* |;;| "Called when we know that FILE is a file, not a directory, and that TEDIT exists. If OPTION is READONLY, we don't want to edit, just view. If FILE is a lisp sourcefile, we execute the font changes by COPY.TEXT.TO.IMAGE") (CL:UNLESS OPTION (SETQ OPTION FB.DEFAULT.EDITOR)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (IF (LISPSOURCEFILEP FILE) THEN (SELECTQ OPTION ((LISP NIL TEDIT) (* |;;| "Asks to load prop and edits the coms. We really don't want to use a text editor on a source file.") (* |;;| "The FUNCALL at the bottom is concerning.") (FB.EDITLISPFILE FILE BROWSER)) (READONLY (* \; "READONLY on call from SEE") (RESETLST (LET ((WINDOW (CREATEW NIL FILE)) (STR (OPENSTREAM FILE 'INPUT))) (RESETSAVE NIL (LIST 'CLOSEF STR)) (SETQ STR (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STR NSTR) NSTR)) (GETPROMPTWINDOW WINDOW (OR TEDIT.PROMPTWINDOW.HEIGHT 1)) (OPENTEXTSTREAM STR WINDOW NIL NIL '(READONLY T))))) (CL:FUNCALL OPTION (MKATOM FILE))) ELSE (SELECTQ OPTION (READONLY (* |;;| "From SEE command. We want to be able to scroll around in the content, can't do that if it isn't random access. So in that case we do a secret NODIRCORE copy and look at that.") (RESETLST (LET ((WINDOW (CREATEW NIL FILE)) (STR (OPENSTREAM FILE 'INPUT))) (CL:UNLESS (RANDACCESSP STR) (RESETSAVE NIL (LIST 'CLOSEF STR)) (SETQ STR (LET ((NSTR (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW NIL (LIST (LIST 'TYPE (GETFILEINFO STR 'TYPE)))))) (COPYBYTES STR NSTR) NSTR))) (GETPROMPTWINDOW WINDOW (OR TEDIT.PROMPTWINDOW.HEIGHT 1)) (OPENTEXTSTREAM STR WINDOW NIL NIL '(READONLY T))))) ((TEDIT NIL) (TEDIT (MKATOM FILE))) (LISP (FB.PROMPTW.FORMAT BROWSER "Failed because not a Lisp source file")) (CL:FUNCALL OPTION (MKATOM FILE))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) (FB.EDITLISPFILE (LAMBDA (FILE BROWSER) (* \; "Edited 21-Feb-2021 17:29 by rmk:") (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) 'FILEDATES)) FILE)) (NOT (GET ROOT 'FILE)) (NOT (BOUNDP (FILECOMS ROOT)))) (FB.PROMPTW.FORMAT BROWSER "The file ~A is not loaded or is not current." FILE) (COND ((MOUSECONFIRM (CONCAT "(LOAD '" FILE " 'PROP)? ") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL `(LOAD ',FILE 'PROP))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT '(FILES :DONTWAIT)))))) (FB.BROWSECOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 20-Feb-2021 20:10 by rmk:") (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ NAME (FB.FETCHFILENAME FILE)) (|if| (OR (FB.DIRECTORYP FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL 'TENEX)) (NAMETAIL (MEMB 'NAME FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) 'VERSION) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \;  "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \;  "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS 'DIRECTORY)) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS 'DIRECTORY (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS 'HOST) 'OSTYPE) 'UNIX) |then| (* \;  "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',NAME ',(MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)) ,@(AND DEPTH `('(:DEPTH ,DEPTH))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME))))) ) (DEFINEQ (FB.FASTSEECOMMAND (LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'NAME) (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'EXTENSION)))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW 'PAGEFULLFN (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'INUSE NIL) (DEL.PROCESS (WINDOWPROP W 'PROCESS)))))) ) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW 'PROCESS NIL) (* \;  "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW 'MORETYPE)))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \;  "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \;  "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL))))))) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \; "Edited 21-Feb-2021 14:46 by rmk:") (* \; "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((DIRECTORYNAMEP FILE) (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER)) (T (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS)))))))))) (FB.SEEFULLFN (LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW 'MORETYPE))))) (EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS '(("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one" ) ("Abort" ABORT "Abort viewing of this and any further files" ))) (FINISHEDMOREBUTTONS '((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files" ))) '((" More " MORE "View another screenfull of the file" ) (" Abort " ABORT "Abort view; allow this window to be re-used" ))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH ) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW 'MOREEVENT (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW 'TITLE)))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS 'REGION)) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW 'REGION))) 'TOP) (T 'BOTTOM)) 'LEFT) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW 'MOREOK NIL))))) (FB.SEEBUTTONFN (LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \;  "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW 'MOREOK T) (NOTIFY.EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (NEXT (* \;  "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW 'PROCESS) '(CL:THROW :NEXT))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW 'PROCESS))) (SHOULDNT))))) ) (DEFINEQ (FB.LOADCOMMAND (LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) 'NAME 'LOAD 'BEFOREEXIT 'DON\'T))))) (FB.COMPILECOMMAND (LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) 'NAME 'COMPILE 'BEFOREEXIT 'DON\'T))))) (FB.OPERATE.ON.FILES (LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN 'LOAD)) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| `(,FN ',(FB.FETCHFILENAME FILEENTRY) ,@(AND LDFLG `(',LDFLG))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS 'PROGN FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM))))) ) (DEFINEQ (FB.UPDATECOMMAND (LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER '|Recompute|) (FB.UPDATEBROWSERITEMS BROWSER))))) (FB.MAYBE.EXPUNGE (LAMBDA (BROWSER COMMAND) (* \; "Edited 22-Feb-2021 12:33 by rmk:") (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL))))) (FB.UPDATEBROWSERITEMS (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \;  "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \;  "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \;  "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION 'SIZE INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION 'LENGTH INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) ) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \;  "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN 'DIRECTORY)))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS 'SUBTREE.SIZE)) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS '(SORT RESETLST))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \;  "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \;  "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME ) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER 'CLEAR "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER '|done|) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.DATE (LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;|  "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9))))) (FB.ADJUST.DATE.WIDTH (LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) 'DATE) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM))) ) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \;  "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT)))) (FB.SET.BROWSER.TITLE (LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) 'TITLE (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser"))))))) (FB.MAYBE.WIDEN.NAMES (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \;  "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES ) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \;  "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T))))))) (FB.SET.DEFAULT.NAME.WIDTH (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL)))) (FB.CREATE.FILEBUCKET (LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \;  "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR ))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \;  "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \;  "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \;  "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER )) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \;  "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA))) (FB.CHECK.NAME.LENGTH (LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \;  "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN)))))))))) (FB.ADD.FILEGROUP (LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA))))(* \;  "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \;  "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA)))))) (FB.INSERT.DIRECTORY (LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM))) (FB.MAKE.SUBDIRECTORY.ITEM (LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER) )))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T))))) (FB.ADD.FILE (LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM)))) (FB.INSERT.FILE (LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already") ) (T (* |;;|  "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \;  "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \;  "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE 'ADD)))) (FB.ANALYZE.PATTERN (LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \;  "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \;  "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \;  "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))) )) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \;  "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN))) (FB.GETALLFILEINFO (LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) '(SIZE LENGTH)) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR 'SUBTREE.SIZE))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE)))) ) (DEFINEQ (FB.SORT.VERSIONS (LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \;  "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME ) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \;  "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS))) (FB.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y))))) (FB.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y))))) (FB.NAMES.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL))) (FB.NAMES.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL))) (FB.DECREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.INCREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.ALPHABETIC.ATTR (LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL))) ) (DEFINEQ (FB.SORTCOMMAND (LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \;  "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \;  "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \;  "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME ) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA))) ) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \;  "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done")))) (FB.INSERT.SUBDIRECTORIES (LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \;  "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL))))) (FB.GET.SORT.MENU (LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS '("Name" 'NAME "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" 'NAME "Sort files by name, decreasing version numbers") ("Increasing version" '(NAME T) "Sort files by name, increasing version numbers"))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER ) |collect| `(,(SETQ ATTR (CAR ATTR)) ',ATTR "Sort by this attribute" ,(SELECTQ ATTR ((SIZE LENGTH BYTESIZE) `(SUBITEMS ("Decreasing" ',ATTR "Sort files in order of decreasing size" ) ("Increasing" '(,ATTR T) "Sort files in order of increasing size"))) ((CREATIONDATE WRITEDATE READDATE) `(SUBITEMS ("Newer first" ',ATTR "Sort files with newer dates appearing before older dates" ) ("Older first" '(,ATTR T) "Sort files with older dates appearing before newer dates" ))) NIL))))))))) ) (DEFINEQ (FB.EXPUNGECOMMAND (LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 22-Feb-2021 12:36 by rmk:") (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER 'DELETED)) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER 'BOTH)) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;|  "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " No") (T (CONCAT (COND (FAILED " Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T)))) (FB.NEWPATTERNCOMMAND (LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER)))))) (FB.NEWINFOCOMMAND (LAMBDA (BROWSER) (* \; "Edited 22-Feb-2021 12:35 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW 'BOTTOM 'JUSTIFY 'LOCALCLOSE) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW 'REGION))) 0) (* \;  "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW 'CLOSEFN (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) 'FILEBROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER 'CLEAR "Select from the lower menu which attributes are to be displayed, then click Recompute")))) (FB.DEPTHCOMMAND (LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL ) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH))))) (FB.SHAPECOMMAND (LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW 'EXTENT)) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW 'WIDTH))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW 'HEIGHT) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER )))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW 'REGION)) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) 'REGION))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \;  "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT)))))) (FB.REMOVE.FILE (LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM 'REMOVE)))) (FB.COUNT.FILE.CHANGE (LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE)))))))) (FB.SETNEWPATTERN (LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| ( DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN 'HOST))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) 'ICONWINDOW)) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN))) (FB.GET.NEWPATTERN (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN)))))) (FB.OPTIONSCOMMAND (LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire."))) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS (LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW 'MENU))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW))))) (FB.INFO.ITEM.NAMED (LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM)))) ) (DEFINEQ (FB.MAKECOUNTERWINDOW (LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 22-Feb-2021 12:41 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW 'TOP) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW 'FILEBROWSER) |with| COUNTERW) (WINDOWPROP COUNTERW 'REPAINTFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'RESHAPEFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'PAGEFULLFN (FUNCTION NILL)) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP COUNTERW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) COUNTERW))) (FB.COUNTERW.REDISPLAYFN (LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) 'FILEBROWSER))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \;  "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.UPDATE.COUNTERS (LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE 'DELETED) (* \;  "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE 'TOTAL) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT 'REPLACE))))) (FB.DISPLAY.COUNTERS (LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW 'WIDTH)) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)) )) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \;  "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT 'REPLACE) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING) ))) (FB.COUNTER.STRING (LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES))))) ) (DEFINEQ (FB.MAKEHEADINGWINDOW (LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Feb-2021 12:29 by rmk:") (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW 'TOP) (WINDOWPROP HEADINGW 'PASSTOMAINCOMS T) (* \;  "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW 'REPAINTFN (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW 'RESHAPEFN (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \;  "This is a white on black window") (DSPOPERATION 'INVERT HEADINGW) (DSPFILL NIL BLACKSHADE 'REPLACE HEADINGW) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP HEADINGW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HEADINGW))) (FB.HEADINGW.REDISPLAYFN (LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER) WINDOW))) (FB.HEADINGW.RESHAPEFN (LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW)))) (FB.HEADINGW.DISPLAY (LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW 'DSP)) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) 'BORDER)) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE 'REPLACE STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \;  "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \;  "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC)))))) ) (DEFINEQ (FB.ICONFN (LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW 'FILEBROWSER)) FB.ICONFONT POSITION NIL NIL 'FILE)))) (FB.INFOMENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (BROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN)))) (FB.CLOSEFN (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) 'DON\'T) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER 'DELETED) 0) (* \;  "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) 'DON\'T)))))) (FB.EXPUNGE?.MENU (LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT))))) (FB.AFTERCLOSEFN (LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL)))) (FB.CLOSE&EXPUNGE (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W 'MENU))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC '|Expunge| (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG))))))) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY (LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (TBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER)) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \;  "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \;  "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \;  "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER ))) (STREAMPROP IMAGESTREAM 'PRINTOPTIONS (LIST* 'DOCUMENT.NAME TITLE (STREAMPROP IMAGESTREAM 'PRINTOPTIONS))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW ) |of| FBROWSER) 'TITLE)) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES ) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) 'DATE) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \;  "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \;  "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \;  "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM) ) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \;  "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \;  "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \;  "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM))))) (FB.HARDCOPY.PRINT.TITLE (LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T))) (FB.HARDCOPY.MAXWIDTH (LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;|  "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \;  "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001 2021)) (DECLARE\: DONTCOPY (FILEMAP (NIL (28292 50928 (FB 28302 . 29258) (FB.COPYBINARYCOMMAND 29260 . 29606) (FB.COPYTEXTCOMMAND 29608 . 29950) (FILEBROWSER 29952 . 43058) (FB.TABLEBROWSER 43060 . 43277) (FB.SELECTEDFILES 43279 . 43916) (FB.FETCHFILENAME 43918 . 44310) (FB.DIRECTORYP 44312 . 44640) (FB.PROMPTWPRINT 44642 . 45688) (FB.PROMPTW.FORMAT 45690 . 46427) (FB.PROMPTFORINPUT 46429 . 48681) (FB.YES-OR-NO-P 48683 . 49717) ( FB.ALLOW.ABORT 49719 . 50573) (\\FB.HARDCOPY.TOFILE.EXTENSION 50575 . 50926)) (50952 51905 (FB.STARTUP 50962 . 51477) (FB.MAKERIGIDWINDOW 51479 . 51903)) (51906 57278 (FB.PRINTFN 51916 . 57069) (FB.COPYFN 57071 . 57276)) (57328 62653 (FB.MENU.WHENSELECTEDFN 57338 . 57696) (FB.COMMANDSELECTEDFN 57698 . 59237) (FB.SUBITEMP 59239 . 59674) (FB.MAKE.BROWSER.BUSY 59676 . 60228) (FB.FINISH.COMMAND 60230 . 61664) (FB.HANDLE.ABORT.BUTTON 61666 . 62651)) (62654 68170 (FB.DELETECOMMAND 62664 . 62945) ( FB.DELVERCOMMAND 62947 . 66140) (FB.IS.NOT.SUBDIRECTORY.ITEM 66142 . 66323) (FB.DELVER.FILES 66325 . 67414) (FB.DELETE.FILE 67416 . 68168)) (68171 69496 (FB.UNDELETECOMMAND 68181 . 68466) ( FB.UNDELETEALLCOMMAND 68468 . 68747) (FB.UNDELETE.FILE 68749 . 69494)) (69497 93678 (FB.COPYCOMMAND 69507 . 69776) (FB.RENAMECOMMAND 69778 . 70053) (FB.COPY/RENAME.COMMAND 70055 . 70978) ( FB.COPY/RENAME.ONE 70980 . 73302) (FB.COPY/RENAME.MANY 73304 . 79524) (FB.MERGE.DIRECTORIES 79526 . 79944) (FB.GREATEST.PREFIX 79946 . 81302) (FB.MAYBE.INSERT.FILE 81304 . 88744) (FB.GET.NEW.FILE.SPEC 88746 . 92577) (FB.CANONICAL.DIRECTORY 92579 . 93676)) (93679 101463 (FB.HARDCOPYCOMMAND 93689 . 94819 ) (FB.HARDCOPY.TOFILE 94821 . 101461)) (101464 111702 (FB.EDITCOMMAND 101474 . 102265) ( FB.EDITCOMMAND.ONEFILE 102267 . 105918) (FB.EDITLISPFILE 105920 . 106959) (FB.BROWSECOMMAND 106961 . 111700)) (111703 123496 (FB.FASTSEECOMMAND 111713 . 115163) (FB.FASTSEE.ONEFILE 115165 . 118194) ( FB.SEEFULLFN 118196 . 122327) (FB.SEEBUTTONFN 122329 . 123494)) (123497 125243 (FB.LOADCOMMAND 123507 . 124014) (FB.COMPILECOMMAND 124016 . 124554) (FB.OPERATE.ON.FILES 124556 . 125241)) (125244 172293 ( FB.UPDATECOMMAND 125254 . 125479) (FB.MAYBE.EXPUNGE 125481 . 126476) (FB.UPDATEBROWSERITEMS 126478 . 139693) (FB.DATE 139695 . 140436) (FB.ADJUST.DATE.WIDTH 140438 . 143406) (FB.SET.BROWSER.TITLE 143408 . 144265) (FB.MAYBE.WIDEN.NAMES 144267 . 146386) (FB.SET.DEFAULT.NAME.WIDTH 146388 . 147752) ( FB.CREATE.FILEBUCKET 147754 . 154974) (FB.CHECK.NAME.LENGTH 154976 . 157397) (FB.ADD.FILEGROUP 157399 . 158926) (FB.INSERT.DIRECTORY 158928 . 159166) (FB.MAKE.SUBDIRECTORY.ITEM 159168 . 160577) ( FB.ADD.FILE 160579 . 161192) (FB.INSERT.FILE 161194 . 164606) (FB.ANALYZE.PATTERN 164608 . 169872) ( FB.CANONICALIZE.PATTERN 169874 . 171186) (FB.GETALLFILEINFO 171188 . 172291)) (172294 180453 ( FB.SORT.VERSIONS 172304 . 175075) (FB.DECREASING.VERSION 175077 . 175746) (FB.INCREASING.VERSION 175748 . 176369) (FB.NAMES.DECREASING.VERSION 176371 . 177406) (FB.NAMES.INCREASING.VERSION 177408 . 178405) (FB.DECREASING.NUMERIC.ATTR 178407 . 179087) (FB.INCREASING.NUMERIC.ATTR 179089 . 179763) ( FB.ALPHABETIC.ATTR 179765 . 180451)) (180454 190296 (FB.SORTCOMMAND 180464 . 187294) ( FB.INSERT.SUBDIRECTORIES 187296 . 188093) (FB.GET.SORT.MENU 188095 . 190294)) (190297 206386 ( FB.EXPUNGECOMMAND 190307 . 192826) (FB.NEWPATTERNCOMMAND 192828 . 193226) (FB.NEWINFOCOMMAND 193228 . 195994) (FB.DEPTHCOMMAND 195996 . 197771) (FB.SHAPECOMMAND 197773 . 201115) (FB.REMOVE.FILE 201117 . 202938) (FB.COUNT.FILE.CHANGE 202940 . 204385) (FB.SETNEWPATTERN 204387 . 205557) (FB.GET.NEWPATTERN 205559 . 206143) (FB.OPTIONSCOMMAND 206145 . 206384)) (206421 207433 ( FB.INFOMENU.SHADEINITIALSELECTIONS 206431 . 207078) (FB.INFO.ITEM.NAMED 207080 . 207431)) (207434 216900 (FB.MAKECOUNTERWINDOW 207444 . 208906) (FB.COUNTERW.REDISPLAYFN 208908 . 209495) ( FB.UPDATE.COUNTERS 209497 . 211569) (FB.DISPLAY.COUNTERS 211571 . 216631) (FB.COUNTER.STRING 216633 . 216898)) (216901 221544 (FB.MAKEHEADINGWINDOW 216911 . 218459) (FB.HEADINGW.REDISPLAYFN 218461 . 218727) (FB.HEADINGW.RESHAPEFN 218729 . 219105) (FB.HEADINGW.DISPLAY 219107 . 221542)) (221545 225728 (FB.ICONFN 221555 . 221902) (FB.INFOMENU.WHENSELECTEDFN 221904 . 222634) (FB.CLOSEFN 222636 . 223839) (FB.EXPUNGE?.MENU 223841 . 224253) (FB.AFTERCLOSEFN 224255 . 224616) (FB.CLOSE&EXPUNGE 224618 . 225726 )) (225729 237787 (FB.HARDCOPY.DIRECTORY 225739 . 236096) (FB.HARDCOPY.PRINT.TITLE 236098 . 236424) ( FB.HARDCOPY.MAXWIDTH 236426 . 237785))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "25-Feb-2021 13:24:50"  |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;27| 258499 |changes| |to:| (FNS FB.EDITCOMMAND.ONEFILE) |previous| |date:| "22-Feb-2021 12:41:59" |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;25|) ; Copyright (c) 1983-1991, 1993-1994, 1999-2001, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (DECLARE\: EVAL@COMPILE DONTCOPY (P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)))) (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (P (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE)) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (INITVARS (FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser" ))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files" ) ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files" ))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing" ))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards" ) ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards" ) ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window" ) ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory" ))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files" ) ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files")) ) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files") ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files") (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files")) ) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion" ) (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern" ) ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser" ) ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed" ) ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible" ))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice" )))) (VARS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.DIRECTORYP FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITCOMMAND.ONEFILE FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (DECLARE\: EVAL@COMPILE DONTCOPY (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)) ) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQ? FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD ) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice") )) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files. Your deletions are thus ignored."))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB (NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \;  "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',PAT ',PROPS ',OPTIONS) 'NAME 'FB))) NIL)) (FB.COPYBINARYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE BINARY)))))) (FB.COPYTEXTCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE TEXT)))))) (FILEBROWSER (LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT 'HEIGHT)) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \;  "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \;  "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \;  "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \;  "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT 'HEIGHT)))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT 'HEIGHT) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC )) (SETQ REGION (GETREGION (PROGN (* \;  "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \;  "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT ))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \;  "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW 'FILEBROWSER (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \;  "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \;  "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \;  "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW 'RIGHT 'TOP)) (PROGN (* \;  "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \;  "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ '(("--Abort--" NIL "Abort the current FileBrowser operation" )) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT 'WEIGHT 'BOLD) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W 'PASSTOMAINCOMS))) |do| (* \;  "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W 'PASSTOMAINCOMS (UNION '(HARDCOPYIMAGEW) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST 'PRINTFN (FUNCTION FB.PRINTFN) 'COPYFN (FUNCTION FB.COPYFN) 'USERDATA BROWSER 'CLOSEFN (FUNCTION FB.CLOSEFN) 'AFTERCLOSEFN (FUNCTION FB.AFTERCLOSEFN) 'HEADINGWINDOW HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW 'HARDCOPYFN (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW 'ICONFN (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \;  "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS `(,(FUNCTION FB.STARTUP) ',BROWSER ',COMMANDMENU ',(FUNCTION FB.UPDATEBROWSERITEMS)) 'NAME '|FB-Update| 'BEFOREEXIT 'DON\'T)) (RETURN BROWSERWINDOW)))) (FB.TABLEBROWSER (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (FB.SELECTEDFILES (LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)) 'SELECTED)) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL)))) (FB.FETCHFILENAME (LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM 'TABLEITEM))))) (FB.DIRECTORYP (LAMBDA (FILE) (* \; "Edited 20-Feb-2021 20:05 by rmk:") (* |;;| "Does FILE denote a directory?") (CL:WHEN (TYPE? TABLEITEM FILE) (SETQ FILE (FETCH TIDATA OF FILE))) (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE))) (FB.PROMPTWPRINT (LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) 'FILEBROWSER))) THING) (* \;  "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW)))))))) (FB.PROMPTW.FORMAT (CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS)))) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P (LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;|  "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) 'Y) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) 'N) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL))))) (FB.ALLOW.ABORT (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER 'FILEBROWSER) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) 'BOTTOM) (* \;  "And repaint it in case it was used last time") (REDISPLAYW (CAR W)))))) (\\FB.HARDCOPY.TOFILE.EXTENSION (LAMBDA NIL (* \;  "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS 'IP) (POSTSCRIPT 'PS) (DEFAULT TYPE))))) ) (* \; "Setup") (DEFINEQ (FB.STARTUP (LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC '|Recompute| (|fetch| (MENU ITEMS) |of| COMMANDMENU) ) COMMANDMENU) (CL:FUNCALL FN BROWSER)))) (FB.MAKERIGIDWINDOW (LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW 'REGION)))) (WINDOWPROP WINDOW 'MINSIZE (CONS 0 HEIGHT)) (WINDOWPROP WINDOW 'MAXSIZE (CONS SCREENWIDTH HEIGHT)) WINDOW))) ) (DEFINEQ (FB.PRINTFN (LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW 'DSP)) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \;  "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \;  "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \;  "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \;  "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT 'DATE) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM))))) (FB.COPYFN (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM))))) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS `(,(FUNCTION FB.COMMANDSELECTEDFN) ',ITEM ',MENU ',KEY) 'NAME (PACK* 'FB- (CAR ITEM)) 'BEFOREEXIT 'DON\'T))) (FB.COMMANDSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW))))))) (FB.SUBITEMP (LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) 'SUBITEMS) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I))))))) (FB.MAKE.BROWSER.BUSY (LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE)) T)))) (FB.FINISH.COMMAND (LAMBDA (BROWSER ITEM MENU) (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \;  "Take down the abort button if there was one") (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W 'MENU))))) M FB.ITEMUNSELECTEDSHADE) (DETACHWINDOW W) (CLOSEW W))) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted."))))) (FB.HANDLE.ABORT.BUTTON (LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) 'FILEBROWSER)) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER )) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \;  "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC))))) ) (DEFINEQ (FB.DELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.DELVERCOMMAND (LAMBDA (FBROWSER) (* \;  "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM)) ))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER ) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER 'DELETED) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED)))))) (FB.IS.NOT.SUBDIRECTORY.ITEM (LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES (LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \;  "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED)))) (FB.DELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T))))) ) (DEFINEQ (FB.UNDELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETEALLCOMMAND (LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE))))))))) ) (DEFINEQ (FB.COPYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE))))) (FB.RENAMECOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Rename| (CONS (FUNCTION RENAMEFILE))))) (FB.COPY/RENAME.COMMAND (LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN)))))))))) (FB.COPY/RENAME.ONE (LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \;  "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD '|Rename|) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) 'BOTH) (T 'TOTAL)))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \;  "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE 'TOTAL)))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME))))))) (FB.COPY/RENAME.MANY (LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted") ) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST) (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'DEVICE)) (OR (LISTGET FIELDS 'NAME) (LISTGET FIELDS 'EXTENSION) (LISTGET FIELDS 'VERSION))) (* \;  "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST)) (SETQ DIR (OR (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'RELATIVEDIRECTORY))) (SETQ DEVICE (LISTGET FIELDS 'DEVICE)) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM))) ) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER 'Y) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay") ) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION) ))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING 'HOST HOST 'DEVICE DEVICE 'DIRECTORY (|if| (NOT RETAIN) |then| DIR |else| (* \;  "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) 'VERSION NIL 'BODY OLDNAME) CMD MOVEFN))))))) (FB.MERGE.DIRECTORIES (LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL))))) (FB.GREATEST.PREFIX (LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL)))))))) (FB.MAYBE.INSERT.FILE (LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \;  "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;|  "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER) ))) (* |;;|  "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;|  "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \;  "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM))) ) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME 'VERSION NIL 'TENEX))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION 'CREATIONDATE (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)) )) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME 'ICREATIONDATE)) (= CRDATE2 CRDATE))) |then| (* \;  "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \;  "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING 'BODY NEWNAME 'EXTENSION "" 'VERSION VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \;  "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \;  "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD '|Rename|)) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD '|Rename|) (|fetch| TISELECTED |of| OLDITEM)) (* \;  "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T))))) (FB.GET.NEW.FILE.SPEC (LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING 'DIRECTORY (OR (|fetch| (  FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) 'VERSION NIL 'BODY OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) 'NAME))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING 'DIRECTORY NEWNAME 'VERSION NIL 'BODY OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS 'EXTENSION))) (EQ (NCHARS NAMEFIELD) 0))) (* \;  "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these") ) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) 'HOST) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME)))))))) (FB.CANONICAL.DIRECTORY (LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER 'FILEBROWSER))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \;  "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL 'ASK)) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) 'Y) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW 'PROCESS NIL))))) ) (DEFINEQ (FB.HARDCOPYCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \;  "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST 'SERVER PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS))))))) (FB.HARDCOPY.TOFILE (LAMBDA (BROWSER FILES) (* \;  "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING 'NAME '* 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ))) (T (PACKFILENAME.STRING 'VERSION NIL 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ) 'BODY (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS '* (CADR TAIL))) (|if| (NEQ (CAR TAIL) 'NAME) |then| (RETURN (SETQ MSG "Only name portion can contain *") )) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files" ))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \;  "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS 'DIRECTORY NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE 'EXTENSION))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC 'EXTENSION (CDR TYPE)))) |do| (* \;  "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE 'CONVERSION)) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) 'TEXT)) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL 'TENEX)) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS 'NAME) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) 'VERSION NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE))))))) ) (DEFINEQ (FB.EDITCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 21-Feb-2021 15:56 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (IF (DIRECTORYNAMEP FILE) THEN (FB.BROWSECOMMAND BROWSER) ELSEIF (GETD 'OPENTEXTSTREAM) THEN (FB.EDITCOMMAND.ONEFILE BROWSER FILE OPTION) ELSE (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU))))) (FB.EDITCOMMAND.ONEFILE (LAMBDA (BROWSER FILE OPTION) (* \; "Edited 25-Feb-2021 12:31 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (* |;;| "Called when we know that FILE is a file, not a directory, and that TEDIT exists. If OPTION is READONLY, we don't want to edit, just view. If FILE is a lisp sourcefile, we execute the font changes by COPY.TEXT.TO.IMAGE") (CL:UNLESS OPTION (SETQ OPTION FB.DEFAULT.EDITOR)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (IF (LISPSOURCEFILEP FILE) THEN (SELECTQ OPTION ((LISP NIL TEDIT) (* |;;| "Asks to load prop and edits the coms. We really don't want to use a text editor on a source file.") (* |;;| "The FUNCALL at the bottom is concerning.") (FB.EDITLISPFILE FILE BROWSER)) (READONLY (* \; "READONLY on call from SEE") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STREAM NSTR) (TEDIT NSTR NIL NIL '(READONLY T))))) (CL:FUNCALL OPTION (MKATOM FILE))) ELSE (SELECTQ OPTION (READONLY (* |;;| "From SEE command. We want to be able to scroll around in the content, can't do that if it isn't random access. So in that case we do a secret NODIRCORE copy and look at that.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((NSTR)) (CL:UNLESS (RANDACCESSP STREAM) (SETQ NSTR (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW NIL (LIST (LIST 'TYPE (GETFILEINFO STREAM 'TYPE))))) (COPYBYTES STREAM NSTR)) (TEDIT (OR NSTR STREAM) NIL NIL '(READONLY T))))) ((TEDIT NIL) (TEDIT (MKATOM FILE))) (LISP (FB.PROMPTW.FORMAT BROWSER "Failed because not a Lisp source file")) (CL:FUNCALL OPTION (MKATOM FILE))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) (FB.EDITLISPFILE (LAMBDA (FILE BROWSER) (* \; "Edited 21-Feb-2021 17:29 by rmk:") (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) 'FILEDATES)) FILE)) (NOT (GET ROOT 'FILE)) (NOT (BOUNDP (FILECOMS ROOT)))) (FB.PROMPTW.FORMAT BROWSER "The file ~A is not loaded or is not current." FILE) (COND ((MOUSECONFIRM (CONCAT "(LOAD '" FILE " 'PROP)? ") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL `(LOAD ',FILE 'PROP))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT '(FILES :DONTWAIT)))))) (FB.BROWSECOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 20-Feb-2021 20:10 by rmk:") (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ NAME (FB.FETCHFILENAME FILE)) (|if| (OR (FB.DIRECTORYP FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL 'TENEX)) (NAMETAIL (MEMB 'NAME FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) 'VERSION) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \;  "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \;  "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS 'DIRECTORY)) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS 'DIRECTORY (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS 'HOST) 'OSTYPE) 'UNIX) |then| (* \;  "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',NAME ',(MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)) ,@(AND DEPTH `('(:DEPTH ,DEPTH))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME))))) ) (DEFINEQ (FB.FASTSEECOMMAND (LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'NAME) (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'EXTENSION)))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW 'PAGEFULLFN (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'INUSE NIL) (DEL.PROCESS (WINDOWPROP W 'PROCESS)))))) ) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW 'PROCESS NIL) (* \;  "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW 'MORETYPE)))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \;  "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \;  "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL))))))) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \; "Edited 21-Feb-2021 14:46 by rmk:") (* \; "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((DIRECTORYNAMEP FILE) (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER)) (T (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS)))))))))) (FB.SEEFULLFN (LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW 'MORETYPE))))) (EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS '(("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one" ) ("Abort" ABORT "Abort viewing of this and any further files" ))) (FINISHEDMOREBUTTONS '((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files" ))) '((" More " MORE "View another screenfull of the file" ) (" Abort " ABORT "Abort view; allow this window to be re-used" ))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH ) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW 'MOREEVENT (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW 'TITLE)))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS 'REGION)) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW 'REGION))) 'TOP) (T 'BOTTOM)) 'LEFT) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW 'MOREOK NIL))))) (FB.SEEBUTTONFN (LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \;  "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW 'MOREOK T) (NOTIFY.EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (NEXT (* \;  "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW 'PROCESS) '(CL:THROW :NEXT))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW 'PROCESS))) (SHOULDNT))))) ) (DEFINEQ (FB.LOADCOMMAND (LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) 'NAME 'LOAD 'BEFOREEXIT 'DON\'T))))) (FB.COMPILECOMMAND (LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) 'NAME 'COMPILE 'BEFOREEXIT 'DON\'T))))) (FB.OPERATE.ON.FILES (LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN 'LOAD)) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| `(,FN ',(FB.FETCHFILENAME FILEENTRY) ,@(AND LDFLG `(',LDFLG))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS 'PROGN FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM))))) ) (DEFINEQ (FB.UPDATECOMMAND (LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER '|Recompute|) (FB.UPDATEBROWSERITEMS BROWSER))))) (FB.MAYBE.EXPUNGE (LAMBDA (BROWSER COMMAND) (* \; "Edited 22-Feb-2021 12:33 by rmk:") (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL))))) (FB.UPDATEBROWSERITEMS (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \;  "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \;  "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \;  "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION 'SIZE INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION 'LENGTH INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) ) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \;  "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN 'DIRECTORY)))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS 'SUBTREE.SIZE)) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS '(SORT RESETLST))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \;  "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \;  "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME ) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER 'CLEAR "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER '|done|) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.DATE (LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;|  "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9))))) (FB.ADJUST.DATE.WIDTH (LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) 'DATE) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM))) ) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \;  "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT)))) (FB.SET.BROWSER.TITLE (LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) 'TITLE (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser"))))))) (FB.MAYBE.WIDEN.NAMES (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \;  "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES ) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \;  "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T))))))) (FB.SET.DEFAULT.NAME.WIDTH (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL)))) (FB.CREATE.FILEBUCKET (LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \;  "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR ))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \;  "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \;  "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \;  "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER )) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \;  "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA))) (FB.CHECK.NAME.LENGTH (LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \;  "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN)))))))))) (FB.ADD.FILEGROUP (LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA))))(* \;  "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \;  "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA)))))) (FB.INSERT.DIRECTORY (LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM))) (FB.MAKE.SUBDIRECTORY.ITEM (LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER) )))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T))))) (FB.ADD.FILE (LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM)))) (FB.INSERT.FILE (LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already") ) (T (* |;;|  "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \;  "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \;  "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE 'ADD)))) (FB.ANALYZE.PATTERN (LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \;  "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \;  "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \;  "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))) )) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \;  "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN))) (FB.GETALLFILEINFO (LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) '(SIZE LENGTH)) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR 'SUBTREE.SIZE))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE)))) ) (DEFINEQ (FB.SORT.VERSIONS (LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \;  "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME ) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \;  "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS))) (FB.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y))))) (FB.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y))))) (FB.NAMES.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL))) (FB.NAMES.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL))) (FB.DECREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.INCREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.ALPHABETIC.ATTR (LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL))) ) (DEFINEQ (FB.SORTCOMMAND (LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \;  "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \;  "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \;  "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME ) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA))) ) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \;  "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done")))) (FB.INSERT.SUBDIRECTORIES (LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \;  "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL))))) (FB.GET.SORT.MENU (LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS '("Name" 'NAME "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" 'NAME "Sort files by name, decreasing version numbers") ("Increasing version" '(NAME T) "Sort files by name, increasing version numbers"))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER ) |collect| `(,(SETQ ATTR (CAR ATTR)) ',ATTR "Sort by this attribute" ,(SELECTQ ATTR ((SIZE LENGTH BYTESIZE) `(SUBITEMS ("Decreasing" ',ATTR "Sort files in order of decreasing size" ) ("Increasing" '(,ATTR T) "Sort files in order of increasing size"))) ((CREATIONDATE WRITEDATE READDATE) `(SUBITEMS ("Newer first" ',ATTR "Sort files with newer dates appearing before older dates" ) ("Older first" '(,ATTR T) "Sort files with older dates appearing before newer dates" ))) NIL))))))))) ) (DEFINEQ (FB.EXPUNGECOMMAND (LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 22-Feb-2021 12:36 by rmk:") (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER 'DELETED)) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER 'BOTH)) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;|  "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " No") (T (CONCAT (COND (FAILED " Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T)))) (FB.NEWPATTERNCOMMAND (LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER)))))) (FB.NEWINFOCOMMAND (LAMBDA (BROWSER) (* \; "Edited 22-Feb-2021 12:35 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW 'BOTTOM 'JUSTIFY 'LOCALCLOSE) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW 'REGION))) 0) (* \;  "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW 'CLOSEFN (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) 'FILEBROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER 'CLEAR "Select from the lower menu which attributes are to be displayed, then click Recompute")))) (FB.DEPTHCOMMAND (LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL ) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH))))) (FB.SHAPECOMMAND (LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW 'EXTENT)) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW 'WIDTH))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW 'HEIGHT) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER )))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW 'REGION)) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) 'REGION))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \;  "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT)))))) (FB.REMOVE.FILE (LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM 'REMOVE)))) (FB.COUNT.FILE.CHANGE (LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE)))))))) (FB.SETNEWPATTERN (LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| ( DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN 'HOST))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) 'ICONWINDOW)) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN))) (FB.GET.NEWPATTERN (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN)))))) (FB.OPTIONSCOMMAND (LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire."))) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS (LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW 'MENU))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW))))) (FB.INFO.ITEM.NAMED (LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM)))) ) (DEFINEQ (FB.MAKECOUNTERWINDOW (LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 22-Feb-2021 12:41 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW 'TOP) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW 'FILEBROWSER) |with| COUNTERW) (WINDOWPROP COUNTERW 'REPAINTFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'RESHAPEFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'PAGEFULLFN (FUNCTION NILL)) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP COUNTERW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) COUNTERW))) (FB.COUNTERW.REDISPLAYFN (LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) 'FILEBROWSER))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \;  "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.UPDATE.COUNTERS (LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE 'DELETED) (* \;  "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE 'TOTAL) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT 'REPLACE))))) (FB.DISPLAY.COUNTERS (LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW 'WIDTH)) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)) )) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \;  "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT 'REPLACE) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING) ))) (FB.COUNTER.STRING (LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES))))) ) (DEFINEQ (FB.MAKEHEADINGWINDOW (LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Feb-2021 12:29 by rmk:") (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW 'TOP) (WINDOWPROP HEADINGW 'PASSTOMAINCOMS T) (* \;  "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW 'REPAINTFN (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW 'RESHAPEFN (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \;  "This is a white on black window") (DSPOPERATION 'INVERT HEADINGW) (DSPFILL NIL BLACKSHADE 'REPLACE HEADINGW) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP HEADINGW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HEADINGW))) (FB.HEADINGW.REDISPLAYFN (LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER) WINDOW))) (FB.HEADINGW.RESHAPEFN (LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW)))) (FB.HEADINGW.DISPLAY (LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW 'DSP)) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) 'BORDER)) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE 'REPLACE STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \;  "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \;  "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC)))))) ) (DEFINEQ (FB.ICONFN (LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW 'FILEBROWSER)) FB.ICONFONT POSITION NIL NIL 'FILE)))) (FB.INFOMENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (BROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN)))) (FB.CLOSEFN (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) 'DON\'T) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER 'DELETED) 0) (* \;  "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) 'DON\'T)))))) (FB.EXPUNGE?.MENU (LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT))))) (FB.AFTERCLOSEFN (LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL)))) (FB.CLOSE&EXPUNGE (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W 'MENU))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC '|Expunge| (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG))))))) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY (LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (TBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER)) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \;  "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \;  "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \;  "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER ))) (STREAMPROP IMAGESTREAM 'PRINTOPTIONS (LIST* 'DOCUMENT.NAME TITLE (STREAMPROP IMAGESTREAM 'PRINTOPTIONS))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW ) |of| FBROWSER) 'TITLE)) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES ) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) 'DATE) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \;  "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \;  "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \;  "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM) ) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \;  "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \;  "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \;  "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM))))) (FB.HARDCOPY.PRINT.TITLE (LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T))) (FB.HARDCOPY.MAXWIDTH (LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;|  "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \;  "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001 2021)) (DECLARE\: DONTCOPY (FILEMAP (NIL (28103 50739 (FB 28113 . 29069) (FB.COPYBINARYCOMMAND 29071 . 29417) (FB.COPYTEXTCOMMAND 29419 . 29761) (FILEBROWSER 29763 . 42869) (FB.TABLEBROWSER 42871 . 43088) (FB.SELECTEDFILES 43090 . 43727) (FB.FETCHFILENAME 43729 . 44121) (FB.DIRECTORYP 44123 . 44451) (FB.PROMPTWPRINT 44453 . 45499) (FB.PROMPTW.FORMAT 45501 . 46238) (FB.PROMPTFORINPUT 46240 . 48492) (FB.YES-OR-NO-P 48494 . 49528) ( FB.ALLOW.ABORT 49530 . 50384) (\\FB.HARDCOPY.TOFILE.EXTENSION 50386 . 50737)) (50763 51716 (FB.STARTUP 50773 . 51288) (FB.MAKERIGIDWINDOW 51290 . 51714)) (51717 57089 (FB.PRINTFN 51727 . 56880) (FB.COPYFN 56882 . 57087)) (57139 62464 (FB.MENU.WHENSELECTEDFN 57149 . 57507) (FB.COMMANDSELECTEDFN 57509 . 59048) (FB.SUBITEMP 59050 . 59485) (FB.MAKE.BROWSER.BUSY 59487 . 60039) (FB.FINISH.COMMAND 60041 . 61475) (FB.HANDLE.ABORT.BUTTON 61477 . 62462)) (62465 67981 (FB.DELETECOMMAND 62475 . 62756) ( FB.DELVERCOMMAND 62758 . 65951) (FB.IS.NOT.SUBDIRECTORY.ITEM 65953 . 66134) (FB.DELVER.FILES 66136 . 67225) (FB.DELETE.FILE 67227 . 67979)) (67982 69307 (FB.UNDELETECOMMAND 67992 . 68277) ( FB.UNDELETEALLCOMMAND 68279 . 68558) (FB.UNDELETE.FILE 68560 . 69305)) (69308 93489 (FB.COPYCOMMAND 69318 . 69587) (FB.RENAMECOMMAND 69589 . 69864) (FB.COPY/RENAME.COMMAND 69866 . 70789) ( FB.COPY/RENAME.ONE 70791 . 73113) (FB.COPY/RENAME.MANY 73115 . 79335) (FB.MERGE.DIRECTORIES 79337 . 79755) (FB.GREATEST.PREFIX 79757 . 81113) (FB.MAYBE.INSERT.FILE 81115 . 88555) (FB.GET.NEW.FILE.SPEC 88557 . 92388) (FB.CANONICAL.DIRECTORY 92390 . 93487)) (93490 101274 (FB.HARDCOPYCOMMAND 93500 . 94630 ) (FB.HARDCOPY.TOFILE 94632 . 101272)) (101275 110817 (FB.EDITCOMMAND 101285 . 102076) ( FB.EDITCOMMAND.ONEFILE 102078 . 105033) (FB.EDITLISPFILE 105035 . 106074) (FB.BROWSECOMMAND 106076 . 110815)) (110818 122611 (FB.FASTSEECOMMAND 110828 . 114278) (FB.FASTSEE.ONEFILE 114280 . 117309) ( FB.SEEFULLFN 117311 . 121442) (FB.SEEBUTTONFN 121444 . 122609)) (122612 124358 (FB.LOADCOMMAND 122622 . 123129) (FB.COMPILECOMMAND 123131 . 123669) (FB.OPERATE.ON.FILES 123671 . 124356)) (124359 171408 ( FB.UPDATECOMMAND 124369 . 124594) (FB.MAYBE.EXPUNGE 124596 . 125591) (FB.UPDATEBROWSERITEMS 125593 . 138808) (FB.DATE 138810 . 139551) (FB.ADJUST.DATE.WIDTH 139553 . 142521) (FB.SET.BROWSER.TITLE 142523 . 143380) (FB.MAYBE.WIDEN.NAMES 143382 . 145501) (FB.SET.DEFAULT.NAME.WIDTH 145503 . 146867) ( FB.CREATE.FILEBUCKET 146869 . 154089) (FB.CHECK.NAME.LENGTH 154091 . 156512) (FB.ADD.FILEGROUP 156514 . 158041) (FB.INSERT.DIRECTORY 158043 . 158281) (FB.MAKE.SUBDIRECTORY.ITEM 158283 . 159692) ( FB.ADD.FILE 159694 . 160307) (FB.INSERT.FILE 160309 . 163721) (FB.ANALYZE.PATTERN 163723 . 168987) ( FB.CANONICALIZE.PATTERN 168989 . 170301) (FB.GETALLFILEINFO 170303 . 171406)) (171409 179568 ( FB.SORT.VERSIONS 171419 . 174190) (FB.DECREASING.VERSION 174192 . 174861) (FB.INCREASING.VERSION 174863 . 175484) (FB.NAMES.DECREASING.VERSION 175486 . 176521) (FB.NAMES.INCREASING.VERSION 176523 . 177520) (FB.DECREASING.NUMERIC.ATTR 177522 . 178202) (FB.INCREASING.NUMERIC.ATTR 178204 . 178878) ( FB.ALPHABETIC.ATTR 178880 . 179566)) (179569 189411 (FB.SORTCOMMAND 179579 . 186409) ( FB.INSERT.SUBDIRECTORIES 186411 . 187208) (FB.GET.SORT.MENU 187210 . 189409)) (189412 205501 ( FB.EXPUNGECOMMAND 189422 . 191941) (FB.NEWPATTERNCOMMAND 191943 . 192341) (FB.NEWINFOCOMMAND 192343 . 195109) (FB.DEPTHCOMMAND 195111 . 196886) (FB.SHAPECOMMAND 196888 . 200230) (FB.REMOVE.FILE 200232 . 202053) (FB.COUNT.FILE.CHANGE 202055 . 203500) (FB.SETNEWPATTERN 203502 . 204672) (FB.GET.NEWPATTERN 204674 . 205258) (FB.OPTIONSCOMMAND 205260 . 205499)) (205536 206548 ( FB.INFOMENU.SHADEINITIALSELECTIONS 205546 . 206193) (FB.INFO.ITEM.NAMED 206195 . 206546)) (206549 216015 (FB.MAKECOUNTERWINDOW 206559 . 208021) (FB.COUNTERW.REDISPLAYFN 208023 . 208610) ( FB.UPDATE.COUNTERS 208612 . 210684) (FB.DISPLAY.COUNTERS 210686 . 215746) (FB.COUNTER.STRING 215748 . 216013)) (216016 220659 (FB.MAKEHEADINGWINDOW 216026 . 217574) (FB.HEADINGW.REDISPLAYFN 217576 . 217842) (FB.HEADINGW.RESHAPEFN 217844 . 218220) (FB.HEADINGW.DISPLAY 218222 . 220657)) (220660 224843 (FB.ICONFN 220670 . 221017) (FB.INFOMENU.WHENSELECTEDFN 221019 . 221749) (FB.CLOSEFN 221751 . 222954) (FB.EXPUNGE?.MENU 222956 . 223368) (FB.AFTERCLOSEFN 223370 . 223731) (FB.CLOSE&EXPUNGE 223733 . 224841 )) (224844 236902 (FB.HARDCOPY.DIRECTORY 224854 . 235211) (FB.HARDCOPY.PRINT.TITLE 235213 . 235539) ( FB.HARDCOPY.MAXWIDTH 235541 . 236900))))) STOP \ No newline at end of file diff --git a/library/FILEBROWSER.LCOM b/library/FILEBROWSER.LCOM index 7ea8b6f0dd7abdb999658b7829dcd4b1b584cf93..78f5bd47a0cad4d67f89915fe0964682a49402ef 100644 GIT binary patch delta 1413 zcmb7EO>7%Q6y9~)s39bZjcF^ZQeHw1an)Emv;RvEtnGEZ)ZSgMmoBb~X&Of)0;#Ai zTyPa};sO%U9Jo{nj@(EB0)bFK;=~Eg?WKnvdTURWdg`0;Uqqxz-NR^hX5QcTzVAI{ zC%$4QzOLu=)!N4ORjN<|M0Kd<=sQ{FBNB3 zYJS73#GadYRal}&ohj@ixjt?7f$ElK+w2dy!2RZn(Es@6#;031KDpJ0esAsehSO)4 z%_$&ykeq0G-?+zM(DFAF>7Zt>zY9VKi;>fFiDI9?ed_|ZcCx`(Nn4|7QU<|s0 zhx+)C{d)^o_X}&;23{U=izrxm;)em>6DY@F+V*1pL)o8efXsiewz#bcUuqHL{Pa{t z+IlOybSyoSNehLnd^{a+ZtrHA?}_$2{-O8HaCi40&84RVPj{vN2Df`onwxY~&}A!| znG#2$>tbn&|3F-~IGJ<1(oUNHZ5Zvtw|Aw_#{u^)V4R~qPyWwmI42Im`5E@z_0!vf zyhXGh-w-#C@201OmPE#1rupAT;V#XIck5@xJES*7yeG=iEofeHlduU?Goe;4MRC}S zlC)F{ibj7;6NGMJEo4X#)GJyFfJ{#(|AthB%?MA6th4Nx9P9WCK{IXLqXh}Ne1;w(WRKU?o~ap}T(D zZQQ$iL3okx-=tQ}b{nJp@7-S!a=YtL*s+2z@vgSKkQN>4wu?5S4%+YlmB5Qa8er0J z9S(2aKDcx3#{2Ic!eMX!y#w zK!dXBQ-CHx)$=>W#H+}>qU~4>3ab2MC^5KYk_bksMW~^yL3KIdTE~I_+x6QFtzgLU z*KcZZ?Jf0x!TIQ^aO~%jd!B5~KpJw(=`iSzT=>YzB}By$r&E{@CounuCBa)h0h17E zhGyB|G%FoOLnxI;$Oa?$CF`h*=2q~i+8!v!aD=igpI|+D+h75ZTd??4a3d^e{ zXxX8^+q6T5Hsdju*t&T>i&pJ1A2t5{_Krfxr2Mf0JfGQ~i&ak)7`Ik3QK#Z?8V|~l zCVISvfGtml{`avhk#jwAeTZu$2b=#O+-6__eY5tKK)mXeIu6 zf4L&^2I9FtjdDLsl59WE_wVL;9_%cc=&-lv>>w=$vQz?R+hU#r2>HiP&YO50ebn*z zMgCn>b^bPR?rk@D1&|6kO+*wuhP?~%!|vHviKI>9N~M{wl5!ell#-xD#3zwtkmEnD zY+RBRFkO6ptQHXTPGkk5l_#fC$V^Ux8sH;Q^W0Vku;!9yZ0e}-Pu;aN-tX_On^uhz JxA*$5{{U4yca{JE From 14415e197fd85a5f762f877ec236261cc8241eb5 Mon Sep 17 00:00:00 2001 From: Nick Briggs Date: Sat, 27 Feb 2021 17:59:06 -0800 Subject: [PATCH 29/31] Fix run-medley -dimensions processing to make sensible choices (#217) Given a "-dimension WxH" argument, round up the W to a multiple of 32 for the Lisp window width and use an X window geometry with an additional 22 pixels for both W and H to account for the current scrollbar size so that the resulting X window will not require scrolling. --- run-medley | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/run-medley b/run-medley index 41475634..75b061d3 100755 --- a/run-medley +++ b/run-medley @@ -59,8 +59,15 @@ while [ "$#" -ne 0 ]; do shift ;; "--dimensions" | "-dimensions") - geometry="-g $2" - screensize="-sc $2" + sw=`expr "$2" : "\([0-9]*\)x[0-9]*$"` + sh=`expr "$2" : "[0-9]*x\([0-9]*\)$"` + if [ -n "$sw" -a -n "$sh" ] ; then + sw=$(( (31+$sw)/32*32 )) + gw=$(( 22+$sw )) + gh=$(( 22+$sh )) + geometry="-g ${gw}x${gh}" + screensize="-sc ${sw}x${sh}" + fi shift ;; "--geometry" | "-geometry" | "-g") From d4e0a1ba2803efd0be02a0c535c3672333b51683 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sat, 27 Feb 2021 21:58:41 -0800 Subject: [PATCH 30/31] FILEBROWSER: Edit/see window stay on top Addresses #216 --- library/FILEBROWSER | 2 +- library/FILEBROWSER.LCOM | Bin 84365 -> 85539 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/library/FILEBROWSER b/library/FILEBROWSER index 045202a0..75e82857 100644 --- a/library/FILEBROWSER +++ b/library/FILEBROWSER @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "25-Feb-2021 13:24:50"  |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;27| 258499 |changes| |to:| (FNS FB.EDITCOMMAND.ONEFILE) |previous| |date:| "22-Feb-2021 12:41:59" |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;25|) ; Copyright (c) 1983-1991, 1993-1994, 1999-2001, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (DECLARE\: EVAL@COMPILE DONTCOPY (P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)))) (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (P (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE)) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (INITVARS (FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser" ))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files" ) ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files" ))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing" ))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards" ) ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards" ) ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window" ) ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory" ))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files" ) ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files")) ) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files") ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files") (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files")) ) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion" ) (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern" ) ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser" ) ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed" ) ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible" ))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice" )))) (VARS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.DIRECTORYP FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITCOMMAND.ONEFILE FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (DECLARE\: EVAL@COMPILE DONTCOPY (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)) ) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQ? FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD ) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice") )) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files. Your deletions are thus ignored."))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB (NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \;  "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',PAT ',PROPS ',OPTIONS) 'NAME 'FB))) NIL)) (FB.COPYBINARYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE BINARY)))))) (FB.COPYTEXTCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE TEXT)))))) (FILEBROWSER (LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT 'HEIGHT)) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \;  "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \;  "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \;  "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \;  "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT 'HEIGHT)))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT 'HEIGHT) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC )) (SETQ REGION (GETREGION (PROGN (* \;  "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \;  "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT ))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \;  "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW 'FILEBROWSER (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \;  "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \;  "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \;  "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW 'RIGHT 'TOP)) (PROGN (* \;  "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \;  "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ '(("--Abort--" NIL "Abort the current FileBrowser operation" )) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT 'WEIGHT 'BOLD) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W 'PASSTOMAINCOMS))) |do| (* \;  "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W 'PASSTOMAINCOMS (UNION '(HARDCOPYIMAGEW) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST 'PRINTFN (FUNCTION FB.PRINTFN) 'COPYFN (FUNCTION FB.COPYFN) 'USERDATA BROWSER 'CLOSEFN (FUNCTION FB.CLOSEFN) 'AFTERCLOSEFN (FUNCTION FB.AFTERCLOSEFN) 'HEADINGWINDOW HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW 'HARDCOPYFN (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW 'ICONFN (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \;  "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS `(,(FUNCTION FB.STARTUP) ',BROWSER ',COMMANDMENU ',(FUNCTION FB.UPDATEBROWSERITEMS)) 'NAME '|FB-Update| 'BEFOREEXIT 'DON\'T)) (RETURN BROWSERWINDOW)))) (FB.TABLEBROWSER (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (FB.SELECTEDFILES (LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)) 'SELECTED)) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL)))) (FB.FETCHFILENAME (LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM 'TABLEITEM))))) (FB.DIRECTORYP (LAMBDA (FILE) (* \; "Edited 20-Feb-2021 20:05 by rmk:") (* |;;| "Does FILE denote a directory?") (CL:WHEN (TYPE? TABLEITEM FILE) (SETQ FILE (FETCH TIDATA OF FILE))) (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE))) (FB.PROMPTWPRINT (LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) 'FILEBROWSER))) THING) (* \;  "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW)))))))) (FB.PROMPTW.FORMAT (CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS)))) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P (LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;|  "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) 'Y) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) 'N) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL))))) (FB.ALLOW.ABORT (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER 'FILEBROWSER) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) 'BOTTOM) (* \;  "And repaint it in case it was used last time") (REDISPLAYW (CAR W)))))) (\\FB.HARDCOPY.TOFILE.EXTENSION (LAMBDA NIL (* \;  "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS 'IP) (POSTSCRIPT 'PS) (DEFAULT TYPE))))) ) (* \; "Setup") (DEFINEQ (FB.STARTUP (LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC '|Recompute| (|fetch| (MENU ITEMS) |of| COMMANDMENU) ) COMMANDMENU) (CL:FUNCALL FN BROWSER)))) (FB.MAKERIGIDWINDOW (LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW 'REGION)))) (WINDOWPROP WINDOW 'MINSIZE (CONS 0 HEIGHT)) (WINDOWPROP WINDOW 'MAXSIZE (CONS SCREENWIDTH HEIGHT)) WINDOW))) ) (DEFINEQ (FB.PRINTFN (LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW 'DSP)) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \;  "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \;  "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \;  "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \;  "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT 'DATE) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM))))) (FB.COPYFN (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM))))) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS `(,(FUNCTION FB.COMMANDSELECTEDFN) ',ITEM ',MENU ',KEY) 'NAME (PACK* 'FB- (CAR ITEM)) 'BEFOREEXIT 'DON\'T))) (FB.COMMANDSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW))))))) (FB.SUBITEMP (LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) 'SUBITEMS) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I))))))) (FB.MAKE.BROWSER.BUSY (LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE)) T)))) (FB.FINISH.COMMAND (LAMBDA (BROWSER ITEM MENU) (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \;  "Take down the abort button if there was one") (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W 'MENU))))) M FB.ITEMUNSELECTEDSHADE) (DETACHWINDOW W) (CLOSEW W))) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted."))))) (FB.HANDLE.ABORT.BUTTON (LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) 'FILEBROWSER)) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER )) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \;  "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC))))) ) (DEFINEQ (FB.DELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.DELVERCOMMAND (LAMBDA (FBROWSER) (* \;  "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM)) ))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER ) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER 'DELETED) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED)))))) (FB.IS.NOT.SUBDIRECTORY.ITEM (LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES (LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \;  "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED)))) (FB.DELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T))))) ) (DEFINEQ (FB.UNDELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETEALLCOMMAND (LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE))))))))) ) (DEFINEQ (FB.COPYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE))))) (FB.RENAMECOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Rename| (CONS (FUNCTION RENAMEFILE))))) (FB.COPY/RENAME.COMMAND (LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN)))))))))) (FB.COPY/RENAME.ONE (LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \;  "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD '|Rename|) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) 'BOTH) (T 'TOTAL)))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \;  "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE 'TOTAL)))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME))))))) (FB.COPY/RENAME.MANY (LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted") ) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST) (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'DEVICE)) (OR (LISTGET FIELDS 'NAME) (LISTGET FIELDS 'EXTENSION) (LISTGET FIELDS 'VERSION))) (* \;  "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST)) (SETQ DIR (OR (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'RELATIVEDIRECTORY))) (SETQ DEVICE (LISTGET FIELDS 'DEVICE)) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM))) ) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER 'Y) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay") ) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION) ))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING 'HOST HOST 'DEVICE DEVICE 'DIRECTORY (|if| (NOT RETAIN) |then| DIR |else| (* \;  "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) 'VERSION NIL 'BODY OLDNAME) CMD MOVEFN))))))) (FB.MERGE.DIRECTORIES (LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL))))) (FB.GREATEST.PREFIX (LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL)))))))) (FB.MAYBE.INSERT.FILE (LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \;  "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;|  "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER) ))) (* |;;|  "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;|  "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \;  "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM))) ) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME 'VERSION NIL 'TENEX))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION 'CREATIONDATE (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)) )) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME 'ICREATIONDATE)) (= CRDATE2 CRDATE))) |then| (* \;  "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \;  "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING 'BODY NEWNAME 'EXTENSION "" 'VERSION VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \;  "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \;  "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD '|Rename|)) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD '|Rename|) (|fetch| TISELECTED |of| OLDITEM)) (* \;  "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T))))) (FB.GET.NEW.FILE.SPEC (LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING 'DIRECTORY (OR (|fetch| (  FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) 'VERSION NIL 'BODY OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) 'NAME))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING 'DIRECTORY NEWNAME 'VERSION NIL 'BODY OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS 'EXTENSION))) (EQ (NCHARS NAMEFIELD) 0))) (* \;  "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these") ) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) 'HOST) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME)))))))) (FB.CANONICAL.DIRECTORY (LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER 'FILEBROWSER))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \;  "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL 'ASK)) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) 'Y) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW 'PROCESS NIL))))) ) (DEFINEQ (FB.HARDCOPYCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \;  "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST 'SERVER PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS))))))) (FB.HARDCOPY.TOFILE (LAMBDA (BROWSER FILES) (* \;  "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING 'NAME '* 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ))) (T (PACKFILENAME.STRING 'VERSION NIL 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ) 'BODY (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS '* (CADR TAIL))) (|if| (NEQ (CAR TAIL) 'NAME) |then| (RETURN (SETQ MSG "Only name portion can contain *") )) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files" ))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \;  "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS 'DIRECTORY NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE 'EXTENSION))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC 'EXTENSION (CDR TYPE)))) |do| (* \;  "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE 'CONVERSION)) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) 'TEXT)) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL 'TENEX)) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS 'NAME) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) 'VERSION NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE))))))) ) (DEFINEQ (FB.EDITCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 21-Feb-2021 15:56 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (IF (DIRECTORYNAMEP FILE) THEN (FB.BROWSECOMMAND BROWSER) ELSEIF (GETD 'OPENTEXTSTREAM) THEN (FB.EDITCOMMAND.ONEFILE BROWSER FILE OPTION) ELSE (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU))))) (FB.EDITCOMMAND.ONEFILE (LAMBDA (BROWSER FILE OPTION) (* \; "Edited 25-Feb-2021 12:31 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (* |;;| "Called when we know that FILE is a file, not a directory, and that TEDIT exists. If OPTION is READONLY, we don't want to edit, just view. If FILE is a lisp sourcefile, we execute the font changes by COPY.TEXT.TO.IMAGE") (CL:UNLESS OPTION (SETQ OPTION FB.DEFAULT.EDITOR)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (IF (LISPSOURCEFILEP FILE) THEN (SELECTQ OPTION ((LISP NIL TEDIT) (* |;;| "Asks to load prop and edits the coms. We really don't want to use a text editor on a source file.") (* |;;| "The FUNCALL at the bottom is concerning.") (FB.EDITLISPFILE FILE BROWSER)) (READONLY (* \; "READONLY on call from SEE") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STREAM NSTR) (TEDIT NSTR NIL NIL '(READONLY T))))) (CL:FUNCALL OPTION (MKATOM FILE))) ELSE (SELECTQ OPTION (READONLY (* |;;| "From SEE command. We want to be able to scroll around in the content, can't do that if it isn't random access. So in that case we do a secret NODIRCORE copy and look at that.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((NSTR)) (CL:UNLESS (RANDACCESSP STREAM) (SETQ NSTR (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW NIL (LIST (LIST 'TYPE (GETFILEINFO STREAM 'TYPE))))) (COPYBYTES STREAM NSTR)) (TEDIT (OR NSTR STREAM) NIL NIL '(READONLY T))))) ((TEDIT NIL) (TEDIT (MKATOM FILE))) (LISP (FB.PROMPTW.FORMAT BROWSER "Failed because not a Lisp source file")) (CL:FUNCALL OPTION (MKATOM FILE))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) (FB.EDITLISPFILE (LAMBDA (FILE BROWSER) (* \; "Edited 21-Feb-2021 17:29 by rmk:") (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) 'FILEDATES)) FILE)) (NOT (GET ROOT 'FILE)) (NOT (BOUNDP (FILECOMS ROOT)))) (FB.PROMPTW.FORMAT BROWSER "The file ~A is not loaded or is not current." FILE) (COND ((MOUSECONFIRM (CONCAT "(LOAD '" FILE " 'PROP)? ") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL `(LOAD ',FILE 'PROP))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT '(FILES :DONTWAIT)))))) (FB.BROWSECOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 20-Feb-2021 20:10 by rmk:") (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ NAME (FB.FETCHFILENAME FILE)) (|if| (OR (FB.DIRECTORYP FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL 'TENEX)) (NAMETAIL (MEMB 'NAME FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) 'VERSION) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \;  "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \;  "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS 'DIRECTORY)) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS 'DIRECTORY (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS 'HOST) 'OSTYPE) 'UNIX) |then| (* \;  "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',NAME ',(MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)) ,@(AND DEPTH `('(:DEPTH ,DEPTH))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME))))) ) (DEFINEQ (FB.FASTSEECOMMAND (LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'NAME) (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'EXTENSION)))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW 'PAGEFULLFN (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'INUSE NIL) (DEL.PROCESS (WINDOWPROP W 'PROCESS)))))) ) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW 'PROCESS NIL) (* \;  "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW 'MORETYPE)))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \;  "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \;  "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL))))))) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \; "Edited 21-Feb-2021 14:46 by rmk:") (* \; "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((DIRECTORYNAMEP FILE) (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER)) (T (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS)))))))))) (FB.SEEFULLFN (LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW 'MORETYPE))))) (EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS '(("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one" ) ("Abort" ABORT "Abort viewing of this and any further files" ))) (FINISHEDMOREBUTTONS '((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files" ))) '((" More " MORE "View another screenfull of the file" ) (" Abort " ABORT "Abort view; allow this window to be re-used" ))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH ) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW 'MOREEVENT (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW 'TITLE)))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS 'REGION)) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW 'REGION))) 'TOP) (T 'BOTTOM)) 'LEFT) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW 'MOREOK NIL))))) (FB.SEEBUTTONFN (LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \;  "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW 'MOREOK T) (NOTIFY.EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (NEXT (* \;  "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW 'PROCESS) '(CL:THROW :NEXT))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW 'PROCESS))) (SHOULDNT))))) ) (DEFINEQ (FB.LOADCOMMAND (LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) 'NAME 'LOAD 'BEFOREEXIT 'DON\'T))))) (FB.COMPILECOMMAND (LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) 'NAME 'COMPILE 'BEFOREEXIT 'DON\'T))))) (FB.OPERATE.ON.FILES (LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN 'LOAD)) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| `(,FN ',(FB.FETCHFILENAME FILEENTRY) ,@(AND LDFLG `(',LDFLG))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS 'PROGN FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM))))) ) (DEFINEQ (FB.UPDATECOMMAND (LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER '|Recompute|) (FB.UPDATEBROWSERITEMS BROWSER))))) (FB.MAYBE.EXPUNGE (LAMBDA (BROWSER COMMAND) (* \; "Edited 22-Feb-2021 12:33 by rmk:") (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL))))) (FB.UPDATEBROWSERITEMS (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \;  "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \;  "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \;  "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION 'SIZE INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION 'LENGTH INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) ) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \;  "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN 'DIRECTORY)))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS 'SUBTREE.SIZE)) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS '(SORT RESETLST))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \;  "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \;  "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME ) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER 'CLEAR "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER '|done|) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.DATE (LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;|  "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9))))) (FB.ADJUST.DATE.WIDTH (LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) 'DATE) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM))) ) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \;  "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT)))) (FB.SET.BROWSER.TITLE (LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) 'TITLE (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser"))))))) (FB.MAYBE.WIDEN.NAMES (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \;  "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES ) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \;  "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T))))))) (FB.SET.DEFAULT.NAME.WIDTH (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL)))) (FB.CREATE.FILEBUCKET (LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \;  "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR ))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \;  "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \;  "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \;  "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER )) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \;  "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA))) (FB.CHECK.NAME.LENGTH (LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \;  "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN)))))))))) (FB.ADD.FILEGROUP (LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA))))(* \;  "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \;  "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA)))))) (FB.INSERT.DIRECTORY (LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM))) (FB.MAKE.SUBDIRECTORY.ITEM (LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER) )))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T))))) (FB.ADD.FILE (LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM)))) (FB.INSERT.FILE (LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already") ) (T (* |;;|  "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \;  "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \;  "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE 'ADD)))) (FB.ANALYZE.PATTERN (LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \;  "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \;  "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \;  "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))) )) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \;  "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN))) (FB.GETALLFILEINFO (LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) '(SIZE LENGTH)) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR 'SUBTREE.SIZE))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE)))) ) (DEFINEQ (FB.SORT.VERSIONS (LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \;  "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME ) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \;  "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS))) (FB.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y))))) (FB.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y))))) (FB.NAMES.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL))) (FB.NAMES.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL))) (FB.DECREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.INCREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.ALPHABETIC.ATTR (LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL))) ) (DEFINEQ (FB.SORTCOMMAND (LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \;  "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \;  "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \;  "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME ) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA))) ) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \;  "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done")))) (FB.INSERT.SUBDIRECTORIES (LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \;  "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL))))) (FB.GET.SORT.MENU (LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS '("Name" 'NAME "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" 'NAME "Sort files by name, decreasing version numbers") ("Increasing version" '(NAME T) "Sort files by name, increasing version numbers"))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER ) |collect| `(,(SETQ ATTR (CAR ATTR)) ',ATTR "Sort by this attribute" ,(SELECTQ ATTR ((SIZE LENGTH BYTESIZE) `(SUBITEMS ("Decreasing" ',ATTR "Sort files in order of decreasing size" ) ("Increasing" '(,ATTR T) "Sort files in order of increasing size"))) ((CREATIONDATE WRITEDATE READDATE) `(SUBITEMS ("Newer first" ',ATTR "Sort files with newer dates appearing before older dates" ) ("Older first" '(,ATTR T) "Sort files with older dates appearing before newer dates" ))) NIL))))))))) ) (DEFINEQ (FB.EXPUNGECOMMAND (LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 22-Feb-2021 12:36 by rmk:") (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER 'DELETED)) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER 'BOTH)) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;|  "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " No") (T (CONCAT (COND (FAILED " Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T)))) (FB.NEWPATTERNCOMMAND (LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER)))))) (FB.NEWINFOCOMMAND (LAMBDA (BROWSER) (* \; "Edited 22-Feb-2021 12:35 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW 'BOTTOM 'JUSTIFY 'LOCALCLOSE) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW 'REGION))) 0) (* \;  "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW 'CLOSEFN (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) 'FILEBROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER 'CLEAR "Select from the lower menu which attributes are to be displayed, then click Recompute")))) (FB.DEPTHCOMMAND (LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL ) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH))))) (FB.SHAPECOMMAND (LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW 'EXTENT)) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW 'WIDTH))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW 'HEIGHT) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER )))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW 'REGION)) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) 'REGION))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \;  "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT)))))) (FB.REMOVE.FILE (LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM 'REMOVE)))) (FB.COUNT.FILE.CHANGE (LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE)))))))) (FB.SETNEWPATTERN (LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| ( DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN 'HOST))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) 'ICONWINDOW)) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN))) (FB.GET.NEWPATTERN (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN)))))) (FB.OPTIONSCOMMAND (LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire."))) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS (LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW 'MENU))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW))))) (FB.INFO.ITEM.NAMED (LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM)))) ) (DEFINEQ (FB.MAKECOUNTERWINDOW (LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 22-Feb-2021 12:41 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW 'TOP) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW 'FILEBROWSER) |with| COUNTERW) (WINDOWPROP COUNTERW 'REPAINTFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'RESHAPEFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'PAGEFULLFN (FUNCTION NILL)) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP COUNTERW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) COUNTERW))) (FB.COUNTERW.REDISPLAYFN (LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) 'FILEBROWSER))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \;  "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.UPDATE.COUNTERS (LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE 'DELETED) (* \;  "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE 'TOTAL) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT 'REPLACE))))) (FB.DISPLAY.COUNTERS (LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW 'WIDTH)) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)) )) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \;  "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT 'REPLACE) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING) ))) (FB.COUNTER.STRING (LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES))))) ) (DEFINEQ (FB.MAKEHEADINGWINDOW (LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Feb-2021 12:29 by rmk:") (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW 'TOP) (WINDOWPROP HEADINGW 'PASSTOMAINCOMS T) (* \;  "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW 'REPAINTFN (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW 'RESHAPEFN (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \;  "This is a white on black window") (DSPOPERATION 'INVERT HEADINGW) (DSPFILL NIL BLACKSHADE 'REPLACE HEADINGW) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP HEADINGW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HEADINGW))) (FB.HEADINGW.REDISPLAYFN (LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER) WINDOW))) (FB.HEADINGW.RESHAPEFN (LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW)))) (FB.HEADINGW.DISPLAY (LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW 'DSP)) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) 'BORDER)) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE 'REPLACE STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \;  "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \;  "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC)))))) ) (DEFINEQ (FB.ICONFN (LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW 'FILEBROWSER)) FB.ICONFONT POSITION NIL NIL 'FILE)))) (FB.INFOMENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (BROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN)))) (FB.CLOSEFN (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) 'DON\'T) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER 'DELETED) 0) (* \;  "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) 'DON\'T)))))) (FB.EXPUNGE?.MENU (LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT))))) (FB.AFTERCLOSEFN (LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL)))) (FB.CLOSE&EXPUNGE (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W 'MENU))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC '|Expunge| (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG))))))) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY (LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (TBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER)) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \;  "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \;  "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \;  "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER ))) (STREAMPROP IMAGESTREAM 'PRINTOPTIONS (LIST* 'DOCUMENT.NAME TITLE (STREAMPROP IMAGESTREAM 'PRINTOPTIONS))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW ) |of| FBROWSER) 'TITLE)) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES ) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) 'DATE) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \;  "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \;  "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \;  "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM) ) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \;  "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \;  "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \;  "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM))))) (FB.HARDCOPY.PRINT.TITLE (LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T))) (FB.HARDCOPY.MAXWIDTH (LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;|  "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \;  "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001 2021)) (DECLARE\: DONTCOPY (FILEMAP (NIL (28103 50739 (FB 28113 . 29069) (FB.COPYBINARYCOMMAND 29071 . 29417) (FB.COPYTEXTCOMMAND 29419 . 29761) (FILEBROWSER 29763 . 42869) (FB.TABLEBROWSER 42871 . 43088) (FB.SELECTEDFILES 43090 . 43727) (FB.FETCHFILENAME 43729 . 44121) (FB.DIRECTORYP 44123 . 44451) (FB.PROMPTWPRINT 44453 . 45499) (FB.PROMPTW.FORMAT 45501 . 46238) (FB.PROMPTFORINPUT 46240 . 48492) (FB.YES-OR-NO-P 48494 . 49528) ( FB.ALLOW.ABORT 49530 . 50384) (\\FB.HARDCOPY.TOFILE.EXTENSION 50386 . 50737)) (50763 51716 (FB.STARTUP 50773 . 51288) (FB.MAKERIGIDWINDOW 51290 . 51714)) (51717 57089 (FB.PRINTFN 51727 . 56880) (FB.COPYFN 56882 . 57087)) (57139 62464 (FB.MENU.WHENSELECTEDFN 57149 . 57507) (FB.COMMANDSELECTEDFN 57509 . 59048) (FB.SUBITEMP 59050 . 59485) (FB.MAKE.BROWSER.BUSY 59487 . 60039) (FB.FINISH.COMMAND 60041 . 61475) (FB.HANDLE.ABORT.BUTTON 61477 . 62462)) (62465 67981 (FB.DELETECOMMAND 62475 . 62756) ( FB.DELVERCOMMAND 62758 . 65951) (FB.IS.NOT.SUBDIRECTORY.ITEM 65953 . 66134) (FB.DELVER.FILES 66136 . 67225) (FB.DELETE.FILE 67227 . 67979)) (67982 69307 (FB.UNDELETECOMMAND 67992 . 68277) ( FB.UNDELETEALLCOMMAND 68279 . 68558) (FB.UNDELETE.FILE 68560 . 69305)) (69308 93489 (FB.COPYCOMMAND 69318 . 69587) (FB.RENAMECOMMAND 69589 . 69864) (FB.COPY/RENAME.COMMAND 69866 . 70789) ( FB.COPY/RENAME.ONE 70791 . 73113) (FB.COPY/RENAME.MANY 73115 . 79335) (FB.MERGE.DIRECTORIES 79337 . 79755) (FB.GREATEST.PREFIX 79757 . 81113) (FB.MAYBE.INSERT.FILE 81115 . 88555) (FB.GET.NEW.FILE.SPEC 88557 . 92388) (FB.CANONICAL.DIRECTORY 92390 . 93487)) (93490 101274 (FB.HARDCOPYCOMMAND 93500 . 94630 ) (FB.HARDCOPY.TOFILE 94632 . 101272)) (101275 110817 (FB.EDITCOMMAND 101285 . 102076) ( FB.EDITCOMMAND.ONEFILE 102078 . 105033) (FB.EDITLISPFILE 105035 . 106074) (FB.BROWSECOMMAND 106076 . 110815)) (110818 122611 (FB.FASTSEECOMMAND 110828 . 114278) (FB.FASTSEE.ONEFILE 114280 . 117309) ( FB.SEEFULLFN 117311 . 121442) (FB.SEEBUTTONFN 121444 . 122609)) (122612 124358 (FB.LOADCOMMAND 122622 . 123129) (FB.COMPILECOMMAND 123131 . 123669) (FB.OPERATE.ON.FILES 123671 . 124356)) (124359 171408 ( FB.UPDATECOMMAND 124369 . 124594) (FB.MAYBE.EXPUNGE 124596 . 125591) (FB.UPDATEBROWSERITEMS 125593 . 138808) (FB.DATE 138810 . 139551) (FB.ADJUST.DATE.WIDTH 139553 . 142521) (FB.SET.BROWSER.TITLE 142523 . 143380) (FB.MAYBE.WIDEN.NAMES 143382 . 145501) (FB.SET.DEFAULT.NAME.WIDTH 145503 . 146867) ( FB.CREATE.FILEBUCKET 146869 . 154089) (FB.CHECK.NAME.LENGTH 154091 . 156512) (FB.ADD.FILEGROUP 156514 . 158041) (FB.INSERT.DIRECTORY 158043 . 158281) (FB.MAKE.SUBDIRECTORY.ITEM 158283 . 159692) ( FB.ADD.FILE 159694 . 160307) (FB.INSERT.FILE 160309 . 163721) (FB.ANALYZE.PATTERN 163723 . 168987) ( FB.CANONICALIZE.PATTERN 168989 . 170301) (FB.GETALLFILEINFO 170303 . 171406)) (171409 179568 ( FB.SORT.VERSIONS 171419 . 174190) (FB.DECREASING.VERSION 174192 . 174861) (FB.INCREASING.VERSION 174863 . 175484) (FB.NAMES.DECREASING.VERSION 175486 . 176521) (FB.NAMES.INCREASING.VERSION 176523 . 177520) (FB.DECREASING.NUMERIC.ATTR 177522 . 178202) (FB.INCREASING.NUMERIC.ATTR 178204 . 178878) ( FB.ALPHABETIC.ATTR 178880 . 179566)) (179569 189411 (FB.SORTCOMMAND 179579 . 186409) ( FB.INSERT.SUBDIRECTORIES 186411 . 187208) (FB.GET.SORT.MENU 187210 . 189409)) (189412 205501 ( FB.EXPUNGECOMMAND 189422 . 191941) (FB.NEWPATTERNCOMMAND 191943 . 192341) (FB.NEWINFOCOMMAND 192343 . 195109) (FB.DEPTHCOMMAND 195111 . 196886) (FB.SHAPECOMMAND 196888 . 200230) (FB.REMOVE.FILE 200232 . 202053) (FB.COUNT.FILE.CHANGE 202055 . 203500) (FB.SETNEWPATTERN 203502 . 204672) (FB.GET.NEWPATTERN 204674 . 205258) (FB.OPTIONSCOMMAND 205260 . 205499)) (205536 206548 ( FB.INFOMENU.SHADEINITIALSELECTIONS 205546 . 206193) (FB.INFO.ITEM.NAMED 206195 . 206546)) (206549 216015 (FB.MAKECOUNTERWINDOW 206559 . 208021) (FB.COUNTERW.REDISPLAYFN 208023 . 208610) ( FB.UPDATE.COUNTERS 208612 . 210684) (FB.DISPLAY.COUNTERS 210686 . 215746) (FB.COUNTER.STRING 215748 . 216013)) (216016 220659 (FB.MAKEHEADINGWINDOW 216026 . 217574) (FB.HEADINGW.REDISPLAYFN 217576 . 217842) (FB.HEADINGW.RESHAPEFN 217844 . 218220) (FB.HEADINGW.DISPLAY 218222 . 220657)) (220660 224843 (FB.ICONFN 220670 . 221017) (FB.INFOMENU.WHENSELECTEDFN 221019 . 221749) (FB.CLOSEFN 221751 . 222954) (FB.EXPUNGE?.MENU 222956 . 223368) (FB.AFTERCLOSEFN 223370 . 223731) (FB.CLOSE&EXPUNGE 223733 . 224841 )) (224844 236902 (FB.HARDCOPY.DIRECTORY 224854 . 235211) (FB.HARDCOPY.PRINT.TITLE 235213 . 235539) ( FB.HARDCOPY.MAXWIDTH 235541 . 236900))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "27-Feb-2021 20:08:26"  |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;33| 261320 |changes| |to:| (FNS FB.EDITCOMMAND.ONEFILE FB.FINISH.COMMAND FB.MAKE.BROWSER.BUSY FB.EDITCOMMAND) |previous| |date:| "25-Feb-2021 13:24:50" |{DSK}kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;27|) ; Copyright (c) 1983-1991, 1993-1994, 1999-2001, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (DECLARE\: EVAL@COMPILE DONTCOPY (P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)))) (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (P (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE)) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (INITVARS (FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser" ))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files" ) ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files" ))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing" ))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards" ) ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards" ) ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window" ) ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory" ))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files" ) ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files")) ) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files") ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files") (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files")) ) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion" ) (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern" ) ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser" ) ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed" ) ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible" ))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice" )))) (VARS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.DIRECTORYP FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITCOMMAND.ONEFILE FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (DECLARE\: EVAL@COMPILE DONTCOPY (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) (TERPRI T) (PRIN1 "NOTE: FILEBROWSER requires EXPORTS.ALL" T) (TERPRI T) (TERPRI T)) ) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "Set up for MODERNIZE windows, whether or not MODERNIZE is pre-loaded") (MOVD? 'NILL 'TOTOPW.MODERNIZE) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQ? FB.MENU.ITEMS '((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion." ) ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. You specify how many versions to keep."))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)" ) (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| (FB.EDITCOMMAND READONLY) "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD ) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice") )) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files. Your deletions are thus ignored."))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB (NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \;  "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',PAT ',PROPS ',OPTIONS) 'NAME 'FB))) NIL)) (FB.COPYBINARYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE BINARY)))))) (FB.COPYTEXTCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE) '((TYPE TEXT)))))) (FILEBROWSER (LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT 'HEIGHT)) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \;  "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \;  "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \;  "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \;  "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT 'HEIGHT)))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT 'HEIGHT) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC )) (SETQ REGION (GETREGION (PROGN (* \;  "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \;  "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT ))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \;  "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW 'FILEBROWSER (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \;  "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \;  "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \;  "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW 'RIGHT 'TOP)) (PROGN (* \;  "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \;  "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ '(("--Abort--" NIL "Abort the current FileBrowser operation" )) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT 'WEIGHT 'BOLD) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W 'PASSTOMAINCOMS))) |do| (* \;  "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W 'PASSTOMAINCOMS (UNION '(HARDCOPYIMAGEW) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST 'PRINTFN (FUNCTION FB.PRINTFN) 'COPYFN (FUNCTION FB.COPYFN) 'USERDATA BROWSER 'CLOSEFN (FUNCTION FB.CLOSEFN) 'AFTERCLOSEFN (FUNCTION FB.AFTERCLOSEFN) 'HEADINGWINDOW HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW 'HARDCOPYFN (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW 'ICONFN (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \;  "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS `(,(FUNCTION FB.STARTUP) ',BROWSER ',COMMANDMENU ',(FUNCTION FB.UPDATEBROWSERITEMS)) 'NAME '|FB-Update| 'BEFOREEXIT 'DON\'T)) (RETURN BROWSERWINDOW)))) (FB.TABLEBROWSER (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (FB.SELECTEDFILES (LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER 'FILEBROWSER)) 'SELECTED)) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL)))) (FB.FETCHFILENAME (LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM 'TABLEITEM))))) (FB.DIRECTORYP (LAMBDA (FILE) (* \; "Edited 20-Feb-2021 20:05 by rmk:") (* |;;| "Does FILE denote a directory?") (CL:WHEN (TYPE? TABLEITEM FILE) (SETQ FILE (FETCH TIDATA OF FILE))) (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE))) (FB.PROMPTWPRINT (LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) 'FILEBROWSER))) THING) (* \;  "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW)))))))) (FB.PROMPTW.FORMAT (CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER)))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS)))) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P (LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;|  "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) 'Y) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) 'N) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL))))) (FB.ALLOW.ABORT (LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER 'FILEBROWSER) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) 'BOTTOM) (* \;  "And repaint it in case it was used last time") (REDISPLAYW (CAR W)))))) (\\FB.HARDCOPY.TOFILE.EXTENSION (LAMBDA NIL (* \;  "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS 'IP) (POSTSCRIPT 'PS) (DEFAULT TYPE))))) ) (* \; "Setup") (DEFINEQ (FB.STARTUP (LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC '|Recompute| (|fetch| (MENU ITEMS) |of| COMMANDMENU) ) COMMANDMENU) (CL:FUNCALL FN BROWSER)))) (FB.MAKERIGIDWINDOW (LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW 'REGION)))) (WINDOWPROP WINDOW 'MINSIZE (CONS 0 HEIGHT)) (WINDOWPROP WINDOW 'MAXSIZE (CONS SCREENWIDTH HEIGHT)) WINDOW))) ) (DEFINEQ (FB.PRINTFN (LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW 'DSP)) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \;  "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \;  "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \;  "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \;  "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT 'DATE) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM))))) (FB.COPYFN (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM))))) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS `(,(FUNCTION FB.COMMANDSELECTEDFN) ',ITEM ',MENU ',KEY) 'NAME (PACK* 'FB- (CAR ITEM)) 'BEFOREEXIT 'DON\'T))) (FB.COMMANDSELECTEDFN (LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW))))))) (FB.SUBITEMP (LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) 'SUBITEMS) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I))))))) (FB.MAKE.BROWSER.BUSY (LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 27-Feb-2021 19:21 by rmk:") (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMSELECTEDSHADE))) T)))) (FB.FINISH.COMMAND (LAMBDA (BROWSER ITEM MENU) (* \; "Edited 27-Feb-2021 19:52 by rmk:") (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (* |;;| "RMK: Don't reshade the item if it isn't needed. This will prevent the FB window from popping on top of any windows that the menu command created (SEE, EDIT), if they clear it before they open their windows.") (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \;  "Take down the abort button if there was one") (DETACHWINDOW W) (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W 'MENU))))) M FB.ITEMUNSELECTEDSHADE) (CLOSEW W))) (|if| (AND ITEM (EQ ITEM (CAR (GETMENUPROP MENU 'ITEMSHADE))) (NEQ FB.ITEMUNSELECTEDSHADE (CDR (GETMENUPROP MENU 'ITEMSHADE)))) |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'FB.ITEMUNSELECTEDSHADE NIL)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted."))))) (FB.HANDLE.ABORT.BUTTON (LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) 'FILEBROWSER)) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER )) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \;  "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC))))) ) (DEFINEQ (FB.DELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.DELVERCOMMAND (LAMBDA (FBROWSER) (* \;  "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM)) ))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER ) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER 'DELETED) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED)))))) (FB.IS.NOT.SUBDIRECTORY.ITEM (LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES (LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \;  "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED)))) (FB.DELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T))))) ) (DEFINEQ (FB.UNDELETECOMMAND (LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETEALLCOMMAND (LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER))) (FB.UNDELETE.FILE (LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE))))))))) ) (DEFINEQ (FB.COPYCOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Copy| (CONS (FUNCTION COPYFILE))))) (FB.RENAMECOMMAND (LAMBDA (BROWSER) (* \;  "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER '|Rename| (CONS (FUNCTION RENAMEFILE))))) (FB.COPY/RENAME.COMMAND (LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN)))))))))) (FB.COPY/RENAME.ONE (LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \;  "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD '|Rename|) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) 'BOTH) (T 'TOTAL)))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \;  "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE 'TOTAL)))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME))))))) (FB.COPY/RENAME.MANY (LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted") ) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST) (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'DEVICE)) (OR (LISTGET FIELDS 'NAME) (LISTGET FIELDS 'EXTENSION) (LISTGET FIELDS 'VERSION))) (* \;  "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) 'HOST)) (SETQ DIR (OR (LISTGET FIELDS 'DIRECTORY) (LISTGET FIELDS 'RELATIVEDIRECTORY))) (SETQ DEVICE (LISTGET FIELDS 'DEVICE)) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM))) ) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER 'Y) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay") ) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION) ))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING 'HOST HOST 'DEVICE DEVICE 'DIRECTORY (|if| (NOT RETAIN) |then| DIR |else| (* \;  "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) 'VERSION NIL 'BODY OLDNAME) CMD MOVEFN))))))) (FB.MERGE.DIRECTORIES (LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL))))) (FB.GREATEST.PREFIX (LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL)))))))) (FB.MAYBE.INSERT.FILE (LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \;  "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;|  "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER) ))) (* |;;|  "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;|  "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \;  "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM))) ) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME 'VERSION NIL 'TENEX))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION 'CREATIONDATE (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)) )) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME 'ICREATIONDATE)) (= CRDATE2 CRDATE))) |then| (* \;  "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \;  "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING 'BODY NEWNAME 'EXTENSION "" 'VERSION VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \;  "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \;  "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD '|Rename|)) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD '|Rename|) (|fetch| TISELECTED |of| OLDITEM)) (* \;  "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T))))) (FB.GET.NEW.FILE.SPEC (LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING 'DIRECTORY (OR (|fetch| (  FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) 'VERSION NIL 'BODY OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) 'NAME))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING 'DIRECTORY NEWNAME 'VERSION NIL 'BODY OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS 'EXTENSION))) (EQ (NCHARS NAMEFIELD) 0))) (* \;  "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these") ) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) 'HOST) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME)))))))) (FB.CANONICAL.DIRECTORY (LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER 'FILEBROWSER))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \;  "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL 'ASK)) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) 'Y) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW 'PROCESS NIL))))) ) (DEFINEQ (FB.HARDCOPYCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \;  "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST 'SERVER PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS))))))) (FB.HARDCOPY.TOFILE (LAMBDA (BROWSER FILES) (* \;  "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING 'NAME '* 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ))) (T (PACKFILENAME.STRING 'VERSION NIL 'EXTENSION (  \\FB.HARDCOPY.TOFILE.EXTENSION ) 'BODY (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS '* (CADR TAIL))) (|if| (NEQ (CAR TAIL) 'NAME) |then| (RETURN (SETQ MSG "Only name portion can contain *") )) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files" ))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \;  "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS 'DIRECTORY NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE 'EXTENSION))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC 'EXTENSION (CDR TYPE)))) |do| (* \;  "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE 'CONVERSION)) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) 'TEXT)) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL 'TENEX)) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS 'NAME) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) 'VERSION NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE))))))) ) (DEFINEQ (FB.EDITCOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 27-Feb-2021 19:07 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (IF (DIRECTORYNAMEP FILE) THEN (FB.BROWSECOMMAND BROWSER) ELSEIF (GETD 'OPENTEXTSTREAM) THEN (FB.EDITCOMMAND.ONEFILE BROWSER FILE OPTION ITEM MENU) ELSE (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU))))) (FB.EDITCOMMAND.ONEFILE (LAMBDA (BROWSER FILE OPTION ITEM MENU) (* \; "Edited 27-Feb-2021 20:07 by rmk:") (* \; "Edited 1-Feb-88 19:00 by bvm:") (* |;;| "Called when we know that FILE is a file, not a directory, and that TEDIT exists. If OPTION is READONLY, we don't want to edit, just view. If FILE is a lisp sourcefile, we execute the font changes by COPY.TEXT.TO.IMAGE.") (* |;;| "We clear the shade stuff here because we don't want the FB to come up on top of our see/edit region. We don't factor it to the top because we want to do whatever heavy lifting (copying files) before. Don't factor to the end because then it is too late--the TEDIT window was up and then buried. (If TEDIT had a don'topen option, we could set things up, then change the shade, then open. We could also do the manufactured title on the window before it shows.") (CL:UNLESS OPTION (SETQ OPTION FB.DEFAULT.EDITOR)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (IF (LISPSOURCEFILEP FILE) THEN (SELECTQ OPTION ((LISP NIL TEDIT) (* |;;| "Asks to load prop and edits the coms. We really don't want to use a text editor on a source file.") (* |;;| "The FUNCALL at the bottom is concerning.") (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMUNSELECTEDSHADE)) (FB.EDITLISPFILE FILE BROWSER)) (READONLY (* \; "READONLY on call from SEE") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STREAM NSTR) (* |;;| "Unshade the item before we create the TEDIT window, and tell FB.FINISH.COMMAND that we did that. That way, the FB window won't pop up on top.") (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMUNSELECTEDSHADE )) (WINDOWPROP (WFROMDS (TEXTSTREAM (TEDIT NSTR NIL NIL '(READONLY T)))) 'TITLE (CONCAT "SEE window for " (FULLNAME STREAM)))))) (CL:FUNCALL OPTION (MKATOM FILE))) ELSE (SELECTQ OPTION (READONLY (* |;;| "From SEE command. We want to be able to scroll around in the content, can't do that if it isn't random access. So in that case we do a secret NODIRCORE copy and look at that.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((NSTR)) (CL:UNLESS (RANDACCESSP STREAM) (SETQ NSTR (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW NIL (LIST (LIST 'TYPE (GETFILEINFO STREAM 'TYPE))))) (COPYBYTES STREAM NSTR)) (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMUNSELECTEDSHADE)) (WINDOWPROP (WFROMDS (TEXTSTREAM (TEDIT (OR NSTR STREAM) NIL NIL '(READONLY T)))) 'TITLE (CONCAT "SEE window for " (FULLNAME STREAM)))))) ((TEDIT NIL) (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE) (PUTMENUPROP MENU 'ITEMSHADE (CONS ITEM FB.ITEMUNSELECTEDSHADE)) (TEDIT (MKATOM FILE))) (LISP (FB.PROMPTW.FORMAT BROWSER "Failed because not a Lisp source file")) (CL:FUNCALL OPTION (MKATOM FILE))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) (FB.EDITLISPFILE (LAMBDA (FILE BROWSER) (* \; "Edited 21-Feb-2021 17:29 by rmk:") (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) 'FILEDATES)) FILE)) (NOT (GET ROOT 'FILE)) (NOT (BOUNDP (FILECOMS ROOT)))) (FB.PROMPTW.FORMAT BROWSER "The file ~A is not loaded or is not current." FILE) (COND ((MOUSECONFIRM (CONCAT "(LOAD '" FILE " 'PROP)? ") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL `(LOAD ',FILE 'PROP))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT '(FILES :DONTWAIT)))))) (FB.BROWSECOMMAND (LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 20-Feb-2021 20:10 by rmk:") (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ NAME (FB.FETCHFILENAME FILE)) (|if| (OR (FB.DIRECTORYP FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL 'TENEX)) (NAMETAIL (MEMB 'NAME FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) 'VERSION) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \;  "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \;  "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS 'DIRECTORY)) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS 'DIRECTORY (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS 'HOST) 'OSTYPE) 'UNIX) |then| (* \;  "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS `(,(FUNCTION FILEBROWSER) ',NAME ',(MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)) ,@(AND DEPTH `('(:DEPTH ,DEPTH))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME))))) ) (DEFINEQ (FB.FASTSEECOMMAND (LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'NAME) (UNPACKFILENAME (FB.FETCHFILENAME FILE) 'EXTENSION)))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW 'PAGEFULLFN (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'INUSE NIL) (DEL.PROCESS (WINDOWPROP W 'PROCESS)))))) ) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW 'PROCESS NIL) (* \;  "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW 'MORETYPE)))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \;  "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \;  "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL))))))) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \; "Edited 21-Feb-2021 14:46 by rmk:") (* \; "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((DIRECTORYNAMEP FILE) (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER)) (T (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS)))))))))) (FB.SEEFULLFN (LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW 'MORETYPE))))) (EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS '(("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one" ) ("Abort" ABORT "Abort viewing of this and any further files" ))) (FINISHEDMOREBUTTONS '((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files" ))) '((" More " MORE "View another screenfull of the file" ) (" Abort " ABORT "Abort view; allow this window to be re-used" ))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH ) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW 'MOREEVENT (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW 'TITLE)))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS 'REGION)) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW 'REGION))) 'TOP) (T 'BOTTOM)) 'LEFT) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW 'MOREOK NIL))))) (FB.SEEBUTTONFN (LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \;  "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW 'MOREOK T) (NOTIFY.EVENT (WINDOWPROP WINDOW 'MOREEVENT))) (NEXT (* \;  "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW 'PROCESS) '(CL:THROW :NEXT))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW 'PROCESS))) (SHOULDNT))))) ) (DEFINEQ (FB.LOADCOMMAND (LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) 'NAME 'LOAD 'BEFOREEXIT 'DON\'T))))) (FB.COMPILECOMMAND (LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) 'NAME 'COMPILE 'BEFOREEXIT 'DON\'T))))) (FB.OPERATE.ON.FILES (LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN 'LOAD)) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| `(,FN ',(FB.FETCHFILENAME FILEENTRY) ,@(AND LDFLG `(',LDFLG))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS 'PROGN FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM))))) ) (DEFINEQ (FB.UPDATECOMMAND (LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER '|Recompute|) (FB.UPDATEBROWSERITEMS BROWSER))))) (FB.MAYBE.EXPUNGE (LAMBDA (BROWSER COMMAND) (* \; "Edited 22-Feb-2021 12:33 by rmk:") (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL))))) (FB.UPDATEBROWSERITEMS (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \;  "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \;  "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \;  "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION 'SIZE INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION 'LENGTH INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) ) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \;  "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN 'DIRECTORY)))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS 'SUBTREE.SIZE)) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS '(SORT RESETLST))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \;  "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \;  "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME ) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER 'CLEAR "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER '|done|) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.DATE (LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;|  "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9))))) (FB.ADJUST.DATE.WIDTH (LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) 'DATE) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM))) ) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \;  "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT)))) (FB.SET.BROWSER.TITLE (LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) 'TITLE (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser"))))))) (FB.MAYBE.WIDEN.NAMES (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \;  "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES ) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \;  "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T))))))) (FB.SET.DEFAULT.NAME.WIDTH (LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL)))) (FB.CREATE.FILEBUCKET (LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \;  "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR ))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \;  "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \;  "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \;  "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER )) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \;  "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA))) (FB.CHECK.NAME.LENGTH (LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \;  "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN)))))))))) (FB.ADD.FILEGROUP (LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA))))(* \;  "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \;  "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA)))))) (FB.INSERT.DIRECTORY (LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM))) (FB.MAKE.SUBDIRECTORY.ITEM (LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER) )))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T))))) (FB.ADD.FILE (LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM)))) (FB.INSERT.FILE (LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already") ) (T (* |;;|  "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \;  "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \;  "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE 'ADD)))) (FB.ANALYZE.PATTERN (LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \;  "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \;  "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \;  "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))) )) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \;  "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN))) (FB.GETALLFILEINFO (LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) '(SIZE LENGTH)) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR 'SUBTREE.SIZE))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE)))) ) (DEFINEQ (FB.SORT.VERSIONS (LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \;  "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME ) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \;  "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS))) (FB.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y))))) (FB.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y))))) (FB.NAMES.DECREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL))) (FB.NAMES.INCREASING.VERSION (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL))) (FB.DECREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.INCREASING.NUMERIC.ATTR (LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y)))))) (FB.ALPHABETIC.ATTR (LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL))) ) (DEFINEQ (FB.SORTCOMMAND (LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \;  "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \;  "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \;  "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME ) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA))) ) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \;  "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done")))) (FB.INSERT.SUBDIRECTORIES (LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \;  "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL))))) (FB.GET.SORT.MENU (LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS '("Name" 'NAME "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" 'NAME "Sort files by name, decreasing version numbers") ("Increasing version" '(NAME T) "Sort files by name, increasing version numbers"))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER ) |collect| `(,(SETQ ATTR (CAR ATTR)) ',ATTR "Sort by this attribute" ,(SELECTQ ATTR ((SIZE LENGTH BYTESIZE) `(SUBITEMS ("Decreasing" ',ATTR "Sort files in order of decreasing size" ) ("Increasing" '(,ATTR T) "Sort files in order of increasing size"))) ((CREATIONDATE WRITEDATE READDATE) `(SUBITEMS ("Newer first" ',ATTR "Sort files with newer dates appearing before older dates" ) ("Older first" '(,ATTR T) "Sort files with older dates appearing before newer dates" ))) NIL))))))))) ) (DEFINEQ (FB.EXPUNGECOMMAND (LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 22-Feb-2021 12:36 by rmk:") (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER 'DELETED)) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER 'BOTH)) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;|  "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " No") (T (CONCAT (COND (FAILED " Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T)))) (FB.NEWPATTERNCOMMAND (LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER)))))) (FB.NEWINFOCOMMAND (LAMBDA (BROWSER) (* \; "Edited 22-Feb-2021 12:35 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW 'BOTTOM 'JUSTIFY 'LOCALCLOSE) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW 'REGION))) 0) (* \;  "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW 'CLOSEFN (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) 'FILEBROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER 'CLEAR "Select from the lower menu which attributes are to be displayed, then click Recompute")))) (FB.DEPTHCOMMAND (LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL ) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH))))) (FB.SHAPECOMMAND (LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW 'EXTENT)) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW 'WIDTH))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW 'HEIGHT) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER )))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW 'REGION)) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) 'REGION))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \;  "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT)))))) (FB.REMOVE.FILE (LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \;  "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM 'REMOVE)))) (FB.COUNT.FILE.CHANGE (LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE)))))))) (FB.SETNEWPATTERN (LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| ( DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN 'HOST))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) 'ICONWINDOW)) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN))) (FB.GET.NEWPATTERN (LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN)))))) (FB.OPTIONSCOMMAND (LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire."))) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS (LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW 'MENU))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW))))) (FB.INFO.ITEM.NAMED (LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM)))) ) (DEFINEQ (FB.MAKECOUNTERWINDOW (LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 22-Feb-2021 12:41 by rmk:") (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW 'TOP) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW 'FILEBROWSER) |with| COUNTERW) (WINDOWPROP COUNTERW 'REPAINTFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'RESHAPEFN (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW 'PAGEFULLFN (FUNCTION NILL)) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP COUNTERW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) COUNTERW))) (FB.COUNTERW.REDISPLAYFN (LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) 'FILEBROWSER))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \;  "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER))))) (FB.UPDATE.COUNTERS (LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE 'DELETED) (* \;  "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE 'TOTAL) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT 'REPLACE))))) (FB.DISPLAY.COUNTERS (LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW 'WIDTH)) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW 'HEIGHT)) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)) )) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \;  "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT 'REPLACE) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING) ))) (FB.COUNTER.STRING (LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES))))) ) (DEFINEQ (FB.MAKEHEADINGWINDOW (LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Feb-2021 12:29 by rmk:") (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW 'TOP) (WINDOWPROP HEADINGW 'PASSTOMAINCOMS T) (* \;  "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW 'REPAINTFN (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW 'RESHAPEFN (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \;  "This is a white on black window") (DSPOPERATION 'INVERT HEADINGW) (DSPFILL NIL BLACKSHADE 'REPLACE HEADINGW) (* \;  "Set up for modernized window moving/shaping") (WINDOWPROP HEADINGW 'BUTTONEVENTFN (FUNCTION TOTOPW.MODERNIZE)) (WINDOWPROP BROWSERWINDOW 'TOPMARGIN 0) HEADINGW))) (FB.HEADINGW.REDISPLAYFN (LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER) WINDOW))) (FB.HEADINGW.RESHAPEFN (LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'FILEBROWSER))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW)))) (FB.HEADINGW.DISPLAY (LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW 'DSP)) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) 'BORDER)) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE 'REPLACE STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \;  "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \;  "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC)))))) ) (DEFINEQ (FB.ICONFN (LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW 'FILEBROWSER)) FB.ICONFONT POSITION NIL NIL 'FILE)))) (FB.INFOMENU.WHENSELECTEDFN (LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (BROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN)))) (FB.CLOSEFN (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) 'DON\'T) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER 'DELETED) 0) (* \;  "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \;  "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) 'DON\'T)))))) (FB.EXPUNGE?.MENU (LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT))))) (FB.AFTERCLOSEFN (LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL)))) (FB.CLOSE&EXPUNGE (LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W 'MENU))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC '|Expunge| (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG))))))) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY (LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW 'FILEBROWSER)) (TBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER)) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \;  "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \;  "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \;  "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER ))) (STREAMPROP IMAGESTREAM 'PRINTOPTIONS (LIST* 'DOCUMENT.NAME TITLE (STREAMPROP IMAGESTREAM 'PRINTOPTIONS))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW ) |of| FBROWSER) 'TITLE)) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES ) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) 'DATE) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \;  "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \;  "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \;  "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM) ) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \;  "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \;  "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \;  "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM))))) (FB.HARDCOPY.PRINT.TITLE (LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T))) (FB.HARDCOPY.MAXWIDTH (LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;|  "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \;  "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001 2021)) (DECLARE\: DONTCOPY (FILEMAP (NIL (28186 50822 (FB 28196 . 29152) (FB.COPYBINARYCOMMAND 29154 . 29500) (FB.COPYTEXTCOMMAND 29502 . 29844) (FILEBROWSER 29846 . 42952) (FB.TABLEBROWSER 42954 . 43171) (FB.SELECTEDFILES 43173 . 43810) (FB.FETCHFILENAME 43812 . 44204) (FB.DIRECTORYP 44206 . 44534) (FB.PROMPTWPRINT 44536 . 45582) (FB.PROMPTW.FORMAT 45584 . 46321) (FB.PROMPTFORINPUT 46323 . 48575) (FB.YES-OR-NO-P 48577 . 49611) ( FB.ALLOW.ABORT 49613 . 50467) (\\FB.HARDCOPY.TOFILE.EXTENSION 50469 . 50820)) (50846 51799 (FB.STARTUP 50856 . 51371) (FB.MAKERIGIDWINDOW 51373 . 51797)) (51800 57172 (FB.PRINTFN 51810 . 56963) (FB.COPYFN 56965 . 57170)) (57222 63264 (FB.MENU.WHENSELECTEDFN 57232 . 57590) (FB.COMMANDSELECTEDFN 57592 . 59131) (FB.SUBITEMP 59133 . 59568) (FB.MAKE.BROWSER.BUSY 59570 . 60308) (FB.FINISH.COMMAND 60310 . 62275) (FB.HANDLE.ABORT.BUTTON 62277 . 63262)) (63265 68781 (FB.DELETECOMMAND 63275 . 63556) ( FB.DELVERCOMMAND 63558 . 66751) (FB.IS.NOT.SUBDIRECTORY.ITEM 66753 . 66934) (FB.DELVER.FILES 66936 . 68025) (FB.DELETE.FILE 68027 . 68779)) (68782 70107 (FB.UNDELETECOMMAND 68792 . 69077) ( FB.UNDELETEALLCOMMAND 69079 . 69358) (FB.UNDELETE.FILE 69360 . 70105)) (70108 94289 (FB.COPYCOMMAND 70118 . 70387) (FB.RENAMECOMMAND 70389 . 70664) (FB.COPY/RENAME.COMMAND 70666 . 71589) ( FB.COPY/RENAME.ONE 71591 . 73913) (FB.COPY/RENAME.MANY 73915 . 80135) (FB.MERGE.DIRECTORIES 80137 . 80555) (FB.GREATEST.PREFIX 80557 . 81913) (FB.MAYBE.INSERT.FILE 81915 . 89355) (FB.GET.NEW.FILE.SPEC 89357 . 93188) (FB.CANONICAL.DIRECTORY 93190 . 94287)) (94290 102074 (FB.HARDCOPYCOMMAND 94300 . 95430 ) (FB.HARDCOPY.TOFILE 95432 . 102072)) (102075 113638 (FB.EDITCOMMAND 102085 . 102886) ( FB.EDITCOMMAND.ONEFILE 102888 . 107854) (FB.EDITLISPFILE 107856 . 108895) (FB.BROWSECOMMAND 108897 . 113636)) (113639 125432 (FB.FASTSEECOMMAND 113649 . 117099) (FB.FASTSEE.ONEFILE 117101 . 120130) ( FB.SEEFULLFN 120132 . 124263) (FB.SEEBUTTONFN 124265 . 125430)) (125433 127179 (FB.LOADCOMMAND 125443 . 125950) (FB.COMPILECOMMAND 125952 . 126490) (FB.OPERATE.ON.FILES 126492 . 127177)) (127180 174229 ( FB.UPDATECOMMAND 127190 . 127415) (FB.MAYBE.EXPUNGE 127417 . 128412) (FB.UPDATEBROWSERITEMS 128414 . 141629) (FB.DATE 141631 . 142372) (FB.ADJUST.DATE.WIDTH 142374 . 145342) (FB.SET.BROWSER.TITLE 145344 . 146201) (FB.MAYBE.WIDEN.NAMES 146203 . 148322) (FB.SET.DEFAULT.NAME.WIDTH 148324 . 149688) ( FB.CREATE.FILEBUCKET 149690 . 156910) (FB.CHECK.NAME.LENGTH 156912 . 159333) (FB.ADD.FILEGROUP 159335 . 160862) (FB.INSERT.DIRECTORY 160864 . 161102) (FB.MAKE.SUBDIRECTORY.ITEM 161104 . 162513) ( FB.ADD.FILE 162515 . 163128) (FB.INSERT.FILE 163130 . 166542) (FB.ANALYZE.PATTERN 166544 . 171808) ( FB.CANONICALIZE.PATTERN 171810 . 173122) (FB.GETALLFILEINFO 173124 . 174227)) (174230 182389 ( FB.SORT.VERSIONS 174240 . 177011) (FB.DECREASING.VERSION 177013 . 177682) (FB.INCREASING.VERSION 177684 . 178305) (FB.NAMES.DECREASING.VERSION 178307 . 179342) (FB.NAMES.INCREASING.VERSION 179344 . 180341) (FB.DECREASING.NUMERIC.ATTR 180343 . 181023) (FB.INCREASING.NUMERIC.ATTR 181025 . 181699) ( FB.ALPHABETIC.ATTR 181701 . 182387)) (182390 192232 (FB.SORTCOMMAND 182400 . 189230) ( FB.INSERT.SUBDIRECTORIES 189232 . 190029) (FB.GET.SORT.MENU 190031 . 192230)) (192233 208322 ( FB.EXPUNGECOMMAND 192243 . 194762) (FB.NEWPATTERNCOMMAND 194764 . 195162) (FB.NEWINFOCOMMAND 195164 . 197930) (FB.DEPTHCOMMAND 197932 . 199707) (FB.SHAPECOMMAND 199709 . 203051) (FB.REMOVE.FILE 203053 . 204874) (FB.COUNT.FILE.CHANGE 204876 . 206321) (FB.SETNEWPATTERN 206323 . 207493) (FB.GET.NEWPATTERN 207495 . 208079) (FB.OPTIONSCOMMAND 208081 . 208320)) (208357 209369 ( FB.INFOMENU.SHADEINITIALSELECTIONS 208367 . 209014) (FB.INFO.ITEM.NAMED 209016 . 209367)) (209370 218836 (FB.MAKECOUNTERWINDOW 209380 . 210842) (FB.COUNTERW.REDISPLAYFN 210844 . 211431) ( FB.UPDATE.COUNTERS 211433 . 213505) (FB.DISPLAY.COUNTERS 213507 . 218567) (FB.COUNTER.STRING 218569 . 218834)) (218837 223480 (FB.MAKEHEADINGWINDOW 218847 . 220395) (FB.HEADINGW.REDISPLAYFN 220397 . 220663) (FB.HEADINGW.RESHAPEFN 220665 . 221041) (FB.HEADINGW.DISPLAY 221043 . 223478)) (223481 227664 (FB.ICONFN 223491 . 223838) (FB.INFOMENU.WHENSELECTEDFN 223840 . 224570) (FB.CLOSEFN 224572 . 225775) (FB.EXPUNGE?.MENU 225777 . 226189) (FB.AFTERCLOSEFN 226191 . 226552) (FB.CLOSE&EXPUNGE 226554 . 227662 )) (227665 239723 (FB.HARDCOPY.DIRECTORY 227675 . 238032) (FB.HARDCOPY.PRINT.TITLE 238034 . 238360) ( FB.HARDCOPY.MAXWIDTH 238362 . 239721))))) STOP \ No newline at end of file diff --git a/library/FILEBROWSER.LCOM b/library/FILEBROWSER.LCOM index 78f5bd47a0cad4d67f89915fe0964682a49402ef..444d474dd812a397f6e4f2191bfaf630629b84d6 100644 GIT binary patch delta 2221 zcmb7F&u<$=6y9}`s%g_UNkfykEj(PLCQVazW_H)R2B}`#>v*Z{b?gmWXhM?4rHQDT z(gM8%<%HnCk5(h~hv3vo9JtUnr4m0aapMMm0Jn-0ho0aFZ)WY-5s?5N*0XQle)IPG zzW3%M-gEb}o@<5u$;te=vy)V#1gMtMtQ0k`p9y1(U4M99HTfYmZkZh^B&C}vW+%q? zjOD$eo2|M|;N~Dfx542T)u~;KtpPO&qZ)6hlY@}YoXC4+uU0sb^-CqEoV)q`kUDC) zIWK4i#$oN!<#X?>tiF9^4c6+5Z=Fl6!JY&)+GP-yqI$~E62RY7r#2R1KO8-KN>P>W z^bQ4oKUvw8-D2@Dbzc0Xoy>9^f6MiFyb@nhoCnW3nFaAgW;HT0%aM_|46XDlV@U#) znV{sBXDU^{0tV%C$Bx8IQnt-*x&_jsa9}uF6c=aI%$_x#2L^tJO%%E@p0pD{GZxq*`{gkCx4hoDpND{eWgpt{7=`QGCrT?D@y{|5*& zJHD4NO+@<%>5L{V4375NAV>ovxuG3@?|F5aKRPp+PDlnME1#ylTqe7xN09IVYLo2~ zt41Mq`reO7JCh!9YC+9)o0b5RZNO}|x-P#q4=mat4>~xSX4&JQTvEFgb*BItP?hO| zq_t74Er>`&V@+02m61s0Mq#X&jgFbxRY(?Ko3J}QB! z;T<*t=n`ntdbFi=7mCd<&yDwuCGkZsD5CSE5c`Njpf2?8j43PWfkan$C>A~)A5go)$a{D0E4RX-y7cIiFY33Ns|TzR9tcOIyCc7c zBQhsEAY)C(hl62U+WEfn2S2%Zvj0&y^i31_jhF5#pYx9wbJ}7P^iF-l_%E>h*TvyX zTy~5E|1cc-wgq}>uWXqmkkw$zFdQ?REyK{brBhDemw-`z>64)f!;Xr&fZEB{Giupe z6r`rrmJld2AX`jji+;@oinDJMo)VM8?C^_7t472{$5SqvazGHHxi!H_xCua*)dnDp z34rxY01AZIa!dm1jHj7sSnU3aI1T}Q(|KlKL$`-68dc=g{F!Rj71?6UGTnw$*{_zI zA~4OC89*&L1BF*+$~6~{S$_C7fK7~S3cC9s8E>TatR7pd7CFIAm6>sZbEvw9-A}Xcz4^X3 zZ@yU@`jQNNRi4nYrR91S%NPMtEUa3Zy!uWoVPo~-6;UBmVlt=nAs91=YR;s`QYE+I z6snFLIYpSk|Di+P6;F*~qXSsWsisM~V)jHDIxE+gKWtz7;JprXnwQ^SwmOuJ`&%Gv zsmRhy#+Ik^vTo3Y-*Z!zlU{tZ{98PZg0_H3j5enw=A98_(ez=^4*`u#EAi22J-KPNpkhV z-@Yx&x|#+dBT9le!qDTQaHc%k0DuNS#nrSX}hZR@_Ti%+ zbtD-~dhSl+u%zo$-6JcGb%w;Lbt%U6TA=2W2s2$M}~ zT0#nWVnG?H9HgW{Ozat!g!cUS%s_ldij&E4aWL*p{r&Yg(c~Wg^KJ9)cD2@x55$w) zsZHSt`L%g+|7x80X`6EO?M>k(Ni7#Yd2<`T-u#X-xQqO?akQtn7Ef}Qxzg=8@n}ck z^h+GqnBq8UIi>^lJ=b#JowlRE1FRZQ%Fl(>zzd^zt`t-~n;r_**{Nh)R-zp&GIc0a ztU@KIIe>DwFNh3-czmXoTryf+o4hsHq%=Q7<8>iHRRn)dK+F4Re5`JrPna+lA4Rj aXDx4-S`vaxqw^{mY9A8^wleK!e>?}wz%+&c From 2f1b68ea4f4ec27736586f4b7ee29c63d30be3a4 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sat, 27 Feb 2021 22:01:14 -0800 Subject: [PATCH 31/31] MODERNIZE: More work on attached windows, LOADUP-FULL with MODERNIZE replacing MACINTERFACE --- lispusers/MODERNIZE | 2 +- lispusers/MODERNIZE.LCOM | Bin 7748 -> 7761 bytes sources/LOADUP-FULL | 2 +- sources/LOADUP-FULL.LCOM | Bin 5728 -> 5778 bytes 4 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lispusers/MODERNIZE b/lispusers/MODERNIZE index 37ff459a..89ee43a4 100644 --- a/lispusers/MODERNIZE +++ b/lispusers/MODERNIZE @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 16:47:48"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;8 20161 changes to%: (VARS MODERNIZECOMS) (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP MODERNWINDOW.BUTTONEVENTFN MODERN-ADD-EXEC MODERN-SNAPW TEDIT.MODERNIZE TOTOPW.MODERNIZE MODERNWINDOW.BUTTONEVENTFN.ANYWHERE MACWINDOW.BUTTONEVENTFN.ANYWHERE MACINT-ADD-EXEC TEDIT.MACINTERFACE TOTOPW.MACINTERFACE MACWINDOW.BUTTONEVENTFN INCORNER.REGION) previous date%: "22-Feb-2021 13:55:51" {DSK}kaplan>lisp>MACINTERFACE.;2) (PRETTYCOMPRINT MODERNIZECOMS) (RPAQQ MODERNIZECOMS [ (* ;; "Externals") (COMS (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP) (INITVARS (MODERN-WINDOW-MARGIN 25))) (* ;; "Internals") [COMS (FNS MODERNWINDOW.BUTTONEVENTFN MODERNWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE) (* ;; "Add some Meta commands") (FNS TEDIT.MODERNIZE TEDIT.SELECTALL) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MODERNIZE) (* ;; "Inspector") (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MODERNWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW) (* ;; "New execs") (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC) (* ;; "Existing exec of the load") (MODERNWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MODERNWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MODERN-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MODERNWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MODERNWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MODERNWINDOW.BUTTONEVENTFN)))) WINDOW]) (MODERNWINDOW.SETUP [LAMBDA (ORIGFN MODERNWINDOWFN ANYWHERE) (* ; "Edited 22-Feb-2021 16:42 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MODERNORIG-.") (* ;; "If MODERNWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into modern window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MODERNWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MODERNWINDOWFN THEN (MOVD MODERNWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MODERNWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMODERNWINDOW [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN NIL)) WINDOW]) (MODERNWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 22-Feb-2021 16:45 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MODERN-WINDOW-MARGIN 25) (* ;; "Internals") (DEFINEQ (MODERNWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MODERN-WINDOW-MARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW WINDOW STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MODERNWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 22-Feb-2021 16:27 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MODERN-WINDOW-MARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH BOTTOM OF MAINREGION))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MODERN-WINDOW-MARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH BOTTOM OF MAINREGION))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MODERN-ADD-EXEC [LAMBDA U (* ; "Edited 22-Feb-2021 16:41 by rmk:") (LET [(PROC (APPLY (FUNCTION MODERN-ORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MODERNWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MODERN-SNAPW [LAMBDA NIL (* ; "Edited 22-Feb-2021 16:41 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MODERN-ORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) (TOTOPW.MODERNIZE [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MODERNWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (* ;; "Add some Meta commands") (DEFINEQ (TEDIT.MODERNIZE [LAMBDA NIL (* ; "Edited 22-Feb-2021 16:28 by rmk:") (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN) (MODERNWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE))]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MODERNIZE) (* ;; "Inspector") (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MODERNWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW) (* ;; "New execs") (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC) (* ;; "Existing exec of the load") (MODERNWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MODERNWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MODERN-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4575 8401 (MODERNWINDOW 4585 . 5243) (MODERNWINDOW.SETUP 5245 . 7189) (UNMODERNWINDOW 7191 . 7585) (MODERNWINDOW.UNSETUP 7587 . 8399)) (8466 16070 (MODERNWINDOW.BUTTONEVENTFN 8476 . 13078) (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE 13080 . 13451) (NEARTOP 13453 . 13889) (NEARESTCORNER 13891 . 14770) (INCORNER.REGION 14772 . 16068)) (16128 17546 (MODERN-ADD-EXEC 16138 . 16569) (MODERN-SNAPW 16571 . 17114) (TOTOPW.MODERNIZE 17116 . 17544)) (17587 18670 (TEDIT.MODERNIZE 17597 . 18339) ( TEDIT.SELECTALL 18341 . 18668))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "27-Feb-2021 18:14:36"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;11 20163 changes to%: (FNS MODERNWINDOW.BUTTONEVENTFN) previous date%: "26-Feb-2021 21:20:15" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;10) (PRETTYCOMPRINT MODERNIZECOMS) (RPAQQ MODERNIZECOMS [ (* ;; "Externals") (COMS (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP) (INITVARS (MODERN-WINDOW-MARGIN 25))) (* ;; "Internals") [COMS (FNS MODERNWINDOW.BUTTONEVENTFN MODERNWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER INCORNER.REGION) (* ;; "Behavior for some known window creators") (FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE) (* ;; "Add some Meta commands") (FNS TEDIT.MODERNIZE TEDIT.SELECTALL) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MODERNIZE) (* ;; "Inspector") (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MODERNWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW) (* ;; "New execs") (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC) (* ;; "Existing exec of the load") (MODERNWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MODERNWINDOW PROMPTWINDOW T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MODERN-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MODERNWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MODERNWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MODERNWINDOW.BUTTONEVENTFN)))) WINDOW]) (MODERNWINDOW.SETUP [LAMBDA (ORIGFN MODERNWINDOWFN ANYWHERE) (* ; "Edited 22-Feb-2021 16:42 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MODERNORIG-.") (* ;; "If MODERNWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into modern window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MODERNWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MODERNWINDOWFN THEN (MOVD MODERNWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MODERNWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (UNMODERNWINDOW [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:44 by rmk:") (* ;; "Restores original window behavior") (CL:WHEN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)) (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN NIL)) WINDOW]) (MODERNWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 22-Feb-2021 16:45 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MODERN-WINDOW-MARGIN 25) (* ;; "Internals") (DEFINEQ (MODERNWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 27-Feb-2021 17:57 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION)) (ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW] (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.") (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ") (SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN) ELSEIF (WINDOWPROP WINDOW 'TITLE) THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT) ELSE MODERN-WINDOW-MARGIN)) (SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN)) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test corners before titlebar.") (* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.") (* ;; "WINDOWREGION includes the attached windows") (LET ((LEFT (FETCH LEFT OF ATTACHEDREGION)) (RIGHT (FETCH RIGHT OF ATTACHEDREGION)) (TOP (FETCH TOP OF ATTACHEDREGION)) (BOTTOM (FETCH BOTTOM OF ATTACHEDREGION)) STARTINGREGION) (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.") (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN)) [SETQ STARTINGREGION (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM) (GETMOUSESTATE) (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM) (GETMOUSESTATE) (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (\CURSORPOSITION RIGHT TOP) (GETMOUSESTATE) (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (\CURSORPOSITION LEFT TOP) (GETMOUSESTATE) (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT]) (SHAPEW (CL:IF (MEMB 'SHAPEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS)) (WINDOWPROP WINDOW 'MAINWINDOW) WINDOW) STARTINGREGION)) T ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN)) THEN (NEARESTCORNER ATTACHEDREGION) (MOVEW (CL:IF (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS)) (WINDOWPROP WINDOW 'MAINWINDOW) WINDOW)) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:") (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MODERNWINDOW.BUTTONEVENTFN WINDOW NIL T]) (NEARTOP [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:") (* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)") (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION) TOPMARGIN]) (NEARESTCORNER [LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:") (* ;; "Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY") (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION)) (IDIFFERENCE (FETCH RIGHT OF REGION) LASTMOUSEX)) (FETCH LEFT OF REGION) (FETCH RIGHT OF REGION)) (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION)) (IDIFFERENCE (FETCH TOP OF REGION) LASTMOUSEY)) (FETCH BOTTOM OF REGION) (FETCH TOP OF REGION))]) (INCORNER.REGION [LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 22-Feb-2021 16:27 by rmk:") (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.") (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ") (IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION))) MODERN-WINDOW-MARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'LEFTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH BOTTOM OF MAINREGION))) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION))) MODERN-WINDOW-MARGIN) THEN (IF (NEARTOP MAINREGION TOPMARGIN) THEN 'RIGHTTOP ELSEIF (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH BOTTOM OF MAINREGION))) THEN 'RIGHTBOTTOM]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MODERN-ADD-EXEC [LAMBDA U (* ; "Edited 22-Feb-2021 16:41 by rmk:") (LET [(PROC (APPLY (FUNCTION MODERN-ORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MODERNWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MODERN-SNAPW [LAMBDA NIL (* ; "Edited 22-Feb-2021 16:41 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MODERN-ORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) (TOTOPW.MODERNIZE [LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:") (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.") (TOTOPW WINDOW) (LET ((MAIN (MAINWINDOW WINDOW T))) (CL:WHEN MAIN (MODERNWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))]) ) (* ;; "Add some Meta commands") (DEFINEQ (TEDIT.MODERNIZE [LAMBDA NIL (* ; "Edited 22-Feb-2021 16:28 by rmk:") (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN) (MODERNWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE))]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MODERNIZE) (* ;; "Inspector") (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MODERNWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW) (* ;; "New execs") (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC) (* ;; "Existing exec of the load") (MODERNWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (* ;; "Table browser (for filebrowser)") (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN) (* ;; "Grapher") (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE) (* ;; "Promptwindow") (MODERNWINDOW PROMPTWINDOW T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MODERN-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4168 7994 (MODERNWINDOW 4178 . 4836) (MODERNWINDOW.SETUP 4838 . 6782) (UNMODERNWINDOW 6784 . 7178) (MODERNWINDOW.UNSETUP 7180 . 7992)) (8059 16072 (MODERNWINDOW.BUTTONEVENTFN 8069 . 13080) (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE 13082 . 13453) (NEARTOP 13455 . 13891) (NEARESTCORNER 13893 . 14772) (INCORNER.REGION 14774 . 16070)) (16130 17548 (MODERN-ADD-EXEC 16140 . 16571) (MODERN-SNAPW 16573 . 17116) (TOTOPW.MODERNIZE 17118 . 17546)) (17589 18672 (TEDIT.MODERNIZE 17599 . 18341) ( TEDIT.SELECTALL 18343 . 18670))))) STOP \ No newline at end of file diff --git a/lispusers/MODERNIZE.LCOM b/lispusers/MODERNIZE.LCOM index dd9ee7b19a9fe657b7ca48bee61fe80eb830cebd..189ea08d435d4f7fb0206ec8a8555e32f67313b3 100644 GIT binary patch delta 639 zcmah^Jx|+E6s;3Pl>}FjU_g}N5(xpSu>3yq{2_)I=ee3uldWufMmBb&LR+ zHlj9R!|qN2q2VV@EKNNeeqY>Xw;D~;YS8PR^n0Mz@NW%_Y|3n6)z;Ki&)?#1%$<}s zp@#pJaO5o_1XxFm!1EW~mxKN>oE$FOuo~VIDbDf7=+x3d6K$O9P$_lGbNKoZ6I|6l9toX{Dhj)PqKm1FB9g*Zz~U!WhYG? zx5b+sKWs*wm_PQT5b6kA9;UIgHKE05Mk`WkiSGURDWI6;;AyrPg~0K{i3o^kK-)=@ hG|EXg3X+UMH=iJs{Gr9{juz`T8w*u!j|b|v>MwI)k~jbW delta 620 zcmY*VO>fgc5RGG$G^UnBamFz~g6IVUe6gLS(NvH#t zil2Z)S#jh57tW|BPJqM(aX|0`;KZGufbFOy-NWpgw{PC;%#X&G#tVE^Dz}6CWvL=T z0IQl()0Fy&-)HJ4AH?irIvO1bK`TnjdPP&9rYgk}zuC6#A;U(xi%f7) zbY}XveY*~%3amnKF!U#bAO!R2O$}`Jb=v`ahnUF5)*doQ$0^aFpweT3&-So`++LS{ zXRgy%>xBX`Emu6(0++a?>-{GZ9bq}PqZ{;1c8x}OE5a6b%erZn(JnFoAAK@*NoZuZ zbpxFnEprPGVc)_Au`#km8{M@CE`ixm@N_hN5`qW*Jcvf%FHS6Ls;a552#!r>=UJl{ z21jA@kv|*zlje97&YH`e#VzS{FI~%M&vWS%yON5|$Ne~tvwy~y{=R+B93<((81A-m z@zWxH&9nw_#?fypays?larry>ilisp>medley>sources>LOADUP-FULL.;3 7916 changes to%: (VARS LOADUP-FULLCOMS) previous date%: " 6-Feb-2021 13:46:58" {DSK}larry>ilisp>medley>sources>LOADUP-FULL.;2) (PRETTYCOMPRINT LOADUP-FULLCOMS) (RPAQQ LOADUP-FULLCOMS ((COMMANDS "cd" "pwd" "ls") (FNS LOADFULLFONTS MAKEFULLSYSOUT FIXMETA) (P (FIXMETA)) (VARS (WRITEFULLSYSOUTFLAG T)) (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT))) (PROP FILETYPE))) (DEFCOMMAND "cd" (DIR) (/CNDIR DIR)) (DEFCOMMAND "pwd" NIL (DIRECTORYNAME T)) (DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST))) (DEFINEQ (LOADFULLFONTS [LAMBDA (ROOTDIRECTORY) (* ;  "Edited 11-Aug-2020 17:53 by rmk:") (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q") (PRINTOUT T "Loading FULL fonts..." T) (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts") (PACK* ROOTDIRECTORY "/fonts/altofonts"))) (* (SETQ INTERPRESSFONTDIRECTORIES  (CONS (PACK* ROOTDIRECTORY  "/fonts/ipfonts")))) (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE)) (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts"))) (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT) (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL) (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL)) (* ;  "Don't let the font loader substitute just because a server went catatonic on us") (for FAMILY in '(CLASSIC MODERN TERMINAL) do (PRINTOUT T " Loading " FAMILY " ") [for SIZE in '(8 10 12) do (PRINTOUT T SIZE " ") (for FACE in '(MRR BRR MIR) do (* ;; "No need for Interpress") (* (NLSETQ (FONTCREATE FAMILY SIZE  FACE NIL (QUOTE INTERPRESS) NIL 0))) (for CSET in '(0 33 34 35 238 239 241) do (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL 'DISPLAY NIL CSET] (PRINTOUT T T)) (PRINTOUT T " Loading postscript fonts" T) (for F in (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES) ">c0>*.*")) do (PSCFONT.READFONT F)) (PRINTOUT T "FULL fonts loaded" T]) (MAKEFULLSYSOUT [LAMBDA NIL (* ; "Edited 5-Dec-2020 20:07 by larry") (* ;  "Edited 14-May-2018 15:01 by kaplan") (* ;  "Edited 28-Sep-2020 12:35 by rmk:") (* ; "Edited 17-Apr-2018 08:41 by ") (* ;  "Edited 21-Apr-2018 07:27 by rmk:") (* ; "Edited 23-Feb-94 15:04 by bvm") (CLRPROMPT) (CNDIR (UNIX-GETENV "LOADUPDIR")) (LET ((ROOTDIRECTORY (MEDLEYDIR))) (SETQ MAKESYSFILENAME (CONCAT (MEDLEYDIR "loadups") "xfull35.sysout")) (DRIBBLE (PACKFILENAME 'EXTENSION 'DRIBBLE 'BODY MAKESYSFILENAME)) (* ;; "BKSYSBUF stops page holding ") (PRINTOUT T T "Full loadup started at " (DATE) " while connected to " (DIRECTORYNAME T) T T) (BKSYSBUF " ") (SETQ DEFAULTFILETYPE 'BINARY) (* ;  "These prevent bits from being lost due to lack of knowledge") (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST) DEFAULTFILETYPELIST) (* (SETQ *UPPER-CASE-FILE-NAMES* NIL)) (SETQ MAKESYSNAME :MEDLEY3.5) (push DEFAULTFILETYPELIST '(TXT . TEXT) '(TEXT . TEXT) '(TEX . TEXT) '(HTML . TEXT) '(HTM . TEXT)) (MEDLEY-INIT-VARS) (SETQ LOADUPDIRECTORIES DIRECTORIES) (LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT") (LOADFULLFONTS (MEDLEYDIR)) (LISTPUT IDLE.PROFILE 'TIMEOUT 0) (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) (LOADUP '(CHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE ISO8859IO HELPSYS DINFO CLIPBOARD MACINTERFACE)) (FILESLOAD (SYSLOAD) PRETTYFILEINDEX WHO-LINE) (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP)) (* ;; "Turn off who-line until after the user has greeted") (CL:WHEN (WINDOWP *WHO-LINE*) (CLOSEW *WHO-LINE*)) [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS] (FILESLOAD (SYSLOAD) UNIXCOMM UNIXCHAT UNIXTELNET) (FILESLOAD (SYSLOAD) SETDEFAULTPRINTER) (FILESLOAD (SYSLOAD) LOADPATCHES) (\DAYTIME0 \LASTUSERACTION) (LISTPUT IDLE.PROFILE 'TIMEOUT 20) (for TYPE in FILEPKTYPES do (FILEPKGCHANGES TYPE NIL)) (SETTOPVAL 'INITIALS NIL) (PROMPTPRINT "About to end loadup") (PRINTOUT T "About to end loadup" T) (* ;; "From SYNCLISPFILES") (ENDLOADUP) (COND ((WINDOWP LOGOW) (CLOSEW LOGOW))) (DREMOVE (ASSOC 'LOGOW AFTERMAKESYSFORMS) AFTERMAKESYSFORMS) (push AFTERMAKESYSFORMS '(CLRPROMPT) '(MEDLEY-INIT-VARS)) (* ;; "Set up for making the sysout, if we made it this far.") (CL:WHEN WRITEFULLSYSOUTFLAG (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T) (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " (MEDLEYVERSION) " Full Sysout%")"))) (DRIBBLE]) (FIXMETA [LAMBDA NIL (* ;  "Edited 25-Jun-2017 17:12 by rmk:") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP]) ) (FIXMETA) (RPAQQ WRITEFULLSYSOUTFLAG T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (MAKEFULLSYSOUT) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (853 7655 (LOADFULLFONTS 863 . 3367) (MAKEFULLSYSOUT 3369 . 7344) (FIXMETA 7346 . 7653)) ))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 16:56:12"  {DSK}kaplan>Local>medley3.5>git-medley>sources>LOADUP-FULL.;2 8011 changes to%: (FNS MAKEFULLSYSOUT) previous date%: " 6-Feb-2021 15:41:34" {DSK}kaplan>Local>medley3.5>git-medley>sources>LOADUP-FULL.;1) (PRETTYCOMPRINT LOADUP-FULLCOMS) (RPAQQ LOADUP-FULLCOMS ((COMMANDS "cd" "pwd" "ls") (FNS LOADFULLFONTS MAKEFULLSYSOUT FIXMETA) (P (FIXMETA)) (VARS (WRITEFULLSYSOUTFLAG T)) (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT))) (PROP FILETYPE))) (DEFCOMMAND "cd" (DIR) (/CNDIR DIR)) (DEFCOMMAND "pwd" NIL (DIRECTORYNAME T)) (DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST))) (DEFINEQ (LOADFULLFONTS [LAMBDA (ROOTDIRECTORY) (* ;  "Edited 11-Aug-2020 17:53 by rmk:") (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q") (PRINTOUT T "Loading FULL fonts..." T) (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts") (PACK* ROOTDIRECTORY "/fonts/altofonts"))) (* (SETQ INTERPRESSFONTDIRECTORIES  (CONS (PACK* ROOTDIRECTORY  "/fonts/ipfonts")))) (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE)) (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts"))) (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT) (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL) (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL)) (* ;  "Don't let the font loader substitute just because a server went catatonic on us") (for FAMILY in '(CLASSIC MODERN TERMINAL) do (PRINTOUT T " Loading " FAMILY " ") [for SIZE in '(8 10 12) do (PRINTOUT T SIZE " ") (for FACE in '(MRR BRR MIR) do (* ;; "No need for Interpress") (* (NLSETQ (FONTCREATE FAMILY SIZE  FACE NIL (QUOTE INTERPRESS) NIL 0))) (for CSET in '(0 33 34 35 238 239 241) do (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL 'DISPLAY NIL CSET] (PRINTOUT T T)) (PRINTOUT T " Loading postscript fonts" T) (for F in (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES) ">c0>*.*")) do (PSCFONT.READFONT F)) (PRINTOUT T "FULL fonts loaded" T]) (MAKEFULLSYSOUT [LAMBDA NIL (* ;  "Edited 5-Dec-2020 20:07 by larry") (* ;  "Edited 14-May-2018 15:01 by kaplan") (* ;  "Edited 22-Feb-2021 16:56 by rmk:") (* ; "Edited 17-Apr-2018 08:41 by ") (* ;  "Edited 21-Apr-2018 07:27 by rmk:") (* ; "Edited 23-Feb-94 15:04 by bvm") (CLRPROMPT) (CNDIR (UNIX-GETENV "LOADUPDIR")) (LET ((ROOTDIRECTORY (MEDLEYDIR))) (SETQ MAKESYSFILENAME (CONCAT (MEDLEYDIR "loadups") "xfull35.sysout")) (DRIBBLE (PACKFILENAME 'EXTENSION 'DRIBBLE 'BODY MAKESYSFILENAME)) (* ;; "BKSYSBUF stops page holding ") (PRINTOUT T T "Full loadup started at " (DATE) " while connected to " (DIRECTORYNAME T) T T) (BKSYSBUF " ") (SETQ DEFAULTFILETYPE 'BINARY) (* ;  "These prevent bits from being lost due to lack of knowledge") (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST) DEFAULTFILETYPELIST) (* (SETQ *UPPER-CASE-FILE-NAMES* NIL)) (SETQ MAKESYSNAME :MEDLEY3.5) (push DEFAULTFILETYPELIST '(TXT . TEXT) '(TEXT . TEXT) '(TEX . TEXT) '(HTML . TEXT) '(HTM . TEXT)) (MEDLEY-INIT-VARS) (SETQ LOADUPDIRECTORIES DIRECTORIES) (LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT") (LOADFULLFONTS (MEDLEYDIR)) (LISTPUT IDLE.PROFILE 'TIMEOUT 0) (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) (LOADUP '(CHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE ISO8859IO HELPSYS DINFO CLIPBOARD MODERNIZE)) (FILESLOAD (SYSLOAD) PRETTYFILEINDEX WHO-LINE) (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP)) (* ;; "Turn off who-line until after the user has greeted") (CL:WHEN (WINDOWP *WHO-LINE*) (CLOSEW *WHO-LINE*)) [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS] (FILESLOAD (SYSLOAD) UNIXCOMM UNIXCHAT UNIXTELNET) (FILESLOAD (SYSLOAD) SETDEFAULTPRINTER) (FILESLOAD (SYSLOAD) LOADPATCHES) (\DAYTIME0 \LASTUSERACTION) (LISTPUT IDLE.PROFILE 'TIMEOUT 20) (for TYPE in FILEPKTYPES do (FILEPKGCHANGES TYPE NIL)) (SETTOPVAL 'INITIALS NIL) (PROMPTPRINT "About to end loadup") (PRINTOUT T "About to end loadup" T) (* ;; "From SYNCLISPFILES") (ENDLOADUP) (COND ((WINDOWP LOGOW) (CLOSEW LOGOW))) (DREMOVE (ASSOC 'LOGOW AFTERMAKESYSFORMS) AFTERMAKESYSFORMS) (push AFTERMAKESYSFORMS '(CLRPROMPT) '(MEDLEY-INIT-VARS)) (* ;; "Set up for making the sysout, if we made it this far.") (CL:WHEN WRITEFULLSYSOUTFLAG (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T) (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " (MEDLEYVERSION) " Full Sysout%")"))) (DRIBBLE]) (FIXMETA [LAMBDA NIL (* ;  "Edited 25-Jun-2017 17:12 by rmk:") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP]) ) (FIXMETA) (RPAQQ WRITEFULLSYSOUTFLAG T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (MAKEFULLSYSOUT) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (885 7750 (LOADFULLFONTS 895 . 3399) (MAKEFULLSYSOUT 3401 . 7439) (FIXMETA 7441 . 7748)) ))) STOP \ No newline at end of file diff --git a/sources/LOADUP-FULL.LCOM b/sources/LOADUP-FULL.LCOM index 4a1a70ad1cd78623f48fdca49ee382d3f03afead..bb519b850198814c361353b02b3c74069d8b7894 100644 GIT binary patch delta 381 zcmaE$Gf8)XuZWS6u3Ku7u91O}p@N~Am8qGPq0z)dNyX6O)S_a$?8Jhc#5_Bn{N%(O zyWG^2oYYEVJyW~%%o5$nZy4pQ6_gY#bsYy@A-9mkQf+K_dLqjIsm#Ig#Tu)C=Ng*Y%1gL>m30cC>#LC3b z%G5+jlUKvd)5q00$kj2#)kOhS5!C5GtE*jty=!dUB;85mj_8!0Iy6{RNU=N4qf8XHA7Z?>3jjc?~tV}JG6nOC%%4oFNj%l6%m!q?%Ux;gvo1^pQ I$3p9w0ffC@H~;_u