LISTING FOR >udd>sm>ds>w>ml>lisp_setf_ COMPILED BY Multics LISP Compiler, Version 2.13c, July 11, 1983 ON 05/05/00 1835.7 mdt Fri IN BEHALF OF Schroth.SysMaint.m ;; -*- Mode: Lisp; Lowercase: True -*- (%include defmacro) (defmacro setf (form val) (do ((form form (funcall mfun form)) (mfun)) ((atom form) `(setq ,form ,val)) (let ((fun (car form))) (or (symbolp fun) (error "Barf! Can't setf this: " form 'fail-act)) (cond ((setq mfun (get fun 'setf)) (return (funcall mfun form val))) ((setq mfun (get fun 'macro))) (t (error "Barf! Can't find macro or setf property for " fun 'fail-act)))))) (defmacro defsetf (fun pat var . body) (let ((arg (gensym)) (name (intern (make_atom (catenate fun " setf"))))) `(progn 'compile (defprop ,fun ,name setf) (defun ,name (,arg ,var) (let ((,pat (cdr ,arg))) . ,body))))) (defsetf car (x) y `(rplaca ,x ,y)) (defsetf cdr (x) y `(rplacd ,x ,y)) (defsetf get (x y) z `(putprop ,x ,z ,y)) (defsetf plist (x) y `(setplist ,x ,y)) (defsetf symeval (x) y `(set ,x ,y)) (defsetf args (x) y `(args ,x ,y)) (defsetf arg (n) y `(setarg ,n ,y)) (defsetf arraycall rest y `(store (arraycall . ,rest) ,y)) (defsetf nth (i x) y `(rplaca (nthcdr ,i ,x) ,y)) (defsetf ldb (ppss x) y `(setf ,x (dpb ,y ,ppss ,x))) (defsetf status (x) y `(sstatus ,x ,y)) (declare (eval (read))) (defmacro defcxxr (sym) (let ((p (get_pname sym))) (let ((rplac (cond ( (= (getcharn p 2) 141) ;#/a 'rplaca) (t 'rplacd))) (cr (intern (make_atom (catenate "c" (substr p 3 (- (stringlength p) 3)) "r"))))) `(progn 'compile (defprop ,sym (,rplac . ,cr) setf-cxxr) (defprop ,sym setf-cxxr-er setf))))) (defun setf-cxxr-er (form newval) (let ((pair (get (car form) 'setf-cxxr))) `(,(car pair) (,(cdr pair) ,(cadr form)) ,newval))) (defcxxr caar) (defcxxr cadr) (defcxxr cdar) (defcxxr cddr) (defcxxr caaar) (defcxxr caadr) (defcxxr cadar) (defcxxr caddr) (defcxxr cdaar) (defcxxr cdadr) (defcxxr cddar) (defcxxr cdddr) (defcxxr caaaar) (defcxxr caaadr) (defcxxr caadar) (defcxxr caaddr) (defcxxr cadaar) (defcxxr cadadr) (defcxxr caddar) (defcxxr cadddr) (defcxxr cdaaar) (defcxxr cdaadr) (defcxxr cdadar) (defcxxr cdaddr) (defcxxr cddaar) (defcxxr cddadr) (defcxxr cdddar) (defcxxr cddddr) (defprop first car/ setf setf) (defprop rest1 cdr/ setf setf) (defprop second (rplaca . cdr) setf-cxxr) (defprop rest2 (rplacd . cdr) setf-cxxr) (defprop third (rplaca . cddr) setf-cxxr) (defprop rest3 (rplacd . cddr) setf-cxxr) (defprop fourth (rplaca . cdddr) setf-cxxr) (defprop rest4 (rplacd . cdddr) setf-cxxr) (defprop second setf-cxxr-er setf) (defprop third setf-cxxr-er setf) (defprop fourth setf-cxxr-er setf) (defprop rest2 setf-cxxr-er setf) (defprop rest3 setf-cxxr-er setf) (defprop rest4 setf-cxxr-er setf) (sstatus feature setf) 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)) Functions Defined Name Offset Offset Name arg setf 471 0 setf macro args setf 453 150 defsetf macro arraycall setf 507 336 car setf car setf 336 354 cdr setf cdr setf 354 372 get setf defsetf macro 150 417 plist setf get setf 372 435 symeval setf ldb setf 564 453 args setf nth setf 532 471 arg setf plist setf 417 507 arraycall setf setf macro 0 532 nth setf setf-cxxr-er 636 564 ldb setf status setf 620 620 status setf symeval setf 435 636 setf-cxxr-er Functions Referenced catenate funcall intern displace gensym length error get make_atom funcall ----------------------------------------------------------- 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