mirror of
https://github.com/PDP-10/its.git
synced 2026-04-02 12:19:14 +00:00
100 lines
2.7 KiB
Common Lisp
Executable File
100 lines
2.7 KiB
Common Lisp
Executable File
;;; -*- Mode:LISP; -*-
|
||
|
||
;;; Macro support for the world
|
||
|
||
(declare (special *in-more-break*))
|
||
|
||
;;; CATCH-**MORE**
|
||
;;; Catch a throw to flush output after a **MORE**.
|
||
|
||
(defmacro catch-**more** (&body body)
|
||
`(*catch '*can-flush-more*
|
||
(let ((*can-flush-more* t))
|
||
(declare (special *can-flush-more*))
|
||
,@body)))
|
||
|
||
;;; DONT-CATCH-**MORE**
|
||
|
||
(defmacro dont-catch-**more** (&body body)
|
||
`(let ((*can-flush-more* nil))
|
||
(declare (special *can-flush-more*))
|
||
,@body))
|
||
|
||
;;; Top level place to go when have problems.
|
||
|
||
(defmacro catch-complaints (&body body)
|
||
`(*catch 'complaint-handler
|
||
(let ((*complaint-handler* t))
|
||
(declare (special *complaint-handler*))
|
||
,@body)))
|
||
|
||
;;; Use system's old obarray
|
||
|
||
(defmacro with-saved-obarray (&body body)
|
||
`(let ((obarray (or (get 'obarray 'saved-obarray) obarray)))
|
||
,@body))
|
||
|
||
;;; File hacking if on TOPS-20
|
||
(eval-when (eval compile load)
|
||
(cond ((status feature TOPS-20)
|
||
(putprop 'teach '(ps kmp/.teach) 'ppn)
|
||
(putprop 'teach '(ps kmp/.teach) 'ppn))))
|
||
|
||
;;; Loading in of system files
|
||
|
||
(defmacro load-module (name &optional (when '(eval load)))
|
||
(let ((inside `(cond ((not (get ',name 'version))
|
||
(load '((teach) ,name))))))
|
||
(cond ((or (equal when '(eval load))
|
||
(equal when '(load eval)))
|
||
inside)
|
||
(t `(eval-when ,when ,inside)))))
|
||
|
||
;;;; Interrupt character functions.
|
||
|
||
(defmacro define-interrupt-handler (name &body body)
|
||
(let ((stream-var (gensym))
|
||
(char-var (gensym)))
|
||
`(progn 'compile
|
||
(defun ,name (,stream-var ,char-var)
|
||
(declare (special *complaint-handler*))
|
||
(clear-input ,stream-var)
|
||
(program-record "User typed ~@:C (~S).~%" ,char-var ',name)
|
||
(cond ((not *disallow-interrupts*)
|
||
(let ((*disallow-interrupts* t))
|
||
(nointerrupt nil)
|
||
(catch-complaints
|
||
(catch-**more** ,@body))
|
||
(print '*)
|
||
(terpri)
|
||
(if *complaint-handler* ;maybe quietly return...
|
||
(complain))))
|
||
(*in-more-break* nil)
|
||
(t
|
||
(recorded-output "~2&Don't type ~@:C when I'm busy~2%"
|
||
,char-var)))))))
|
||
|
||
|
||
;;; (WHEN-ABNORMAL-EXIT exp form1 form2 form3 ...)
|
||
;;;
|
||
;;; Executes exp, returning its value.
|
||
;;; If an abnormal exit is done from exp, form1, form2, ... are executed.
|
||
|
||
(defmacro when-abnormal-exit (exp &body abnormal-exit-forms)
|
||
(let ((var (gensym)))
|
||
`(let ((,var t))
|
||
(unwind-protect (prog1 ,exp (setq ,var nil))
|
||
(cond (,var ,@abnormal-exit-forms))))))
|
||
|
||
(defmacro cautiously-incrementing-filepos (file &body body)
|
||
`(let ((old-filepos (filepos ,file)))
|
||
(when-abnormal-exit (progn ,@body)
|
||
(filepos ,file old-filepos))))
|
||
|
||
;;; Local Modes:;
|
||
;;; Mode:LISP;
|
||
;;; Lisp WHEN-ABNORMAL-EXIT Indent:1;
|
||
;;; Lisp CAUTIOUSLY-INCREMENTING-FILEPOS:1;
|
||
;;; End:;
|
||
|