(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Dec-87 15:41:38" |{POGO:AISNORTH:XEROX}<CUTTING>LISP>CD.;2| 16777
previous date%: "11-Dec-87 15:24:17" |{POGO:AISNORTH:XEROX}<CUTTING>LISP>CD.;1|)
(* "
Copyright (c) 1984, 1985, 1986, 1987 by
Henry Thompson, Dept. of Artificial Intelligence, Univ. of Edinburgh. All rights reserved.
")
(PRETTYCOMPRINT CDCOMS)
(RPAQQ CDCOMS ((FNS CDFun CDSepr CDName ChangeDir ReshowConn ShowCDMenu COPYBUTTONDOWN?)
(INITVARS [LocalDiskVolume (COND ((FMEMB (MACHINETYPE)
'(DANDELION DOVE))
(FILENAMEFIELD (DIRECTORYNAME '{DSK})
'DIRECTORY]
(CD.DEFAULT.HOST 'DSK)
(CD.DEFAULT.PREFIX LocalDiskVolume)
[CD.DEFAULT.USER (LET [(pos (STRPOS "." (USERNAME]
(COND [pos (PACK* (SUBSTRING (USERNAME)
1
(DIFFERENCE pos 1]
(T (USERNAME]
(CD.DEFAULT.LEFT)
(CD.DEFAULT.BOTTOM)
(CDMenuItems)
(LOGINHOST/DIR (CDName))
(CONNWINDOW)
(CDMenu)
(CDCommandMenu))
(ADDVARS (LISPXCOMS CD)
[AFTERSYSOUTFORMS (SETQ CD.DEFAULT.PREFIX (SETQ LocalDiskVolume
(COND
((FMEMB (MACHINETYPE)
'(DANDELION DOVE))
(FILENAMEFIELD
(DIRECTORYNAME '{DSK})
'DIRECTORY]
(POSTGREETFORMS [SETQ CD.DEFAULT.USER
(LET [(pos (STRPOS "." (USERNAME]
(COND [pos (PACK* (SUBSTRING (USERNAME)
1
(DIFFERENCE pos 1]
(T (USERNAME]
[SETQ CD.DEFAULT.PREFIX (SETQ LocalDiskVolume
(COND ((FMEMB (MACHINETYPE)
'(DANDELION DOVE))
(FILENAMEFIELD (DIRECTORYNAME
'{DSK})
'DIRECTORY]
(SETQ LOGINHOST/DIR (CDName)))
(CD.OS.SEPRS (DSK . >)
(UNIX . /)
(VMS . /)
(NS . >)
(IFS . >))
(CDCommandMenuItems (Connect (CDFun $dir$)
"Connect to the directory")
(Browse (APPLY* (FUNCTION FB)
$dir$)
"Bring up a file browser on the directory")
(Delete (PROGN (SETQ CDMenu NIL)
(SETQ CDMenuItems (DREMOVE $dir$ CDMenuItems)))
"Remove the directory from the CD menu")))
(ADVISE CNDIR DIRECTORYNAME)
(LISPXMACROS CD)
(COMMANDS "CD")
[P ([LAMBDA (new)
(COND ((FMEMB new CDMenuItems)
CDMenuItems)
(T (SETQ CDMenuItems (CONS new CDMenuItems]
(PACK* (DIRECTORYNAME '{DSK}]
(PROP MAKEFILE-ENVIRONMENT CD)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CD.DEFAULT.HOST CD.DEFAULT.PREFIX CD.OS.SEPRS LocalDiskVolume
CD.DEFAULT.USER CD.DEFAULT.LEFT CD.DEFAULT.BOTTOM CONNWINDOW CDMenu
CDMenuItems CDCommandMenuItems CDCommandMenu))))
(DEFINEQ
(CDFun
[LAMBDA (d) (* ; "Edited 9-Dec-87 18:08 by ")
(if d
then [SELECTQ (NTHCHAR d 1)
({ (ChangeDir d))
(< [ChangeDir (CDName (SUBSTRING d 2)
(FILENAMEFIELD (DIRECTORYNAME T)
'HOST])
(bind (target ← (DIRECTORYNAME T))
host dir sep dp first (SETQ dir (FILENAMEFIELD target 'DIRECTORY))
(SETQ dp (MKSTRING d))
(SETQ host (FILENAMEFIELD target 'HOST))
(SETQ sep (CDSepr host))
while (IGREATERP (NCHARS dp)
0)
do (if (EQ (NTHCHAR dp 1)
'%.)
then (GNC dp)
[if (EQ (NTHCHAR dp 1)
'%.)
then (GNC dp)
(bind (prev ← 0)
this while (SETQ this (STRPOS sep dir (PLUS prev 1)))
do (SETQ prev this)
finally (SETQ dir (SUBSTRING dir 1
(IMAX (IDIFFERENCE prev 1)
0)
dir]
else (SETQ dir (PACK* dir sep dp))
(GO $$OUT))
(if (OR (EQ (NTHCHAR dp 1)
sep)
(EQ (NTHCHAR dp 1)
'>))
then (GNC dp)) finally (RETURN (ChangeDir (PACKFILENAME 'HOST host
'DIRECTORY dir]
else (ChangeDir (CDName])
(CDSepr
[LAMBDA (host) (* ht%: "19-Mar-86 09:34")
(OR (CDR (ASSOC host CD.OS.SEPRS))
(CDR (ASSOC (GETOSTYPE host)
CD.OS.SEPRS))
'>])
(CDName
[LAMBDA (dir host) (* drc%: " 1-Jun-86 16:17")
(if (NOT host)
then (SETQ host CD.DEFAULT.HOST))
(if [AND (NOT dir)
(FMEMB (MACHINETYPE)
'(DANDELION DOVE]
then (SETQ dir CD.DEFAULT.USER))
(PACKFILENAME 'HOST host 'DIRECTORY (if [AND CD.DEFAULT.PREFIX
(NOT (AND (FMEMB (MACHINETYPE)
'(DANDELION DOVE))
(EQ CD.DEFAULT.PREFIX LocalDiskVolume)
(NEQ host 'DSK]
then (PACK* CD.DEFAULT.PREFIX (CDSepr host)
dir)
else dir])
(ChangeDir
[LAMBDA (dir) (* ht%: " 8-SEP-82 20:05")
(CONS (DIRECTORYNAME T)
(/CNDIR dir])
(ReshowConn
[LAMBDA NIL (* ht%: "30-Apr-85 17:33")
(PROG ((DN (DIRECTORYNAME T))
(TTYREG (WINDOWPROP \TopLevelTtyWindow 'REGION))
REG FONT)
(if (NOT (WINDOWP CONNWINDOW))
then (SETQ CONNWINDOW
(CREATEW (SETQ REG
(create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ← 10
HEIGHT ← 10))
NIL NIL T))
(WINDOWPROP CONNWINDOW 'BUTTONEVENTFN (FUNCTION ShowCDMenu))
(if (SETQ FONT (FONTCREATE 'HELVETICA 8 NIL NIL 'DISPLAY T))
then (DSPFONT FONT CONNWINDOW))
(replace HEIGHT of REG with (HEIGHTIFWINDOW (- (DSPLINEFEED NIL CONNWINDOW))
NIL NIL))
(SHAPEW CONNWINDOW REG))
(if (ACTIVEWP CONNWINDOW)
then (CLOSEW CONNWINDOW))
[SETQ REG (APPEND (WINDOWPROP CONNWINDOW 'REGION]
(replace LEFT of REG with (OR CD.DEFAULT.LEFT (fetch LEFT of TTYREG)))
(replace BOTTOM of REG with (OR CD.DEFAULT.BOTTOM (fetch TOP of TTYREG)))
(replace WIDTH of REG with (WIDTHIFWINDOW (STRINGWIDTH DN CONNWINDOW)
NIL))
(SHAPEW CONNWINDOW REG)
(DSPRESET CONNWINDOW)
(OPENW CONNWINDOW)
(PRIN3 DN CONNWINDOW])
(ShowCDMenu
[LAMBDA (cw) (* ht%: " 3-Apr-86 12:07")
(LET [(copyFlg (COPYBUTTONDOWN?))
(mv (MENU (OR CDMenu (create MENU
ITEMS ← CDMenuItems
MENUFONT ← (FONTCREATE 'HELVETICA 8 NIL NIL 'DISPLAY T)
WHENSELECTEDFN ← (FUNCTION (LAMBDA (item menu key vals)
(CONS key item]
(if mv
then (if copyFlg
then [if (COPYBUTTONDOWN?)
then (if (NLSETQ (while (COPYBUTTONDOWN?) do (BLOCK)))
then (BKSYSBUF (CDR mv]
else (SELECTQ (CAR mv)
(LEFT (CDFun (CDR mv)))
((MIDDLE RIGHT)
(PROMPTPRINT "Choose action for directory " (CDR mv))
[LET (($dir$ (CDR mv)))
(DECLARE (SPECVARS $dir$))
(MENU (OR CDCommandMenu (create MENU
ITEMS ← CDCommandMenuItems])
(SHOULDNT])
(COPYBUTTONDOWN?
[LAMBDA NIL (* ht%: "19-Mar-86 09:37")
(SHIFTDOWNP 'SHIFT])
)
(RPAQ? LocalDiskVolume [COND ((FMEMB (MACHINETYPE)
'(DANDELION DOVE))
(FILENAMEFIELD (DIRECTORYNAME '{DSK})
'DIRECTORY])
(RPAQ? CD.DEFAULT.HOST 'DSK)
(RPAQ? CD.DEFAULT.PREFIX LocalDiskVolume)
(RPAQ? CD.DEFAULT.USER [LET [(pos (STRPOS "." (USERNAME]
(COND [pos (PACK* (SUBSTRING (USERNAME)
1
(DIFFERENCE pos 1]
(T (USERNAME])
(RPAQ? CD.DEFAULT.LEFT )
(RPAQ? CD.DEFAULT.BOTTOM )
(RPAQ? CDMenuItems )
(RPAQ? LOGINHOST/DIR (CDName))
(RPAQ? CONNWINDOW )
(RPAQ? CDMenu )
(RPAQ? CDCommandMenu )
(ADDTOVAR LISPXCOMS CD)
(ADDTOVAR AFTERSYSOUTFORMS [SETQ CD.DEFAULT.PREFIX (SETQ LocalDiskVolume
(COND ((FMEMB (MACHINETYPE)
'(DANDELION DOVE))
(FILENAMEFIELD (DIRECTORYNAME
'{DSK})
'DIRECTORY])
(ADDTOVAR POSTGREETFORMS [SETQ CD.DEFAULT.USER (LET [(pos (STRPOS "." (USERNAME]
(COND [pos (PACK* (SUBSTRING (USERNAME)
1
(DIFFERENCE pos 1]
(T (USERNAME]
[SETQ CD.DEFAULT.PREFIX (SETQ LocalDiskVolume (COND
((FMEMB (MACHINETYPE)
'(DANDELION DOVE))
(FILENAMEFIELD
(DIRECTORYNAME '{DSK})
'DIRECTORY]
(SETQ LOGINHOST/DIR (CDName)))
(ADDTOVAR CD.OS.SEPRS (DSK . >)
(UNIX . /)
(VMS . /)
(NS . >)
(IFS . >))
(ADDTOVAR CDCommandMenuItems (Connect (CDFun $dir$)
"Connect to the directory")
(Browse (APPLY* (FUNCTION FB)
$dir$)
"Bring up a file browser on the directory")
(Delete (PROGN (SETQ CDMenu NIL)
(SETQ CDMenuItems (DREMOVE $dir$ CDMenuItems)))
"Remove the directory from the CD menu"))
[XCL:REINSTALL-ADVICE
'CNDIR :AROUND '((:LAST (PROG ((val (NLSETQ *)))
(ReshowConn)
(RETURN (if val then (if (NOT (FMEMB (CAR val)
CDMenuItems))
then
(push CDMenuItems (CAR val))
(SETQ CDMenu NIL))
(CAR val)
else
(ERROR!]
[XCL:REINSTALL-ADVICE 'DIRECTORYNAME :AFTER
'((:LAST (COND ([AND (EQ 'DSK (FILENAMEFIELD !VALUE 'HOST))
(NOT (FMEMB (NTHCHAR !VALUE -1)
'(> }]
(SETQ !VALUE (PACK* !VALUE ">"]
(READVISE CNDIR DIRECTORYNAME)
(ADDTOVAR LISPXMACROS (CD (CDFun (CAR LISPXLINE))))
(ADDTOVAR LISPXCOMS CD)
(DEFCOMMAND ("CD" :EVAL) (&OPTIONAL XCL-USER::DIR-SPEC)
"un*x style directory changing, e.g. cd foo (use << for ..)"
(LET ((XCL-USER::DS XCL-USER::DIR-SPEC))
(CDFun (CL:IF (EQ XCL-USER::DS 'XCL-USER::<<)
'XCL-USER::|..| XCL-USER::DS))))
[[LAMBDA (new)
(COND ((FMEMB new CDMenuItems)
CDMenuItems)
(T (SETQ CDMenuItems (CONS new CDMenuItems]
(PACK* (DIRECTORYNAME '{DSK}]
(PUTPROPS CD MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CD.DEFAULT.HOST CD.DEFAULT.PREFIX CD.OS.SEPRS LocalDiskVolume CD.DEFAULT.USER
CD.DEFAULT.LEFT CD.DEFAULT.BOTTOM CONNWINDOW CDMenu CDMenuItems CDCommandMenuItems
CDCommandMenu)
)
)
(PUTPROPS CD COPYRIGHT ("Henry Thompson, Dept. of Artificial Intelligence, Univ. of Edinburgh" 1984
1985 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4785 11633 (CDFun 4795 . 7044) (CDSepr 7046 . 7276) (CDName 7278 . 8222) (ChangeDir
8224 . 8386) (ReshowConn 8388 . 10077) (ShowCDMenu 10079 . 11488) (COPYBUTTONDOWN? 11490 . 11631)))))
STOP