(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED " 6-Jul-88 11:51:18" {IVY}<HTHOMPSON>LISP>UTIL>CD.;8
 18509  

      changes to%:  (VARS CDCOMS)
                    (FNS CDFun)

      previous date%: "14-Dec-87 15:41:38" {ERINYES}<LISP>LYRIC>LISPUSERS>CD.;2)


(* "
Copyright (c) 1984, 1985, 1986, 1987, 1988 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  6-Jul-88 11:49 by ht:")

    (if
 d
        then

        [LET* ((target (DIRECTORYNAME T))
               (host (FILENAMEFIELD target 'HOST))
               (dir (FILENAMEFIELD target 'DIRECTORY))
               (sep (CDSepr
 host)))
              (SELECTQ (NTHCHAR d 1)
                  ({ (ChangeDir
 d))
                  (< [if
 (AND (EQ (NCHARS d)
                                      2)
                                  (EQ (NTHCHAR d 1)
                                      '<))
                         then
 

                               (* ;; "this hack here for common lisp readtables which reject ..")


                               [bind
 (prev _ 0)
                                      this while
 (SETQ this (STRPOS sep dir (PLUS prev 1)))
                                  do
 (SETQ prev this)
                                  finally
 (ChangeDir
 (PACKFILENAME 'HOST host 'DIRECTORY
                                                                    (SUBSTRING dir 1
                                                                           (IMAX (IDIFFERENCE prev 1)
                                                                                 0)
                                                                           dir]
                       else
 (ChangeDir
 (CDName
 (SUBSTRING d 2)
                                                      (FILENAMEFIELD (DIRECTORYNAME T)
                                                             'HOST])
                  (bind
 dp first
 (SETQ dp (MKSTRING d)) 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 1988))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (5118 13308 (CDFun 5128 . 8719) (CDSepr 8721 . 8951) (CDName 8953 . 9897) (ChangeDir 
9899 . 10061) (ReshowConn 10063 . 11752) (ShowCDMenu 11754 . 13163) (COPYBUTTONDOWN? 13165 . 13306))))
)
STOP