github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-04 18:54:08 +00:00
Code Issues Releases Wiki Activity

KERMIT - file transfer.

Browse Source
This commit is contained in:
Lars Brinkhoff
2016-12-23 20:54:39 +01:00
committed by Eric Swenson
parent 686cbc12d5
commit 31e3aa5e67
8 changed files with 2060 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@@ -10,7 +10,7 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \
spcwar rwg libmax rat z emaxim rz maxtul aljabr cffk das ell ellen \
jim jm jpg macrak maxdoc maxsrc mrg munfas paulw reh rlb rlb% share \
tensor transl wgd zz graphs lmlib pratt quux scheme gsb ejs mudsys \
draw wl taa tj6 budd sharem ucode rvb kldcp
draw wl taa tj6 budd sharem ucode rvb kldcp math
DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \
chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \
xfont maxout ucode moon acount alan channa fonts games graphs humor \

12
build/lisp.tcl
View File

@@ -858,3 +858,15 @@ respond "*" "complr\013"
respond "_" "games;_chase\r"
respond "_" "\032"
type ":kill\r"
# Kermit
respond "*" ":link math;defset fasl,lisp;\r"
respond "*" ":complr\r"
respond "_" "math;common\r"
respond "_" "math;kermit\r"
respond "_" "\032"
type ":kill\r"
respond "*" ":lisp math; kermit dumper\r"
respond "to dump.|" "(kermit-dump)"
expect ":KILL"
respond "*" ":link sys3;ts kermit,math;\r"

109
doc/info/kermit.4 Executable file
View File

@@ -0,0 +1,109 @@
-*-Text-*-
This is the file INFO;KERMIT >, which documents KERMIT, a file-transfer
program.

File: Kermit Node: Top Up: (DIR) Next: Simple
Kermit is a file transfer program which can send and receive text files
over a terminal line. It is particularly useful for transferring files
between an ITS and a PC or other random computer which has a modem but
isn't connected to any network.
* Menu:
* Simple:: Basic usage.
* Filenames:: File name syntax.
* Parameters:: Setting internal parameters.

File: Kermit Node: Simple Up: Top Next: Filenames
For purposes of this presentation, I'll refer to the machine which is at
the other end of the connection as the "PC", even though of course it
can be any machine which runs Kermit.
Typical use of Kermit is as follows:
1. Get ahold of a terminal emulator and a kermit program for your PC.
Often these come together in a single package. Kermit has many
implementations, inluding versions for Unix, IBM PC (crosstalk?),
Macintosh, VAX/VMS, and Symbolics 3600. Many of these are public
domain. I think the MIT microcomputer store sells it. You can
also get it from Columbia University, which is where Kermit originated.
2. Start the terminal emulator, dial up the ITS machine on the phone,
and log in.
3. Run the Kermit server with the DDT command :KERMIT. It will inform
you that it is entering Kermit server mode.
4. On the PC, run the kermit user program. This is usually a command
processor or menu which has commands like GET, SEND, and FINISH.
5. Issue GET and SEND commands to receive or transmit files.
6. Issue a FINISH command to halt the ITS KERMIT server.
7. Return to the terminal emulator to get back to ITS, etc.

File: Kermit Node: Filenames Up: Top Next: Parameters
In order to accomodate Kermit user programs which are unable to send or
receive filenames with spaces in them, ITS Kermit will treat a period in
the filename as a FN1/FN2 separator. E.g., to get file FOO STUFF in the
current directory, issue the command GET FOO.STUFF. Yes, this means
that you can't ask for files that have dots in their names; this is an
unfortunate limitation.
A second filename of LSP, LISP, TXT, or SCM will be ignored (treated
like >). (This is controlled by the variable *ITS-UNINTERESTING-TYPES*;
see the Parameters node.)
To accomodate Kermit programs that don't like semicolons, but do
like colons, ITS Kermit will treat FOO: as if it were FOO;,assuming
that there is no FOO device.

