home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
lispmachine.zip
/
lmiopn.lsp
< prev
next >
Wrap
Text File
|
1988-08-16
|
6KB
|
174 lines
;;; -*- PACKAGE:KERMIT;BASE:8;IBASE:8;MODE:LISP-*-
;******************************************************************************
; Copyright (c) 1984, 1985 by Lisp Machine Inc.
; Symbolics-specific portions Copyright (c) 1985 by Honeywell, Inc.
; Permission to copy all or part of this material is granted, provided
; that the copies are not made or distributed for resale, and the
; copyright notices and reference to the source file and the software
; distribution version appear, and that notice is given that copying is
; by permission of Lisp Machine Inc. LMI reserves for itself the
; sole commercial right to use any part of this KERMIT/H19-Emulator
; not covered by any Columbia University copyright. Inquiries concerning
; copyright should be directed to Mr. Damon Lawrence at (213) 642-1116.
;
; Version Information:
; LMKERMIT 1.0 -- Original LMI code, plus edit ;1; for 3600 port
;
; Authorship Information:
; Mark David (LMI) Original version, using KERMIT.C as a guide
; George Carrette (LMI) Various enhancements
; Mark Ahlstrom (Honeywell) Port to 3600 (edits marked with ";1;" comments)
;
; Author Addresses:
; George Carrette ARPANET: GJC at MIT-MC
;
; Mark Ahlstrom ARPANET: Ahlstrom at HI-Multics
; PHONE: (612) 887-4006
; USMAIL: Honeywell MN09-1400
; Computer Sciences Center
; 10701 Lyndale Avenue South
; Bloomington, MN 55420
;******************************************************************************
(declare (special interaction-pane debug-pane *filnam* *filelist* *serial-stream* *terminal*))
;;;; G N X T F L
;moved here from file kermit-window; 6-21-84 --mhd
(DEFUN GNXTFL ()
"Get next file in a file group.
Set *FILNAM* to next file, and return rest of *FILELIST*."
(AND *DEBUG* (DEBUGGER-TELL-USER ':GNXTFL *FILELIST*))
(without-interrupts (setq *filelist* (cdr *filelist*))
(setq *filnam* (car *filelist*)))
(cond ((#-3600 consp #+3600 listp *filnam*) ;1; can probably just make this listp for all...
(setq *as-filnam* (cadr *filnam*) *filnam* (car *filnam*))))
*FILELIST*)
;1; For 3600, I changed this around to defvar it earlier in the calls file.
;1; The .system file has also been changed to ensure that calls will be loaded
;1; before this file.
#-3600 (defconst kermit-default-pathname :unbound)
#+3600 (declare (special kermit-default-pathname))
(defun kermit-filelist (filename)
(let ((pathname
(fs:parse-pathname
(fs:merge-pathname-defaults filename kermit-default-pathname))))
;; must be parsable pathname
(cond
((eq (send pathname ':send-if-handles ':directory) ':unspecific)
;; some device or other random thing. just return what we got as a string.
(list (string pathname)))
(t
;; this is some other case; hopefully a string for the directory
;; such as "mhd", but who knows. You know someone should straighten
;; the Lisp Machine file mess out some day....
(loop for x in
(fs:directory-list pathname)
; let user see error message; no files will be sent; reasonable for today.
when (car x) collect (car x))))))
(defun string-for-kermit-infile (filename)
(fs:merge-pathname-defaults filename kermit-default-pathname))
(defun string-for-kermit-outfile (filename)
(fs:merge-pathname-defaults filename kermit-default-pathname))
(defun open-file-in-or-not (filename)
(open filename ':in))
(defun open-file-out-or-not (filename)
(open filename ':out))
(defvar *maxnamelength* 25)
(defvar *maxtypelength* 25)
;;; @@@ string-for-kermit
(defun string-for-kermit (filename &aux pathname dir name type version)
"given a [lispm] pathname, GENERALLY returns /"name.type/"."
(SETQ FILENAME (STRING FILENAME))
(prog ()
(setq pathname (fs:parse-pathname filename))
(selectq *filnamcnv*
(:generic
(setq dir nil
name (maybe-handle-wildthing pathname ':name *filnamcnv*)
type (maybe-handle-wildthing pathname ':type *filnamcnv*)
version nil))
(:raw (return filename))
(:otherwise
(setq dir nil
name (maybe-handle-wildthing pathname ':name *filnamcnv*)
type #-3600 (multiple-value-bind (thing winp) ;1; no fs:decode... on 3600
(fs:decode-canonical-type (send pathname ':canonical-type) *filnamcnv*)
(if winp
thing
(maybe-handle-wildthing pathname ':type *filnamcnv*)))
#+3600 (maybe-handle-wildthing pathname ':type *filnamcnv*)
version nil)))
(return (string-append (if dir (string-append dir name) name)
"." (if version (string-append type version) type)))))
(defprop :vms 9. *maxnamelength*)
(defprop :vms 3. *maxtypelength*)
(defun (:vms ok-filename-char) (x)
(or (<= #/a x #/z)
(<= #/A x #/Z)
(<= #/0 x #/9)
(= #/* x)))
(defun maybe-handle-wildthing (pathname element system)
(let ((s (cdr (assq element '((:name . *maxnamelength*)
(:type . *maxtypelength*))))))
(let ((max-length (or (get system s) (symeval s))))
(let ((e (send pathname element)))
(if (eq e ':wild) (setq e "*"))
(if (eq e ':unspecific) (setq e ""))
(if (get system 'ok-filename-char)
(setq e (with-output-to-string (y)
(do ((j 0 (1+ j)))
((= j (string-length e)))
(if (funcall (get system 'ok-filename-char) (aref e j))
(send y ':tyo (aref e j)))))))
(substring e 0 (min max-length (string-length e)))))))