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