File: Kermit Node: Parameters Up: Top
Kermit is a Maclisp program. A number of interesting internal
parameters are stored as the values of Lisp global variables. They can
be changed by using SETQ at a read-eval-print loop or in your Kermit
init file. For example, if your uname is FOO, you can put
(PUSH "tex" *ITS-UNINTERESTING-TYPES*)
in your Kermit init file FOO KERMIT.
To get to a read-eval-print loop, type control-G. To enter Kermit
server mode again, call the function SERVE with no arguments.
E.g.:
^G
QUIT
(PUSH "tex" *ITS-UNINTERESTING-TYPES*)
(...)
(SERVE)
Entering KERMIT server mode.
Here are some of the things you can set:
Variable Default Description
*DEBUG?* NIL T means supply debugging info as you run
*VERSION-NUMBERS?* NIL T means include version numbers in file names,
whenever possible
*MAX-RETRY-COUNT* 10. Times to retry a packet
*MIN-TIMEOUT* 2 Minimum timeout interval in seconds
*SERVER-TIMEOUT* 30 Timeout interval when in server mode
*SERIAL-INPUT* NIL Input stream for serial line
*SERIAL-OUTPUT* NIL Output stream for serial line
*COMMENTARY-STREAM* terminal Stream for messages to user
*DEFAULT-PATHNAME-DEFAULTS*
The variable *ITS-UNINTERESTING-TYPES* is a list of file types that
should be treated as if they aren't there. The default value is
("LISP" "LSP" "SCM" "TXT" "lisp" "lsp" "scm" "txt" "" :UNSPECIFIC).
See the source code (AI: MATH; KERMIT >) for further inspiration.

105
doc/math/kermit.order Executable file
View File

@@ -0,0 +1,105 @@
-*-Text-*-
This is the file INFO;KERMIT >, which documents KERMIT, a file-transfer
program.

File: Kermit Node: Top Up: (DIR) Next: Simple
Kermit is a file transfer program which can send and receive text files
over a terminal line. It is particularly useful for transferring files
between an ITS and a PC or other random computer which has a modem but
isn't connected to any network.
* Menu:
* Simple:: Basic usage.
* Filenames:: File name syntax.
* Parameters:: Setting internal parameters.

File: Kermit Node: Simple Up: Top Next: Filenames
For purposes of this presentation, I'll refer to the machine which is at
the other end of the connection as the "PC", even though of course it
can be any machine which runs Kermit.
Typical use of Kermit is as follows:
1. Get ahold of a terminal emulator and a kermit program for your PC.
Often these come together in a single package. Kermit has many
implementations, inluding versions for Unix, IBM PC (crosstalk?),
Macintosh, VAX/VMS, and Symbolics 3600. Many of these are public
domain. I think the MIT microcomputer store sells it. You can
also get it from Columbia University, which is where Kermit originated.
2. Start the terminal emulator, dial up the ITS machine on the phone,
and log in.
3. Run the Kermit server with the DDT command :KERMIT. It will inform
you that it is entering Kermit server mode.
4. On the PC, run the kermit user program. This is usually a command
processor or menu which has commands like GET, SEND, and FINISH.
5. Issue GET and SEND commands to receive or transmit files.
6. Issue a FINISH command to halt the ITS KERMIT server.
7. Return to the terminal emulator to get back to ITS, etc.

File: Kermit Node: Filenames Up: Top Next: Parameters
In order to accomodate Kermit user programs which are unable to send or
receive filenames with spaces in them, ITS Kermit will treat a period in
the filename as a FN1/FN2 separator. E.g., to get file FOO TXT in the
current directory, issue the command GET FOO.TXT.
A second filename of LSP, LISP, TXT, or SCM will be ignored (treated
like >). (This is controlled by the Maclisp variable
*ITS-UNINTERESTING-TYPES*; see below.)
To accomodate Kermit user programs which don't like semicolons, but do
like colons, ITS Kermit will treat FOO: as if it were FOO; (assuming
that there is no FOO device).
By default, ITS Kermit will transmit version numbers for files which
have them. E.g. if you ask to get file FOO.LSP, and there is a local
file FOO 23, ITS Kermit will say that it is transmitting FOO.LSP.23.
If you don't want this, you'll have to set *VERSION-NUMBERS?* to NIL
(see below).

