LISTING FOR  >udd>sm>ds>w>ml>lisp_other_other_
COMPILED BY Multics LISP Compiler, Version 2.13c, July 11, 1983
ON 05/05/00  1835.5 mdt Fri
IN BEHALF OF Schroth.SysMaint.m



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************
;; -*- Mode: Lisp; Lowercase: True -*-

;; Be careful.  lisp_defun_ uses this file, so don't use &mumbles
;; in procedure definitions.
;; setf is needed at runtime since push, pop, etc. expand into it.
;; This file corresponds in part to LSPSRC;UMLMAC on MIT-MC.

(%include defmacro)
(%include macro_macros)
(%include setf)

;; Functional macros.  These should be redefined as open-codable subrs.

(defmacro logand (&rest x) `(boole 1 . ,x))
(defmacro logior (&rest x) `(boole 7 . ,x))
(defmacro logxor (&rest x) `(boole 6 . ,x))
(defmacro lognot (x)       `(boole 10. ,x -1))
  
(defmacro bit-test  (x y) `(not (= (logand ,x ,y) 0)))
(defmacro bit-set   (x y) `(boole 7 ,x ,y))
(defmacro bit-clear (x y) `(boole 2 ,x ,y))

(defmacro fifth   (x) `(car (cddddr ,x)))
(defmacro sixth   (x) `(cadr (cddddr ,x)))
(defmacro seventh (x) `(caddr (cddddr ,x)))
(defmacro eighth  (x) `(cadddr (cddddr ,x)))

(defmacro rest5 (x) `(cdr (cddddr ,x)))
(defmacro rest6 (x) `(cddr (cddddr ,x)))
(defmacro rest7 (x) `(cdddr (cddddr ,x)))
(defmacro rest8 (x) `(cddddr (cddddr ,x)))

(defmacro evenp   (x)   `(not (oddp ,x)))
(defmacro neq     (x y) `(not (eq ,x ,y)))
(defmacro nequal  (x y) `(not (equal ,x ,y)))
(defmacro fixnump (x)   `(eq (typep ,x) 'fixnum))
(defmacro flonump (x)   `(eq (typep ,x) 'flonum))

;; This is now incompatible.  It will make a very bad macro with its new
;; definition, since that definition must also check for NIL.

(defmacro listp (object) `(not (atom ,object)))

(defmacro copylist (list) `(append ,list nil))

(defmacro aref rest `(arraycall t . ,rest))

;; Must be careful of the order of evaluation here.
;; (defmacro aset (val . rest) `(store (aref . ,rest) ,val))
;; will result in "rest" being evaluated before val.  A good open-codable
;; subr mechanism must be able to handle this.

(defmacro aset (val . rest)
	(let ((var (gensym)))
	     `((lambda (,var)
		     (store (arraycall t . ,rest) ,var))
	       ,val)))

;; (<= A B) --> (NOT (> A B))
;; (<= A B C) --> (NOT (OR (> A B) (> B C)))
;; Funny arglist to check for correct number of arguments.

(defmacro <= (arg1 arg2 &rest rest)
  (<=-expander '> (list* arg1 arg2 rest)))

(defun <=-expander (relation args)
  (cond ((null (cddr args))
         `(not (,relation ,(car args) ,(cadr args))))
        (t (do ((l (reverse args) (cdr l))
	      (nargs nil (cons (cond ((and (atom (car l))
				     (or (null vars)
				         (not (symbolp (car l)))))
				(car l))
			         (t (setq vals (cons (car l) vals))
				  (let ((x (gensym)))
				    (setq vars (cons x vars))
				    x)))
			   nargs))
	      (vars nil)
	      (vals nil))
	     ((null l)
	      (do ((l (cdr nargs) (cdr l))
		 (forms (list `(,relation ,(car nargs) ,(cadr nargs)))
		        (cons `(,relation ,(car l) ,(cadr l)) forms)))
		((null (cdr l))
		 (let ((form `(not (or ,.(nreverse forms)))))
		   (cond ((null vars) form)
		         (t `((lambda ,vars ,form) ,.vals)))))))))))

;; (>= A B) --> (NOT (< A B))
;; (>= A B C) --> (NOT (OR (< A B) (< B C)))
;; Funny arglist to check for correct number of arguments.

(defmacro >= (arg1 arg2 &rest rest)
  (<=-expander '< (list* arg1 arg2 rest)))


;; Control structure macros

;; It is important that (IF NIL <FORM>) returns NIL as Macsyma code depends
;; upon this in places.  Macsyma unfortunately also relies on the ability to
;; have multiple else clauses.

(defmacro ITS-if (predicate then &rest else)
          (cond ((null else) `(cond (,predicate ,then) (t nil)))
                (t `(cond (,predicate ,then) (t . ,else)))))

(defmacro ITS-ifn (predicate then &rest else)
	(cond ((null else) `(cond ((not ,predicate) ,then) (t nil)))
	      (t `(cond ((not ,predicate) ,then) (t . ,else)))))

;; For the benefit of people who use the Multics Emacs version of if we try
;; to avoid redefining it if it is already defined.

(eval-when (eval load compile)
	 (cond ((null (get 'if 'macro))
	        (putprop 'if (get 'ITS-if 'macro) 'macro)
	        (putprop 'ifn (get 'ITS-ifn 'macro) 'macro))))

;; Funny arglists so as to do better argument checking.

(defmacro when (predicate then-1 . then-rest)
	`(cond (,predicate ,then-1 . ,then-rest)))

(defmacro unless (predicate then-1 . then-rest)
	`(cond ((not ,predicate) ,then-1 . ,then-rest)))

;; Variations on setf
;; (push a x)     --> (setq x (cons a x))
;; (pop x)        --> (setq x (cdr x))
;; (incf x)       --> (setq x (1+ x))
;; (decf x)       --> (setq x (1- x))
;; (negf x)       --> (setq x (- x))
;; (notf x)       --> (setq x (not x))

(defmacro push (val var) `(setf ,var (cons ,val ,var)))

(defmacro pop (var &optional (into nil into?))
  (if into?
      `(prog1 (setf ,into (car ,var)) (setf ,var (cdr ,var)))
      `(prog1 (car ,var) (setf ,var (cdr ,var)))))

(defmacro incf (counter &optional increment)
  (if increment
      `(setf ,counter (+ ,counter ,increment))
      `(setf ,counter (1+ ,counter))))

(defmacro decf (counter &optional decrement)
  (if decrement
      `(setf ,counter (- ,counter ,decrement))
      `(setf ,counter (1- ,counter))))

(defmacro negf (integer) `(setf ,integer (- ,integer)))
(defmacro notf (switch) `(setf ,switch (not ,switch)))

;; Dispatchers

(defmacro case x `(select . ,x))
(defmacro caseq x `(selectq . ,x))

;; Give (select x ((a b) 3)), (cond ((memq x (list a b)) 3)) is generated.
;; select and select-equal should be rewritten to instead generate
;; (cond ((or (eq x a) (eq x b)) 3)).  This doesn't cons and can save
;; additional computing if "a" and "b" are both forms, and the first case
;; is true.

(defmacro select (var . lists)
  (once-only (var)
    (do ((lists lists (cdr lists))
         (ans nil (cons (cons (cond ((memq (caar lists) '(t otherwise)) t)
			      ((atom (caar lists))
			       `(eq ,var ,(caar lists)))
			      (t `(memq ,var (list . ,(caar lists)))))
			(cdar lists))
		    ans)))
        ((null lists) `(cond . ,(nreverse ans))))))

