home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / lispmachine / lmiopn.lsp < prev    next >
Text File  |  2020-01-01  |  6KB  |  174 lines
  1. ;;; -*- PACKAGE:KERMIT;BASE:8;IBASE:8;MODE:LISP-*-
  2.  
  3.  
  4.  
  5. ;******************************************************************************
  6. ; Copyright (c) 1984, 1985 by Lisp Machine Inc.
  7. ; Symbolics-specific portions Copyright (c) 1985 by Honeywell, Inc.
  8. ; Permission to copy all or part of this material is granted, provided
  9. ; that the copies are not made or distributed for resale, and the 
  10. ; copyright notices and reference to the source file and the software
  11. ; distribution version appear, and that notice is given that copying is
  12. ; by permission of Lisp Machine Inc.  LMI reserves for itself the 
  13. ; sole commercial right to use any part of this KERMIT/H19-Emulator
  14. ; not covered by any Columbia University copyright.  Inquiries concerning
  15. ; copyright should be directed to Mr. Damon Lawrence at (213) 642-1116.
  16. ;
  17. ; Version Information:
  18. ;      LMKERMIT 1.0     --      Original LMI code, plus edit ;1; for 3600 port
  19. ;
  20. ; Authorship Information:
  21. ;      Mark David (LMI)           Original version, using KERMIT.C as a guide
  22. ;      George Carrette (LMI)      Various enhancements
  23. ;      Mark Ahlstrom (Honeywell)  Port to 3600 (edits marked with ";1;" comments)
  24. ;
  25. ; Author Addresses:
  26. ;      George Carrette     ARPANET: GJC at MIT-MC
  27. ;
  28. ;      Mark Ahlstrom       ARPANET: Ahlstrom at HI-Multics
  29. ;                          PHONE:   (612) 887-4006
  30. ;                          USMAIL:  Honeywell MN09-1400
  31. ;                                   Computer Sciences Center
  32. ;                                   10701 Lyndale Avenue South
  33. ;                                   Bloomington, MN  55420
  34. ;******************************************************************************
  35.  
  36.  
  37. (declare (special interaction-pane debug-pane *filnam* *filelist* *serial-stream* *terminal*))
  38.  
  39. ;;;; G N X T F L
  40. ;moved here from file kermit-window; 6-21-84 --mhd
  41.  
  42. (DEFUN GNXTFL ()
  43.   "Get next file in a file group.
  44.    Set *FILNAM* to next file, and return rest of *FILELIST*."
  45.   (AND *DEBUG* (DEBUGGER-TELL-USER ':GNXTFL *FILELIST*))
  46.   (without-interrupts (setq *filelist* (cdr *filelist*))
  47.                           (setq *filnam* (car *filelist*)))
  48.   (cond ((#-3600 consp #+3600 listp *filnam*)    ;1; can probably just make this listp for all...
  49.            (setq *as-filnam* (cadr *filnam*) *filnam* (car *filnam*))))
  50.   *FILELIST*)
  51.  
  52.  
  53.  
  54.  
  55.  
  56. ;1; For 3600, I changed this around to defvar it earlier in the calls file.
  57. ;1; The .system file has also been changed to ensure that calls will be loaded
  58. ;1; before this file.
  59. #-3600 (defconst kermit-default-pathname :unbound)
  60. #+3600 (declare (special kermit-default-pathname))
  61.  
  62.  
  63. (defun kermit-filelist (filename)
  64.   (let ((pathname
  65.             (fs:parse-pathname
  66.               (fs:merge-pathname-defaults filename kermit-default-pathname))))
  67.     ;; must be parsable pathname
  68.     (cond
  69.       ((eq (send pathname ':send-if-handles ':directory) ':unspecific)
  70.        ;; some device or other random thing. just return what we got as a string.
  71.        (list (string pathname)))
  72.       (t
  73.        ;; this is some other case; hopefully a string for the directory
  74.        ;; such as "mhd", but who knows.  You know someone should straighten
  75.        ;; the Lisp Machine file mess out some day....
  76.        (loop for x in
  77.                (fs:directory-list pathname)
  78.                ; let user see error message; no files will be sent; reasonable for today.
  79.                when (car x) collect (car x))))))
  80.  
  81.  
  82. (defun string-for-kermit-infile (filename)
  83.   (fs:merge-pathname-defaults filename kermit-default-pathname))
  84.  
  85.  
  86. (defun string-for-kermit-outfile (filename)
  87.   (fs:merge-pathname-defaults filename kermit-default-pathname))
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94. (defun open-file-in-or-not (filename)
  95.   (open filename ':in))
  96.  
  97. (defun open-file-out-or-not (filename)
  98.   (open filename ':out))
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109. (defvar *maxnamelength* 25)
  110.  
  111.  
  112.  
  113.  
  114.  
  115. (defvar *maxtypelength* 25)
  116.  
  117.  
  118.  
  119.  
  120.  
  121. ;;; @@@ string-for-kermit
  122.  
  123. (defun string-for-kermit (filename &aux pathname dir name type version)
  124.   "given a [lispm] pathname, GENERALLY returns /"name.type/"."
  125.   (SETQ FILENAME (STRING FILENAME))
  126.   (prog ()
  127.  
  128.           (setq pathname (fs:parse-pathname filename))
  129.  
  130.           (selectq *filnamcnv*
  131.             (:generic
  132.              (setq dir nil
  133.                      name (maybe-handle-wildthing pathname ':name *filnamcnv*)
  134.                      type (maybe-handle-wildthing pathname ':type *filnamcnv*)
  135.                      version nil))
  136.             (:raw (return filename))
  137.             (:otherwise
  138.              (setq dir nil
  139.                      name (maybe-handle-wildthing pathname ':name *filnamcnv*)
  140.                      type #-3600 (multiple-value-bind (thing winp)    ;1; no fs:decode... on 3600
  141.                      (fs:decode-canonical-type (send pathname ':canonical-type) *filnamcnv*)
  142.                    (if winp
  143.                        thing
  144.                        (maybe-handle-wildthing pathname ':type *filnamcnv*)))
  145.                   #+3600 (maybe-handle-wildthing pathname ':type *filnamcnv*)
  146.                      version nil)))
  147.  
  148.           (return (string-append (if dir (string-append dir name) name)
  149.                                      "." (if version (string-append type version) type)))))
  150.  
  151. (defprop :vms 9. *maxnamelength*)
  152. (defprop :vms 3. *maxtypelength*)
  153.  
  154. (defun (:vms ok-filename-char) (x)
  155.   (or (<= #/a x #/z)
  156.       (<= #/A x #/Z)
  157.       (<= #/0 x #/9)
  158.       (= #/* x)))
  159.  
  160. (defun maybe-handle-wildthing (pathname element system)
  161.   (let ((s (cdr (assq element '((:name . *maxnamelength*)
  162.                                         (:type . *maxtypelength*))))))
  163.     (let ((max-length (or (get system s) (symeval s))))
  164.       (let ((e (send pathname element)))
  165.           (if (eq e ':wild) (setq e "*"))
  166.           (if (eq e ':unspecific) (setq e ""))
  167.           (if (get system 'ok-filename-char)
  168.               (setq e (with-output-to-string (y)
  169.                           (do ((j 0 (1+ j)))
  170.                                 ((= j (string-length e)))
  171.                               (if (funcall (get system 'ok-filename-char) (aref e j))
  172.                                   (send y ':tyo (aref e j)))))))
  173.           (substring e 0 (min max-length (string-length e)))))))
  174.