File: Kermit Node: Parameters Up: Top
Kermit is a Maclisp program. A number of interesting internal
parameters are stored as the values of global variables, and therefore
can be changed by using SETQ at a read-eval-print loop.
To get to a read-eval-print loop, type control-G. To enter Kermit
server mode, call the function SERVE with no arguments.
E.g.:
^G
QUIT
(PUSH "tex" *ITS-UNINTERESTING-TYPES*)
(...)
(SERVE)
Entering KERMIT server mode.
Here are some of the things you can set:
(DEFVAR *DEBUG?* NIL "T means supply debugging info as you run")
(DEFVAR *VERSION-NUMBERS?* T "T means include version numbers in file names")
(DEFVAR *MAX-RETRY-COUNT* 10. "times to retry a packet")
(DEFVAR *MIN-TIMEOUT* 2 "minimum timeout interval in seconds")
(DEFVAR *SERVER-TIMEOUT* 30 "timeout interval when in server mode")
(DEFVAR *SERIAL-INPUT* NIL "input stream for serial line")
(DEFVAR *SERIAL-OUTPUT* NIL "output stream for serial line")
(DEFVAR *COMMENTARY-STREAM* *TERMINAL-IO* "stream for messages to user")
See the source code (AI: MATH; KERMIT >) for inspiration.

1
doc/programs.md
View File

@@ -101,6 +101,7 @@
- JEDGAR, counter spying tool.
- JOBS, list jobs by category.
- JOTTO, word-guessing game.
- KERMIT, file transfer.
- KLDCP, KL10 diagnostics console program.
- KLFEDR, KL10 frontend directory tool.
- KLRUG, KL10 frontend debugger.

659
src/math/common.88 Normal file
View File

