(FILECREATED "30-Dec-85 11:59:27" {DSK19}CD.;2 7649
changes to: (VARS CDCOMS)
previous date: "30-Apr-85 17:38:04" {IVY}<HTHOMPSON>LISP>UTIL>CD.;4)
(* Copyright (c) 1984, 1985 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 ((EQ (MACHINETYPE)
'DANDELION)
(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))
(ADDVARS (LISPXCOMS CD)
(POSTGREETFORMS (SETQ CD.DEFAULT.USER USERNAME)
(SETQ LOGINHOST/DIR (CDName))
(CDFun))
(CD.OS.SEPRS (DSK . >)
(UNIX . /)
(VMS . /)
(NS . >)
(IFS . >)))
(ADVISE CNDIR DIRECTORYNAME)
(GLOBALVARS CD.DEFAULT.HOST CD.DEFAULT.PREFIX CD.OS.SEPRS LocalDiskVolume
CD.DEFAULT.USER CD.DEFAULT.LEFT CD.DEFAULT.BOTTOM CONNWINDOW CDMenu
CDMenuItems)
(LISPXMACROS CD)
(P ([LAMBDA (new)
(COND ((FMEMB new CDMenuItems)
CDMenuItems)
(T (SETQ CDMenuItems (CONS new CDMenuItems]
(PACK* (DIRECTORYNAME '{DSK}])
(DEFINEQ
(CDFun
[LAMBDA (d) (* ht: "30-Apr-85 17:09")
(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 (dir←(FILENAMEFIELD target 'DIRECTORY))
(dp←(MKSTRING d))
(host←(FILENAMEFIELD target 'HOST))
(sep←(CDSepr host))
while (IGREATERP (NCHARS dp)
0)
do (if (NTHCHAR dp 1)= '%.
then (GNC dp)
(if (NTHCHAR dp 1)= '%.
then (GNC dp)
(bind (prev ← 0)
this while this←(STRPOS sep dir prev+1)
do prev←this finally dir←(SUBSTRING dir 1
(IMAX prev-1 0)
dir)))
else (dir←(PACK* dir sep dp))
(GO $$OUT))
(if (OR (NTHCHAR dp 1)=sep (NTHCHAR dp 1)= '>)
then (GNC dp))
finally (RETURN (ChangeDir (PACKFILENAME 'HOST
host
'DIRECTORY
dir]
else (ChangeDir (CDName])
(CDSepr
[LAMBDA (host) (* ht: "20-Mar-85 18:40")
(OR (CDR (ASSOC host CD.OS.SEPRS))
(CDR (ASSOC (CDR (ASSOC host NETWORKOSTYPES))
CD.OS.SEPRS))
'>])
(CDName
[LAMBDA (dir host) (* ht: "20-Mar-85 17:30")
(if (NOT host)
then host←CD.DEFAULT.HOST)
(if (AND (NOT dir)
(MACHINETYPE)=
'DANDELION)
then dir←CD.DEFAULT.USER)
(PACKFILENAME 'HOST
host
'DIRECTORY
(if CD.DEFAULT.PREFIX
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 (CONNWINDOW←(CREATEW REG←(create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ← 10
HEIGHT ← 10)
NIL NIL T))
(WINDOWPROP CONNWINDOW 'BUTTONEVENTFN
(FUNCTION ShowCDMenu))
(if FONT←(FONTCREATE 'HELVETICA
8 NIL NIL 'DISPLAY
T)
then (DSPFONT FONT CONNWINDOW))
(REG:HEIGHT←(HEIGHTIFWINDOW (-(DSPLINEFEED NIL CONNWINDOW))
NIL NIL))
(SHAPEW CONNWINDOW REG))
(if (ACTIVEWP CONNWINDOW)
then (CLOSEW CONNWINDOW))
[REG←(APPEND (WINDOWPROP CONNWINDOW 'REGION]
(REG:LEFT←(OR CD.DEFAULT.LEFT TTYREG:LEFT))
(REG:BOTTOM←(OR CD.DEFAULT.BOTTOM TTYREG:TOP))
(REG:WIDTH←(WIDTHIFWINDOW (STRINGWIDTH DN CONNWINDOW)
NIL))
(SHAPEW CONNWINDOW REG)
(DSPRESET CONNWINDOW)
(OPENW CONNWINDOW)
(PRIN3 DN CONNWINDOW])
(ShowCDMenu
[LAMBDA (cw) (* ht: "30-Apr-85 17:31")
(let [(copyFlg (COPYBUTTONDOWN?))
(mv (MENU (OR CDMenu (create MENU
ITEMS ← CDMenuItems
MENUFONT ←(FONTCREATE 'HELVETICA
8 NIL NIL 'DISPLAY
T]
(if mv
then (if copyFlg
then (if (COPYBUTTONDOWN?)
then (if (NLSETQ (while (COPYBUTTONDOWN?) do (BLOCK)))
then (BKSYSBUF mv)))
else (CDFun mv])
(COPYBUTTONDOWN?
[LAMBDA NIL
(OR (KEYDOWNP (QUOTE LSHIFT))
(KEYDOWNP (QUOTE RSHIFT])
)
(RPAQ? LocalDiskVolume [COND ((EQ (MACHINETYPE)
'DANDELION)
(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 )
(ADDTOVAR LISPXCOMS CD)
(ADDTOVAR POSTGREETFORMS (SETQ CD.DEFAULT.USER USERNAME)
(SETQ LOGINHOST/DIR (CDName))
(CDFun))
(ADDTOVAR CD.OS.SEPRS (DSK . >)
(UNIX . /)
(VMS . /)
(NS . >)
(IFS . >))
(PUTPROPS CNDIR READVICE [NIL (AROUND NIL (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!])
(PUTPROPS DIRECTORYNAME READVICE [NIL (AFTER NIL (COND ([AND (EQ 'DSK
(FILENAMEFIELD !VALUE
'HOST))
(NOT (FMEMB (NTHCHAR !VALUE -1)
'(> })]
(SETQ !VALUE (PACK* !VALUE ">"])
(READVISE CNDIR DIRECTORYNAME)
(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)
)
(ADDTOVAR LISPXMACROS (CD (CDFun (CAR LISPXLINE))))
(ADDTOVAR LISPXCOMS CD)
[[LAMBDA (new)
(COND ((FMEMB new CDMenuItems)
CDMenuItems)
(T (SETQ CDMenuItems (CONS new CDMenuItems]
(PACK* (DIRECTORYNAME '{DSK}]
(PUTPROPS CD COPYRIGHT ("Henry Thompson, Dept. of Artificial Intelligence, Univ. of Edinburgh" 1984
1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1583 5706 (CDFun 1593 . 2881) (CDSepr 2883 . 3125) (CDName 3127 . 3575) (ChangeDir 3577
. 3739) (ReshowConn 3741 . 5014) (ShowCDMenu 5016 . 5587) (COPYBUTTONDOWN? 5589 . 5704)))))
STOP