LISTING FOR >udd>sm>ds>w>ml>lisp_defun_ COMPILED BY Multics LISP Compiler, Version 2.13c, July 11, 1983 ON 05/05/00 1835.2 mdt Fri IN BEHALF OF Schroth.SysMaint.m ;;; ************************************************************** ;;; * * ;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 * ;;; * * ;;; ************************************************************** ;; -*- Mode: Lisp; Lowercase: True -*- (%include defmacro) (%include other_other) (declare (*expr let-macro-flush-declares let-macro-cons-declares)) (declare (*expr grok-&keyword-list)) (declare (special *body* *normal* *optional* *rest*)) (defmacro defun& (name args . body) (let ((twoprop nil) (prop 'expr) tem) (cond ((symbolp name) (cond ((symbolp args) (cond ((memq args '(expr fexpr macro)) (setq prop args) (setq args (car body)) (setq body (cdr body))) ((memq name '(expr fexpr macro)) (setq prop name) (setq name args) (setq args (car body)) (setq body (cdr body))))) ((atom args) (error "Bad second argument to defun: " args 'fail-act)))) ((atom name) (error "Bad first argument to defun: " name 'fail-act)) (t (setq tem (intern (make_atom (catenate (car name) " " (cadr name))))) (setq twoprop `(defprop ,(car name) ,tem ,(cadr name))) (setq name tem))) (if (null twoprop) (defun&-internal name args body prop) `(progn 'compile ,twoprop ,(defun&-internal name args body prop))))) (defun defun&-internal (name args body prop) (if (atom args) `(defprop ,name (lambda ,args . ,body) ,prop) (let (*body* *normal* *optional* *rest*) (grok-&keyword-list args (let-macro-flush-declares body)) (cond ((and (null *rest*) (null *optional*)) (do ((l *normal* (cdr l)) (newargs nil) (ignr nil) (ll nil) (gen)) ((null l) (or (null ll) (setq *body* `((let ,ll . ,*body*)))) `(defprop ,name (lambda ,newargs . ,(let-macro-cons-declares body `((comment args = ,args) ,.ignr . ,*body*))) ,prop)) (cond ((null (car l)) (setq gen (gensym)) (push gen newargs) (push gen ignr)) ((symbolp (car l)) (push (car l) newargs)) ((atom (car l)) (error "Illegal argument (defun): " (car l) 'fail-act)) (t (setq gen (gensym)) (push gen newargs) (push `(,(car l) ,gen) ll))))) (t (let ((n+o (+ (length *normal*) (length *optional*))) (n (length *normal*)) (nargs (gensym))) (or (null *rest*) (setq *body* `((let ((,*rest* ,(if (zerop n+o) `(listify ,nargs) `(and (> ,nargs ,n+o) (listify (- ,n+o ,nargs)))))) . ,*body*)))) (do ((l *optional* (cdr l)) (j n+o (1- j)) (ps nil)) ;; plural of p (as in lessp) ((null l) (or (null ps) (setq *body* `((let ,ps .,*body*))))) (setq *body* `((let ((,(caar l) (cond ((> ,nargs ,(1- j)) ,@(or (null (cddar l)) (progn (push (caddar l) ps) `((setq ,(caddar l) t)))) (arg ,j)) (t ,(cadar l))))) . ,*body*)))) (do ((l *normal* (cdr l)) (j n (1- j)) (ll nil `((,(car l) (arg ,j)) . ,ll))) ((null l) (or (null ll) (setq *body* `((let ,ll . ,*body*)))))) (setq *body* `(,@(if (null *rest*) `((and ,(if (zerop n) `(> ,nargs ,n+o) `(or (< ,nargs ,n) (> ,nargs ,n+o))) (error "Wrong number of arguments: " (list ',name ,nargs) 'fail-act))) (or (zerop n) `((and (< ,nargs ,n) (error "Wrong number of arguments: " (list ',name ,nargs) 'fail-act))))) . ,*body*)) (setq *body* (let-macro-cons-declares body `((comment args = ,args) . ,*body*))) `(defprop ,name (lambda ,nargs . ,*body*) ,prop))))))) (putprop 'defun (get 'defun& 'macro) 'macro) (sstatus feature defun) 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>other_other.incl.lisp ;; -*- Mode: Lisp; Lowercase: True -*- ;; other_other.incl.lisp - Loads lisp_setf_ and lisp_other_other_ 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_"))) (or (status feature other_other) (load (catenate (car (namelist (truename infile))) ">lisp_other_other_")))) Functions Defined Name Offset Offset Name defun& macro 0 0 defun& macro defun&-internal 245 245 defun&-internal Functions Referenced append gensym let-macro-cons-declares catenate grok-&keyword-list let-macro-flush-declares defun&-internal intern make_atom displace length nconc 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