@@ -0,0 +1,659 @@
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: (KERMIT LISP) -*-
;;; Common-Lisp-in-Maclisp
;;; Jonathan Rees MIT Jan-Feb 1986
;;; Please don't take this seriously. It exists only to make KERMIT and
;;; a couple of other things of mine work.
(setq gc-overflow nil)
;;; Change read syntax
(eval-when (eval load compile)
(setq base 10. ibase 10. *nopoint t)
(sstatus syntax 47. 2.)
(sstatus syntax 92. 132416.)
(or (get 'sharpm 'version)
(load '((lisp) sharpm)))
(defprop defsetf ((dsk math) defset fasl) autoload))
(declare (mapex t))
(eval-when (eval load compile)
(defsharp \\ (macro-arg)
(declare (special \#-symbolic-characters-table))
(let ((first-char (tyipeek)))
(cond ((not (or (and (>= first-char 65.) (<= first-char 90.))
(and (>= first-char 97.) (<= first-char 122.))))
;; Not alphabetic
(tyi))
(t
(let ((foo (read)))
(cond ((= (flatc foo) 1) first-char)
(t
(let ((probe (assq foo \#-symbolic-characters-table)))
(cond (probe (cdr probe))
(t (error "unknown #\\ character name" foo 'fail-act)))))))))))
)
(push '(LINE . 10.) |#-SYMBOLIC-CHARACTERS-TABLE|)
(push '(PAGE . 12.) |#-SYMBOLIC-CHARACTERS-TABLE|)
;;; -- Macros & special forms
(defmacro lisp:catch (tag &rest body)
`(*catch ,tag ,@body))
(defmacro lisp:throw (tag value)
`(*throw ,tag ,value))
(defmacro defparameter (var val &rest foo)
`(progn 'compile
(defvar ,var nil ,@foo)
(setq ,var ,val)))
(defmacro defconstant (&rest x)
`(defconst ,@x)) ;randomness in MLMAC
(defun require (module &optional (filename module))
(or (get module 'version)
(load filename)))
(defun provide (module)
(putprop module t 'version))
(defmacro the (type obj) type obj)
;;; DEFSUBST isn't Common Lisp, but Maclisp has no (declare (inline ...)).
(defmacro defsubst (name bvl &rest body)
(let ((body (if (null (cdr body)) (car body) `(progn ,@body))))
`(defmacro ,name ,bvl
(sublis (list ,@(mapcar #'(lambda (var) `(cons ',var ,var)) bvl))
',body))))
(defmacro incf (place &optional (amount 1))
`(setf ,place (+ ,place ,amount)))
(defmacro decf (place &optional (amount 1))
`(setf ,place (- ,place ,amount)))
(defmacro multiple-value-setq (&rest x)
`(multiple-value ,@x))
(defmacro case (key &rest clauses)
`(caseq ,key ,@(mapcar #'(lambda (clause)
(if (eq (car clause) 'otherwise)
(cons 't (cdr clause))
clause))
clauses)))
;(eval-when (eval load compile)
; (or (status feature defstruct)
; (load '((dsk liblsp) struct))))
;;; -- Internal utility
(defmacro let-keyword-args (specs rest &rest body)
(cond ((null specs) body)
(t `(let* ,(mapcar #'(lambda (spec)
(let ((name (if (atom spec) spec (car spec)))
(init (if (atom spec) nil (cadr spec))))
`(,name
(let ((,name (member ',(symbolconc ': name) ,rest)))
(if ,name (cadr ,name) ,init)))))
specs)
,@body))))
;;; -- Randomness
(declare (unspecial args))
(defvar *terminal-io* t)
(defvar *debug-io* t)
(defvar *standard-input* t)
(defvar *standard-output* t)
;;; -- Various functions
(cond ((status feature complr)
(*lexpr import export in-package make-package lisp:open lisp:close
aref concatenate make-pathname merge-pathnames
make-broadcast-stream)))
(defmacro consp (x) `(not (atom ,x)))
(defmacro symbol-value (x) `(symeval ,x))
(defmacro symbol-function (x) x)
(defmacro lisp:apply (&rest stuff) `(lexpr-funcall ,@stuff))
(defmacro char-code (x) x)
(defmacro code-char (x) x)
(defmacro char= (&rest stuff) `(= ,@stuff))
(defmacro char< (&rest stuff) `(< ,@stuff))
(defmacro char> (&rest stuff) `(> ,@stuff))
(defmacro char<= (&rest stuff) `(<= ,@stuff))
(defmacro char>= (&rest stuff) `(>= ,@stuff))
(defun alpha-char-p (c)
(or (and (>= c 65.) (<= c 90.))
(and (>= c 97.) (<= c 122.))))
(defun graphic-char-p (c)
(and (>= c 32.) (< c 127.)))
;;; Packages
(defvar *package* 'user)
(defconstant :use ':use)
(defun find-package (name) name)
(defun in-package (package &rest ignore)
(setq *package* package))
(defun export (symbols &rest ignore) nil)
(defmacro shadow (symbols &optional (pkg '*package*))
`(eval-when (eval load compile)
(*shadow ,symbols ,pkg)))
(defun *shadow (symbols pkg) pkg
(mapc #'(lambda (symbol)
(cond ((and (not (get symbol 'shadows))
(not (get symbol 'shadowed-by)))
(remob symbol)
(let ((new (intern (copysymbol symbol nil))))
(putprop symbol new 'shadowed-by)
(putprop new symbol 'shadows)))))
(if (and symbols (atom symbols))
(list symbols)
symbols)))
(defun make-package (&rest ignore)
(*array nil 'obarray nil))
;;; Arrays
(defconstant :element-type ':element-type)
(defconstant :fill-pointer ':fill-pointer)
(defun make-array (dimensions &rest rest)
(let-keyword-args ((element-type 't)
(fill-pointer nil))
rest
(let* ((dimensions (if (atom dimensions) (list dimensions) dimensions))
(the-array
(lexpr-funcall #'*array nil
(cond ((memq element-type
'(character string-char fixnum))
'fixnum)
((eq element-type 'float) 'flonum)
(t 't))
dimensions)))
(hunk the-array
(if (not (fixp fill-pointer)) (car dimensions) fill-pointer)
'array))))
(defun lisp:arrayp (obj)
(and (hunkp obj) (eq (cdr obj) 'array)))
(defmacro array-array (array)
`(cxr 1 ,array))
(defmacro fill-pointer (array)
`(cxr 2 ,array))
(defun aref (array &rest subscripts)
(cond ((simple-string-p array)
(getcharn array (1+ (car subscripts))))
(t
(apply (array-array array) subscripts))))
;;; (defsetf aref ((aref array &rest subscripts) value) t
;;; `(store (funcall (array-array ,array) ,@subscripts) ,value))
(PROGN 'COMPILE
(DEFUN |AREF SETF-X-ACCESS| (|SETF-struct..44| ARRAY &REST SUBSCRIPTS)
(LET ((|Function..43| (SETF-FUNCTION |SETF-struct..44|)))
(LIST* |Function..43| ARRAY SUBSCRIPTS)))
(DEFUN |AREF SETF-X-INVERT| (|SETF-struct..44| VALUE ARRAY &REST SUBSCRIPTS)
(LET ((AREF (SETF-FUNCTION |SETF-struct..44|)))
AREF
`(STORE (FUNCALL (ARRAY-ARRAY ,ARRAY) ,@SUBSCRIPTS) ,VALUE)))
(DEFUN (AREF SETF-X) (|access-spec..42|)
(LET (((|Function..43| ARRAY . SUBSCRIPTS) |access-spec..42|))
(SETF-STRUCT '|AREF SETF-X-ACCESS|
'|AREF SETF-X-INVERT|
'T
(LIST* ARRAY SUBSCRIPTS)
|Function..43|)))
'AREF)
;;; Simple strings
(defun simple-string-p (obj)
(and (symbolp obj) (get obj '+internal-string-marker)))
(defun stringicate (symbol)
(putprop symbol t '+internal-string-marker)
symbol)
;;; Strings
(defun stringp (obj)
(or (simple-string-p obj)
(lisp:arrayp obj)))
(defun string-elt (string index)
(cond ((symbolp string)
(getcharn string (1+ index)))
(t
(arraycall fixnum (array-array string) index))))
(defun set-string-elt (string index value)
(store (arraycall fixnum (array-array string) index) value))
(defsetf string-elt ((string-elt string index) value) t
`(set-string-elt ,string ,index ,value))
(defun coerce (obj type)
(cond ((and (listp obj) (eq type 'string))
(stringicate (maknam obj)))
((and (stringp obj) (eq type 'string)) obj)
((and (symbolp obj) (eq type 'list)) (exploden obj))
((and (lisp:arrayp obj) (eq type 'list))
(do ((i (1- (fill-pointer obj)) (1- i))
(l '() (cons (aref obj i) l)))
((< i 0) l)))
((and (listp obj) (eq type 'list)) obj)
((eq (typep obj) type) obj)
(t (error "bad args to COERCE" (list obj type) 'fail-act))))
(defun unkludgify-string (data)
(cond ((simple-string-p data) data)
(t (coerce (coerce data 'list) 'string))))
;;; Sequences
(defun concatenate (type &rest seqs)
(coerce (apply #'append
(mapcar #'(lambda (seq) (coerce seq 'list))
seqs))
type))
(defun lisp:length (seq)
(cond ((symbolp seq) (flatc seq))
((lisp:arrayp seq) (fill-pointer seq))
(t (length seq))))
;;; Pathnames
(defsubst pathname-host (pathname) (cxr 1 pathname))
(defsubst pathname-device (pathname) (cxr 2 pathname))
(defsubst pathname-directory (pathname) (cxr 3 pathname))
(defsubst pathname-name (pathname) (cxr 4 pathname))
(defsubst pathname-type (pathname) (cxr 5 pathname))
(defsubst pathname-version (pathname) (cxr 6 pathname))
(defsubst pathnamep (thing)
(and (hunkp thing) (eq (cdr thing) 'pathname)))
(defun pathname (thing)
(cond ((pathnamep thing) thing)
((symbolp thing) (parse-namestring thing))
((stringp thing) (parse-namestring (unkludgify-string thing)))
((consp thing)
;; ITS namelist!
(namelist->pathname thing))
(t (error "can't coerce to pathname" thing 'fail-act))))
(defconstant :defaults ':defaults)
(defconstant :host ':host)
(defconstant :device ':device)
(defconstant :directory ':directory)
(defconstant :name ':name)
(defconstant :type ':type)
(defconstant :version ':version)
(defvar *default-pathname-defaults*
(hunk nil nil nil nil nil nil 'pathname))
(defun make-pathname (&rest rest)
(let-keyword-args ((defaults *default-pathname-defaults*)
(host (pathname-host defaults))
(device (pathname-device defaults))
(directory (pathname-directory defaults))
(name (pathname-name defaults))
(type (pathname-type defaults))
(version (pathname-version defaults)))
rest
(hunk host device directory name type version 'pathname)))
(defconstant :newest ':newest)
(defconstant :oldest ':oldest)
(defconstant :wild ':wild)
(defun merge-pathnames (pathname &optional
(defaults *default-pathname-defaults*)
(default-version ':newest))
(let ((pathname (pathname pathname))
(defaults (pathname defaults)))
(hunk (or (pathname-host pathname) (pathname-host defaults))
(or (pathname-device pathname) (pathname-device defaults))
(or (pathname-directory pathname) (pathname-directory defaults))
(or (pathname-name pathname) (pathname-name defaults))
(or (pathname-type pathname) (pathname-type defaults))
(or (pathname-version pathname) default-version (pathname-version defaults))
'pathname)))
;;; [device:] [directory;] name [.type [.version]]
(defun parse-namestring (thing)
(cond ((lisp:arrayp thing)
(parse-namestring (unkludgify-string thing)))
(t
(parse-namestring-aux (coerce thing 'list)))))
(defun parse-namestring-aux (l)
(multiple-value-bind (piece delimiter l)
(get-namestring-piece l '(#\: #\; #\. #\space))
(cond ((null delimiter)
(make-pathname ':name piece))
((char= delimiter #\:)
(make-pathname ':device piece ':defaults (parse-namestring-aux l)))
((char= delimiter #\;)
(make-pathname ':directory piece ':defaults (parse-namestring-aux l)))
(t
(multiple-value-bind (type delimiter l)
(get-namestring-piece l '(#\. #\space))
(make-pathname ':name piece
':type type
':version (if (not delimiter)
nil
(string->version (get-namestring-piece-aux l)))))))))
(defun get-namestring-piece (l delims)
(do ((l l (cdr l))
(z '() (cons (car l) z)))
((null l)
(values (get-namestring-piece-aux (reverse z)) nil '()))
(if (member (car l) delims)
(return (values (get-namestring-piece-aux (reverse z)) (car l) (cdr l))))))
(defun get-namestring-piece-aux (l)
(let ((l (coerce l 'string)))
(cond ((samepnamep l '*) :wild)
((samepnamep l '>) :newest)
((samepnamep l '<) :oldest)
(t l))))
(defun string->version (sym)
(let ((probe (*catch 'foo
(let ((*rset-trap #'(lambda ignore (*throw 'foo nil))))
(readlist (exploden sym))))))
(cond ((not (numberp probe)) sym)
((= probe 0) :newest)
((= probe -1) :oldest)
(t probe))))
(defun pathname-lessp (n1 n2)
(let ((h1 (pathname-host n1))
(h2 (pathname-host n2)))
(or (component-lessp h1 h2)
(and (component-equalp h1 h2)
(let ((d1 (pathname-device n1))
(d2 (pathname-device n2)))
(or (component-lessp d1 d2)
(and (component-equalp d1 d2)
(let ((d1 (pathname-directory n1))
(d2 (pathname-directory n2)))
(or (component-lessp d1 d2)
(and (component-equalp d1 d2)
(let ((a1 (pathname-name n1))
(a2 (pathname-name n2)))
(or (component-lessp a1 a2)
(and (component-equalp a1 a2)
(let ((t1 (pathname-type n1))
(t2 (pathname-type n2)))
(or (component-lessp t1 t2)
(and (component-equalp t1 t2)
(component-lessp (pathname-version n1)
(pathname-version n2))))))))))))))))))
;;; null < string < number [keywords don't figure]
(defun component-lessp (x y)
(cond ((null x) (not (null y)))
((null y) nil)
((symbolp x) (and (symbolp y) (alphalessp x y)))
(t (and (numberp y) (< x y)))))
;;; The following ought to do case-insensitive comparison!!
(defun component-equalp (x y)
(or (equal x y)
(and (symbolp x) (symbolp y) (samepnamep x y))))
;;; Pathname ITSification stuff: coercion between namelists & pathnames.
(defun namelist->pathname (thing)
(let* ((thing (namelist thing))
(v (de-its-ify-component (caddr thing) t)))
(hunk (status site)
(de-its-ify-component (caar thing) nil)
(de-its-ify-component (cadar thing) nil)
(de-its-ify-component (cadr thing) nil)
(if (versionp v) nil v) ;Check file attribute list?
(if (versionp v) v nil)
'pathname)))
(defun de-its-ify-component (x numberp)
numberp ;was useful once, I guess
(cond ((eq x '*) nil)
((null x) "NIL")
((not (symbolp x)) x)
((eq x '>) ':newest)
((eq x '<) ':oldest)
(t (string->version x))))
(defun versionp (x)
(or (numberp x) (eq x ':newest) (eq x ':oldest)))
(defvar *its-uninteresting-types*
'("TXT" "LSP" "LISP" "SCM" "" "txt" "lsp" "lisp" "scm" :unspecific))
(defun pathname->namelist (pathname)
(let ((dev (pathname-device pathname))
(dir (pathname-directory pathname))
(name (pathname-name pathname))
(type (pathname-type pathname))
(version (pathname-version pathname)))
`((,(its-ify-component dev)
,@(if (null (pathname-directory pathname))
'()
`(,(its-ify-component dir))))
,(its-ify-component name)
,(if (or (null type)
(string-member type *its-uninteresting-types*))
(its-ify-component version)
(its-ify-component type)))))
(defun its-ify-component (x)
(cond ((null x) '*)
((eq x ':wild) '*)
((eq x ':newest) '>)
((eq x ':oldest) '<)
(t x)))
(defun string-member (string string-list)
(do ((l string-list (cdr l)))
((null l) nil)
(if (and (symbolp (car l)) (samepnamep string (car l)))
(return l))))
(defun lisp:namestring (thing)
(stringicate (namestring (if (pathnamep thing)
(pathname->namelist thing)
thing))))
;;; I/O routines
(format nil "T") ;Make sure FORMAT is loaded
(defun probe-file (pathname)
(let* ((p (pathname pathname))
(q (probef (pathname->namelist p))))
(and q (merge-pathnames q p nil))))
;;; DIRECTORY: returns a list of pathnames for all local files
;;; matching a given pattern.
(defun lisp:directory (p)
(let ((p (pathname p)))
(cond ((and (not (eq (pathname-device p) ':wild))
(not (eq (pathname-directory p) ':wild))
(not (eq (pathname-name p) ':wild))
(not (eq (pathname-type p) ':wild))
(not (eq (pathname-version p) ':wild)))
(let ((p (probe-file p)))
(if p (list p) '())))
(t
(let* ((p (merge-pathnames p (pathname defaultf) nil))
(p1 (cond ((eq (pathname-version p) ':newest)
(make-pathname :version ':wild
:defaults p))
(t p)))
(n (pathname->namelist p1))
(foo (sort (mapcan #'(lambda (n)
(let ((q (pathname n)))
(if (pathname-matches-p q p)
(list q)
'())))
(allfiles (list n)))
#'pathname-lessp)))
(cond ((eq (pathname-version p) ':newest)
;; Remove all but newest versions from list.
(do ((l (reverse foo)
(do ((ll l (cdr ll)))
((or (null ll)
(not (equal-except-version (car l) (car ll))))
ll)))
(z '() (cons (car l) z)))
((null l) z)))
(t foo)))))))
(defun pathname-matches-p (p q)
(and (component-matches-p (pathname-host p) (pathname-host q))
(component-matches-p (pathname-device p) (pathname-device q))
(component-matches-p (pathname-directory p) (pathname-directory q))
(component-matches-p (pathname-name p) (pathname-name q))
(component-matches-p (pathname-type p) (pathname-type q))
(component-matches-p (pathname-version p) (pathname-version q))))
(defun component-matches-p (x y)
(or (null x)
(null y)
(eq y ':wild)
(and (numberp x) (memq y '(:newest :oldest)))
(component-equalp x y)))
#+clutter-up-address-space
(defun dir (x) ;Test routine for above - arg should be upper case!
(mapc #'(lambda (p)
(format t "~&~7@<~a:~> ~7@<~a;~> ~6a ~6a ~6d"
(pathname-device p)
(pathname-directory p)
(pathname-name p)
(or (pathname-type p) "")
(or (pathname-version p) "")))
(directory (pathname x)))
'*)
(defun equal-except-version (p q)
(and (component-equalp (pathname-host p) (pathname-host q))
(component-equalp (pathname-device p) (pathname-device q))
(component-equalp (pathname-directory p) (pathname-directory q))
(component-equalp (pathname-name p) (pathname-name q))
(component-equalp (pathname-type p) (pathname-type q))))
;;; OPEN and other common-lispy file functions.
(defconstant :direction ':direction)
(defconstant :output ':output)
(defconstant :input ':input)
(defconstant :if-does-not-exist ':if-does-not-exist)
(defconstant :if-exists ':if-exists)
(defconstant :abort ':abort)
(defvar *open-output-files* '()) ;a-list of (<file> . <final-name>)
;;; For opening files only! And in image mode no less!
;;; The only parameter combinations implemented are those needed for
;;; KERMIT!
(defun lisp:open (pathname &rest r)
(let-keyword-args ((direction :input)
(if-does-not-exist 'unsupplied)
(if-exists 'unsupplied))
r
(let ((n (pathname->namelist (pathname pathname))))
(*catch 'fnf
(cond ((eq direction :input)
(let ((io-lossage
(if (null if-does-not-exist)
#'(lambda ignore (*throw 'fnf nil))
io-lossage)))
(open n '(in image block))))
(t
(let* ((io-lossage
(if (null if-exists)
#'(lambda ignore (*throw 'fnf nil))
io-lossage))
(file (open (mergef '((* *) _kerm_ >) n)
'(out image block))))
(push (cons file n) *open-output-files*)
file)))))))
(defun lisp:close (stream &rest r)
(let-keyword-args ((abort nil)) r
(let ((probe (assq stream *open-output-files*)))
(cond ((not probe) (close stream))
(t
(setq *open-output-files* (delq probe *open-output-files*))
(if abort
(delete-file stream)
(rename-file stream (cdr probe))))))))
(defun rename-file (from to)
(renamef from (if (pathnamep to)
(pathname->namelist to)
to)))
(defun delete-file (file)
(deletef (if (pathnamep file)
(pathname->namelist file)
file)))
(defun make-broadcast-stream (&rest streams)
(apply #'append
(mapcar #'(lambda (stream)
(if (atom stream) (list stream) stream))
streams)))
(defsubst end-of-file-p (c) ;Called only on value of +TYI
;; ITS end-of-file
(or (< c 0)
(let ()
(declare (special *image?*))
(and (not *image?*) (= c 3)))))
;;; That's all, folks
(setf (get 'common 'loadedp) t)
;;; Local Modes:
;;; Lisp let-keyword-args Indent:2
;;; End:

1140
src/math/kermit.170 Executable file
View File

File diff suppressed because it is too large Load Diff

33
src/math/kermit.dumper Executable file
View File

@@ -0,0 +1,33 @@
(COMMENT) ; -*- Mode: LISP -*-
;;; To dump, say :LISP MATH; KERMIT DUMPER
(DO ((*PURE T))
(T
(DO ((S (OPEN '((DSK MATH) KERMIT UNFASL))))
(T
(SETQ *KERMIT-SOURCE* (CAR (LAST (CADR (READ S)))))
(CLOSE S)))
(LOAD '((DSK MATH) KERMIT FASL))
(OR (GET 'MLSUB 'VERSION) (LOAD '((LISP) MLSUB FASL)))
(LOAD '((LIBLSP) TIME))))
(DEFUN KERMIT-DUMP ()
(DO ((DD (TIME:PRINT-CURRENT-TIME NIL))
(U (STATUS UNAME)))
(T
(FORMAT T "~&Suspending... ")
(SUSPEND ":KILL " '((DSK MATH) TS KERMIT))
(FORMAT T "~&KERMIT ~A dumped in Lisp ~A by ~A on ~A~%"
(CADDR *KERMIT-SOURCE*) (STATUS LISPV) U DD)
(DEFAULTF (LIST (LIST 'DSK (STATUS HSNAME)) '* '>))
(DO ((I (PROBEF (LIST (LIST 'DSK (STATUS HSNAME))
(STATUS UNAME) 'KERMIT))))
(T
(COND (I
(FORMAT T "Loading ~A" (NAMESTRING I))
(LOAD I)))))
(SERVE)
(QUIT))))
'|Do (KERMIT-DUMP) to dump.|