(defmacro selectq (var . lists)
  (once-only (var)
    (do ((lists lists (cdr lists))
         (ans nil (cons (cons (cond ((memq (caar lists) '(t otherwise)) t)
			      ((atom (caar lists))
			       `(eq ,var ',(caar lists)))
			      (t `(memq ,var ',(caar lists))))
			(cdar lists))
		    ans)))
        ((null lists) `(cond . ,(nreverse ans))))))

;; select-equal and selectq-equal are not found in the LM.
;; they are like select and selectq, but use equal and member
;; JRDavis 19 March 1981

(defmacro select-equal (var . lists)
  (once-only (var)
    (do ((lists lists (cdr lists))
         (ans nil (cons (cons (cond ((memq (caar lists) '(t otherwise)) t)
			      ((atom (caar lists))
			       `(equal ,var ,(caar lists)))
			      (t `(member ,var (list . ,(caar lists)))))
			(cdar lists))
		    ans)))
        ((null lists) `(cond . ,(nreverse ans))))))

(defmacro selectq-equal (var . lists)
  (once-only (var)
    (do ((lists lists (cdr lists))
         (ans nil (cons
		(cons
		  (cond ((memq (caar lists) '(t otherwise)) t)
		        ((atom (caar lists)) `(equal ,var ',(caar lists)))
		        (t `(member ,var ',(caar lists))))
		  (cdar lists))
		ans)))
        ((null lists) `(cond . ,(nreverse ans))))))

(defmacro dotimes ((var form) . body)
	(once-only (form)
               `(do ((,var 0 (1+ ,var)))
                    ((not (< ,var ,form)))
                    . ,body)))

(defmacro dolist ((var form) . body)
          (let ((dum (gensym)))
               `(do ((,dum ,form (cdr ,dum))
		 (,var))
                    ((null ,dum))
                    (setq ,var (car ,dum))
                    . ,body)))

;; Perhaps we should do a code walk over the setq and macroexpand all
;; forms until the compiler is able to do this.  -cwh

(defmacro defconst (var . initp)
  (cond (initp
	`(progn 'compile
	        (declare (special ,var))
	        (setq ,var ,(car initp))))
        (t `(declare (special ,var)))))

(defmacro ITS-defvar (var . initp)
  (cond (initp
	`(progn 'compile
	        (declare (special ,var))
	        (or (boundp ',var)
		  (setq ,var ,(car initp)))))
        (t `(declare (special ,var)))))

;; Just like if we have to be careful about redefining the e-macros defvar.

(eval-when (eval load compile)
	 (cond ((null (get 'defvar 'macro))
	        (putprop 'defvar (get 'ITS-defvar 'macro) 'macro))))

;; (*CATCH 'TAG (COMPUTE)) --> (CATCH (COMPUTE) TAG)
;; This is a kludge to handle the common cases.  This should be implemented
;; correctly in the future.

(defmacro *catch (tag body)
  (cond ((or (memq tag '(t nil))
	   (and (not (atom tag)) (eq (car tag) 'quote)))
         `(catch ,body ,(cadr tag)))
        (t (error "*catch: Tag must be a quoted symbol - " tag
	        'wrng-type-arg))))

(defmacro *throw (tag body)
  (cond ((or (memq tag '(t nil))
	   (and (not (atom tag)) (eq (car tag) 'quote)))
         `(throw ,body ,(cadr tag)))
        (t (error "*throw: Tag must be a quoted symbol - " tag
	        'wrng-type-arg))))

;; This checks for an even number of arguments.

(defmacro psetq (var value . rest)
  (cond (rest `(setq ,var (prog1 ,value (psetq . ,rest))))
        (t `(setq ,var ,value))))

(defmacro lexpr-funcall (function &rest args)
  (cond ((null args) `(funcall ,function))
        ((null (cdr args)) `(apply ,function ,(car args)))
        ((null (cddr args)) `(apply ,function (cons . ,args)))
        (t `(apply ,function (list* . ,args)))))

;; We can't simply write (let ((,var (nointerrupt t))) (unwind-protect ...))
;; Since we may unwind the stack after entering the "let" and before
;; entering the "unwind-protect"

(defmacro without-interrupts (&rest body &aux (var (gensym)))
  `(let ((,var 'not-set-yet))
     (unwind-protect
       (progn (setq ,var (nointerrupt t)) . ,body)
       (unless (eq ,var 'not-set-yet)
	     (nointerrupt ,var)))))

(defmacro without-tty-interrupts (&rest body &aux (var (gensym)))
  `(let ((,var 'not-set-yet))
    (unwind-protect
      (progn (setq ,var (nointerrupt 'tty)) . ,body)
      (unless (eq ,var 'not-set-yet)
	    (nointerrupt ,var)))))

;; This crock is necessary since (open f 'in) and (open f 'out) don't
;; work.  Have to use openi and openo.

;; (defmacro with-open-file ((stream filename options) . body)
;;   `(let ((,stream nil))
;;     (unwind-protect (progn (setq ,stream (open ,filename ,options))
;; 		       . ,body)
;; 		(if ,stream (close ,stream)))))

(defmacro with-open-file ((stream filename options) . body)
  (let ((keyword (cadr options))
        (open-form))
    (setq open-form (cond ((eq keyword 'in)     `(openi ,filename))
		      ((eq keyword 'out)    `(openo ,filename))
		      ((eq keyword 'append) `(opena ,filename))
		      (t `(open ,filename ,options))))
    `(let ((,stream nil))
      (unwind-protect (progn (setq ,stream ,open-form)
		         . ,body)
		  (if ,stream (close ,stream))))))

(defmacro circular-list (&rest args)
  `(let ((x (list . ,args)))
     (rplacd (last x) x)
     x))

(sstatus feature other_other)

INCLUDE FILE >ldd>incl>defmacro.incl.lisp

;; -*- Mode: Lisp; Lowercase: True -*-

;; defmacro.incl.lisp - Loads lisp_backquote_, lisp_destructuring_let_,
;; and lisp_defmacro_ into either the compiler or interpreter environment.
;; Written:  October 1982 by Carl Hoffman

;; Defmacro needs destructuring_let to run.
;; It can run without backquote, but would be useless.

(eval-when (eval compile)
  (or (status feature backquote)
      (load (catenate (car (namelist (truename infile))) ">lisp_backquote_")))
  (or (status feature destructuring_let)
      (load (catenate (car (namelist (truename infile))) ">lisp_destructuring_let_")))
  (or (status feature defmacro)
      (load (catenate (car (namelist (truename infile))) ">lisp_defmacro_"))))

;; This is necessary for (defprop a b macro) forms and defuns produced
;; by defmacro to appear in the object segment.  Let the default be
;; the right thing for naive users.
(declare (macros t))

INCLUDE FILE >ldd>incl>macro_macros.incl.lisp

;; -*- Mode: Lisp; Lowercase: True -*-

;; macro_macros.incl.lisp - Loads lisp_macro_macros_ into either the compiler or
;; interpreter environment.
;; Written:  October 1982 by Carl Hoffman

(eval-when (eval compile)
  (or (status feature macro_macros)
      (load (catenate (car (namelist (truename infile))) ">lisp_macro_macros_"))))

INCLUDE FILE >ldd>incl>setf.incl.lisp

;; -*- Mode: Lisp; Lowercase: True -*-

;; setf.incl.lisp - Loads lisp_setf_ into either the compiler or
;; interpreter environment.
;; Written:  October 1982 by Carl Hoffman

(eval-when (eval compile)
  (or (status feature setf)
      (load (catenate (car (namelist (truename infile))) ">lisp_setf_"))))

			Functions Defined

Name			Offset		Offset		Name


*catch macro                     5546		   0		logand macro
*throw macro                     5651		   30		logior macro
<= macro                         1706		   60		logxor macro
<=-expander                      1770		   110		lognot macro
>= macro                         2211		   160		bit-test macro
ITS-defvar macro                 5401		   247		bit-set macro
ITS-if macro                     2273		   322		bit-clear macro
ITS-ifn macro                    2407		   376		fifth macro
aref macro                       1555		   447		sixth macro
aset macro                       1602		   520		seventh macro
bit-clear macro                  322		   571		eighth macro
bit-set macro                    247		   642		rest5 macro
bit-test macro                   160		   713		rest6 macro
case macro                       3531		   764		rest7 macro
caseq macro                      3550		   1035		rest8 macro
circular-list macro              6660		   1105		evenp macro
copylist macro                   1511		   1156		neq macro
decf macro                       3275		   1234		nequal macro
defconst macro                   5261		   1312		fixnump macro
dolist macro                     5114		   1365		flonump macro
dotimes macro                    4721		   1440		listp macro
eighth macro                     571		   1511		copylist macro
evenp macro                      1105		   1555		aref macro
fifth macro                      376		   1602		aset macro
fixnump macro                    1312		   1706		<= macro
flonump macro                    1365		   1770		<=-expander
incf macro                       3163		   2211		>= macro
lexpr-funcall macro              6057		   2273		ITS-if macro
listp macro                      1440		   2407		ITS-ifn macro
logand macro                     0		   2541		when macro
logior macro                     30		   2626		unless macro
lognot macro                     110		   2722		push macro
logxor macro                     60		   3000		pop macro
negf macro                       3407		   3163		incf macro
neq macro                        1156		   3275		decf macro
nequal macro                     1234		   3407		negf macro
notf macro                       3460		   3460		notf macro
pop macro                        3000		   3531		case macro
psetq macro                      5754		   3550		caseq macro
push macro                       2722		   3567		select macro
rest5 macro                      642		   4011		selectq macro
rest6 macro                      713		   4244		select-equal macro
rest7 macro                      764		   4466		selectq-equal macro
rest8 macro                      1035		   4721		dotimes macro
select macro                     3567		   5114		dolist macro
select-equal macro               4244		   5261		defconst macro
selectq macro                    4011		   5401		ITS-defvar macro
selectq-equal macro              4466		   5546		*catch macro
seventh macro                    520		   5651		*throw macro
sixth macro                      447		   5754		psetq macro
unless macro                     2626		   6057		lexpr-funcall macro
when macro                       2541		   6206		without-interrupts macro
with-open-file macro             6442		   6324		without-tty-interrupts macro
without-interrupts macro         6206		   6442		with-open-file macro
without-tty-interrupts macro     6324		   6660		circular-list macro





			Functions Referenced

<=-expander                             gensym                                  nreverse
displace                                length                                  reverse
error                                                                           


                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL
and BULL HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture 
for managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by BULL HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved