display_lisp_object_segment.pl1 11/20/86  1414.6r w 11/20/86  1145.0      135270



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1982 *
   *                                                            *
   ************************************************************** */
display_lisp_object_segment:
dlos:	proc options (variable);

/* BSG 5/13/80 */

/* declarations */

dcl  BAD_CHARS char (32) static init ("() |/'`#;.,""
") options (constant);
dcl  error_table_$badopt ext static fixed bin (35);
dcl (null, length, substr, addr, addrel, ltrim, copy, search) builtin;
dcl (actionx, linkx, arrayx, subrx, quotx, constx, action_count, action_type) fixed bin;
dcl (n_fixnums, n_flonums, n_strings, n_bignums, n_conses, n_atsyms) fixed bin;
dcl (entryp, tempp, actionp, segp, defp, constp, blockp, arrayp, linkp, sblkp, bigp, symrtp) ptr;
dcl  bc fixed bin (24);
dcl  segtop fixed bin (18);
dcl  argno fixed bin;
dcl  dir char (168), ent char (32);
dcl  code fixed bin (35), arg char (argl) based (argp),
     argp ptr, argl fixed bin (21), myname char (32) init ("display_lisp_object_segment") static options (constant);
dcl (doing_constants, doing_subr_links, doing_array_links) bit (1);


dcl  unalconst fixed bin (17) unaligned automatic;
dcl  1 constant_index_format aligned structure,
      2 load_time bit(1) unaligned,
      2 constant_x fixed bin(16) unaligned;

dcl 1 array_info unaligned,
    2 type fixed bin (9) unsigned,
    2 ndims fixed bin (9) unsigned,
    2 sym_offset fixed bin (17) unaligned;

dcl 1 link_info unaligned,		/* format of 27 info bits in an ITP link */
    2 fcn_offset fixed bin(14),	/* signed offset from ap or lp of function */
    2 snap bit(1),			/* 1 if link can (should) be snapped */
    2 constant bit(1),		/* 1 if fcn_offset is offset from lp of atom */
    2 fsubr bit(1),			/* 1 for fsubr, 0 for subr/lsubr */
    2 nargs fixed bin (9) unsigned;	/* 777 if arg count is in x5, else arg count */

dcl 1 oi aligned like object_info;
dcl 1 sroot aligned like symbol_root based (symrtp);
dcl 1 bignum aligned like lisp_bignum based (bigp);


dcl  cu_$arg_ptr  entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  expand_pathname_  entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate_count  entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl get_definition_ entry (ptr, char(*), char(*), ptr, fixed bin(35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl object_info_$brief  entry (ptr, fixed bin(24), ptr, fixed bin(35));
dcl (ioa_, com_err_) entry options (variable);

%include definition;
%include object_info;
%include lisp_bignum_fmt;
%include lisp_symb_tree;
%include std_symbol_header;

	doing_constants, doing_array_links, doing_subr_links = "0"b;
	call cu_$arg_ptr (1, argp, argl, code);
	if code ^= 0 then do;
	     call com_err_ (code, myname, "Usage: dlos <PATH>");
	     return;
	end;
	call expand_pathname_ (arg, dir, ent, code);
	if code ^= 0 then do;
	     call com_err_ (code, myname, "^a", arg);
	     return;
	end;
	do argno = 2 by 1;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code = 0 then do;
		if arg = "-long" | arg = "-lg" | arg = "-all" | arg = "-a"
		     then doing_constants, doing_array_links, doing_subr_links = "1"b;
		else if arg = "-constant" | arg = "-constants" | arg = "-c"
		| arg = "-cc" | arg = "-compiled_constants" then doing_constants = "1"b;
		else if arg = "-l" | arg = "-lk" | arg = "link" | arg = "-links" then doing_subr_links = "1"b;
		else if arg = "-subr" | arg = "-s" | arg = "-subr_links" | arg = "-sl" then doing_subr_links = "1"b;
		else if arg = "-array" | arg = "-array_links" | arg = "-al" then doing_array_links = "1"b;
		else do;
		     call com_err_ (error_table_$badopt, myname, "^a", arg);
		     return;
		end;
	     end;
	     else go to no_more_args;
	end;
no_more_args:
	call hcs_$initiate_count (dir, ent, "", bc, 0, segp, code);
	if segp = null () then do;
	     call com_err_ (code, myname, "^a>^a", dir, ent);
	     return;
	end;

/*  Get symbol table */

	oi.version_number = object_info_version_2;
	call object_info_$brief (segp, bc, addr (oi), code);
	if code ^= 0 then do;
	     call com_err_ (code, myname, "^a>^a", dir, ent);
	     go to term;
	end;
	call get_definition_ (oi.defp, ent, "*segtop", defp, code);
	if code ^= 0 then do;
	     call com_err_ (code, myname, "*segtop in ^a>^a", dir, ent);
	     go to term;
	end;
	segtop = fixed (rel (addrel (oi.textp, defp -> definition.value)), 18);
	call get_definition_ (oi.defp, ent, "symbol_table", defp, code);
	if code ^= 0 then do;
	     call com_err_ (code, myname, "symbol_table in ^a>^a", dir, ent);
	     go to term;
	end;
	sblkp = addrel (oi.symbp, defp -> definition.value);
	if sblkp -> std_symbol_header.generator ^= "lisp" then do;
	     call com_err_ (0, myname, "Not a Lisp object segment: ^a>^a", dir, ent);
	     go to term;
	end;
	if sblkp -> std_symbol_header.gen_number ^= 2 then do;
	     call com_err_ (0, myname, "Version ^d Lisp object seg not supported.", sblkp -> std_symbol_header.gen_number);
	     go to term;
	end;

/* Do it */

	symrtp = addrel (sblkp, sblkp -> std_symbol_header.area_pointer);
	subrx = 1;
	entryp = addrel (symrtp, sroot.entry_blockp);
	n_fixnums = addrel (symrtp, sroot.objects.fixnum_blockp) -> fixnum_block.count;
	n_flonums = addrel (symrtp, sroot.objects.flonum_blockp) -> flonum_block.count;
	n_strings = addrel (symrtp, sroot.objects.string_blockp) -> string_block.count;
	n_bignums = addrel (symrtp, sroot.objects.bignum_blockp) -> bignum_block.count;
	n_atsyms = addrel (symrtp, sroot.objects.atsym_blockp) -> atsym_block.count;
	n_conses = addrel (symrtp, sroot.objects.cons_blockp) -> cons_block.count;

	blockp = addrel (symrtp, sroot.objects.atsym_blockp);
	do quotx = 1 to n_atsyms;
	     tempp = addrel (symrtp, blockp -> atsym_block.atsym_offset (quotx));
	     if tempp -> string_chars.chars = "quote" then do;
		quotx = quotx + n_fixnums + n_flonums + n_strings + n_bignums;
		go to got_quotx;
	     end;
	end;
         quotx = -1;
got_quotx:
	actionp = addrel (symrtp, sroot.action_blockp);
	action_count = actionp -> action_block.count;
	if segtop ^= 0 then call ioa_ ("^a at offset ^o in segment", ent, segtop);
	call ioa_ ("^d action^[s^] defined:^/", action_count, action_count ^= 1);
	do actionx = 1 to action_count;
	     action_type = actionp -> action_block.actions (actionx).action_code;
	     if action_type = 0 then do;
		call ioa_ ("^3d  EVAL: ^a", actionx, get_prinrep ((actionp -> action_block.actions (actionx).operand)));
	     end;
	     else do;
		call ioa_ ("^3d ^[ SUBR^;LSUBR^;FSUBR^]: ^a^30t^[^d arg^[s^] ^;^s^s^]@^o^[ (^o in seg)^]",
		     actionx, action_type, get_prinrep ((actionp -> action_block.actions (actionx).operand)),
		     action_type = 1,
		     fixed (entryp -> entry_block.entry_info.nargs (subrx), 18),
		     fixed (entryp -> entry_block.entry_info.nargs (subrx), 18) ^= 1,
		     fixed (entryp -> entry_block.entry_info.entrypoint (subrx), 18),
		     (segtop ^=0),
		     fixed (entryp -> entry_block.entry_info.entrypoint (subrx), 18) + segtop);
		subrx = subrx + 1;
	     end;
	end;

	constp = addrel (symrtp, sroot.const_blockp);

	if doing_subr_links then do;
	     linkp = addrel (symrtp, sroot.links_blockp);
	     if linkp -> links_block.count = 0 then call ioa_ ("^/No subr links.");
	     else do;
		call ioa_ ("^/^d subr link^[s^]:^/", linkp -> links_block.count,
		     linkp -> links_block.count ^= 1);
		do linkx = 1 to linkp -> links_block.count;
		     
		     unspec (link_info) = linkp -> links_block.link_info (linkx);
		     if link_info.constant
		     then call ioa_ ("lp|^o^8t^a^[ ^^SNAP^]^[^30t(fsubr)^]^[^30t(lsubr)^]^[^30t^d arg^[s^]^]",
			2 * (linkx + constp -> const_block.count) - 1,
			get_prinrep ((constp -> const_block.constants ((link_info.fcn_offset+1)/2))),
			^link_info.snap, link_info.fsubr, (link_info.nargs = 511),
			^(link_info.fsubr|(link_info.nargs = 511)),
			link_info.nargs, link_info.nargs ^= 1);
		     else call ioa_ ("lp|^o^8tap|^o ^[ ^^SNAP^]^[^30t(fsubr)^]^[^30t(lsubr)^]^[^30t^d arg^[s^]^]",
			2 * (linkx + constp -> const_block.count) - 1,
			link_info.fcn_offset,
			^link_info.snap, link_info.fsubr, (link_info.nargs = 511),
			^(link_info.fsubr|(link_info.nargs = 511)),
			link_info.nargs, link_info.nargs ^= 1);
		end;
	     end;
	end;

	if doing_array_links then do;
	     arrayp = addrel (symrtp, sroot.array_links_blockp);
	     if arrayp -> array_links_block.count = 0 then call ioa_ ("^/No array links.^/");

	     else do;
		call ioa_ ("^/^d array link^[s^]:^/", arrayp -> array_links_block.count,
		     arrayp -> array_links_block.count ^= 1);
		do arrayx = 1 to arrayp -> array_links_block.count;
		     unspec (array_info) = arrayp -> array_links_block.array_link.control_word (arrayx);
		     call ioa_ ("lp|^o^8t^a^30t^d dim^[s^; ^] ^[Lisp objects^;nongc^;fixnum^;flonum^]",
			2 * (addrel (symrtp, sroot.const_blockp) -> const_block.count
			+ addrel (symrtp, sroot.links_blockp) -> links_block.count) -1
			+ 4 * arrayx,
			get_prinrep ((constp -> const_block.constants((array_info.sym_offset + 1)/2))),
			array_info.ndims, array_info.ndims ^= 1,
			array_info.type + 1);
		end;
	     end;
	end;

	if doing_constants then do;
	     if constp -> const_block.count = 0 then call ioa_ ("^/No subr-block constants.^/");
	     else call ioa_ ("^/^d subr-block constant^[s^]:^/",
		constp -> const_block.count, constp -> const_block.count ^= 1);
	     do constx = 1 to constp -> const_block.count;
		unalconst = constp -> const_block.constants (constx);
		unspec (constant_index_format) = unspec (unalconst);
		call ioa_ ("lp|^o^8t^[LOAD TIME: ^]^a", 2 * constx - 1,
		     constant_index_format.load_time, get_prinrep ((constant_index_format.constant_x)));
	     end;
	end;

term:	call hcs_$terminate_noname (segp, (0));

get_prinrep:
	 proc (a_x) returns (char (*));
dcl x fixed bin;
dcl a_x fixed bin;
dcl fvar char (40) varying;
dcl ioa_$rsnnl entry options (variable);
dcl requote_string_ entry (char (*)) returns (char (*));
dcl (car, cdr) fixed bin;
dcl zlflag bit (1);
dcl ncons fixed bin;
dcl cv_bin_$oct  entry (fixed bin) returns (char (12) aligned);

	 zlflag = "1"b;
	 go to join;
get_prinrep_cdr:
	  entry (a_x) returns (char (*));
	  x = a_x;
	  if x <= n_fixnums + n_flonums + n_strings + n_bignums + n_atsyms then do;
	       return (" . " || get_prinrep (x) || ")");
	  end;
	  zlflag = "0"b;
join:
	 x = a_x;
	 if x = 0 then return ("nil");
	 if x <= n_fixnums then do;
	      blockp = addrel (symrtp, sroot.objects.fixnum_blockp);
	      return (ltrim (cv_bin_$oct ((blockp -> fixnum_block.fixnums (x)))));
	 end;
	 x = x - n_fixnums;
	 if x <= n_flonums then do;
	      blockp = addrel (symrtp, sroot.objects.flonum_blockp);
	      call ioa_$rsnnl ("^f", fvar, (0), blockp -> flonum_block.flonums (x));
	      return (fvar);
	 end;
	 x = x - n_flonums;
	 if x <= n_strings then do;
	      blockp = addrel (symrtp, sroot.objects.string_blockp);
	      tempp = addrel (symrtp, blockp -> string_block.string_offset(x));
	      return (requote_string_ (tempp -> string_chars.chars));
	 end;
	 x = x - n_strings;
	 if x <= n_bignums then do;
	      blockp = addrel (symrtp, sroot.objects.bignum_blockp);
	      bigp = addrel (symrtp, blockp -> bignum_block.bignum_offsets (x));
	      return (bigna_representer ());
	 end;
	 x = x - n_bignums;
	 if x <= n_atsyms then do;
	      blockp = addrel (symrtp, sroot.objects.atsym_blockp);
	      tempp = addrel (symrtp, blockp -> atsym_block.atsym_offset (x));
	      if search (tempp -> string_chars.chars, BAD_CHARS) ^= 0
		 then return (hairy_atom (tempp -> string_chars.chars));
	      else return (tempp -> string_chars.chars);
hairy_atom:      proc (s) returns (char (*));
dcl s char (*), (sl, cx) fixed bin (24);
	       sl = length (s);
	       if sl = 0 then return ("");
	       cx = search (s, BAD_CHARS);
	       if cx = 0 then return (s);
	       if cx = 1 & sl = 1 then return ("/" || s);
	       if cx = 1 then return ("/" || substr (s, 1, 1) || hairy_atom (substr (s, 2)));
	       if cx = sl then return (substr (s, 1, cx - 1) || "/" || substr (s, sl, 1));
	       else return (substr (s, 1, cx -1) || "/" || substr (s, cx, 1) || hairy_atom (substr (s, cx + 1)));
	  end;
	 end;
	 x = x - n_atsyms;
	 blockp = addrel (symrtp, sroot.objects.cons_blockp);
	 car = blockp -> cons_block.conses (x).car;
	 cdr = blockp -> cons_block.conses (x).cdr;
	 if car = quotx then do;
	      ncons = cdr - n_fixnums - n_flonums - n_bignums - n_strings - n_atsyms;
	      if ncons > 0 then if blockp -> cons_block.conses (ncons).cdr = 0
		 then return ("'" || get_prinrep ((blockp -> cons_block.conses (ncons).car)));
	 end;
	 if zlflag then
	      if cdr = 0 then return ("(" || get_prinrep (car) || ")");
	      else return ("(" || get_prinrep (car) || get_prinrep_cdr (cdr));
	 else
	      if cdr = 0 then return (" " || get_prinrep (car) || ")");
	      else return (" " || get_prinrep (car) || get_prinrep_cdr (cdr));


bigna_representer:
	 proc () returns (char (*));

dcl (octwds, decwds) (0:bignum.prec-1) fixed bin (35);
dcl (octdigs, decdigs) char (12*bignum.prec + 5);
dcl (octrem, decrem) fixed bin (35);
dcl DIGITS char (10) init ("0123456789") static options (constant);
dcl (octx, decx) fixed bin (21);
dcl (octz, decz) bit (1) aligned;
dcl wordx fixed bin (18);

	 octx = length (octdigs);
	 decx = length (decdigs);
	 do wordx = 1 to bignum.prec;
	      octwds (bignum.prec - wordx), decwds (bignum.prec - wordx) = bignum.words (wordx);
	 end;
	 decz, octz = "0"b;
	 do while (^decz | ^octz);
	      if ^octz then do;
		 call divider (octz, octwds, octrem, 8);
		 substr (octdigs, octx, 1) = substr (DIGITS, octrem + 1, 1);
		 octx = octx - 1;
	      end;
	      if ^decz then do;
		 call divider (decz, decwds, decrem, 10);
		 substr (decdigs, decx, 1) = substr (DIGITS, decrem + 1, 1);
		 decx = decx - 1;
	      end;
	 end;
	 if bignum.sign then
	      substr (decdigs, decx, 1), substr (octdigs, octx, 1) = "-";
	 else do;
	      decx = decx + 1;
	      octx = octx + 1;
	 end;

	 if index (substr (decdigs, decx),
	      copy ("0", (length (decdigs) - decx)/3)) ^= 0
	      | index (substr (decdigs, decx),
	      copy ("9", (length (decdigs) - decx)/3)) ^= 0
	      then return (substr (decdigs, decx) || ".");
	 else return (substr (octdigs, octx));

divider:	  proc (done, words, rem, base);

dcl done bit (1) aligned;
dcl buf fixed bin (71);
dcl x fixed bin;
dcl words (0:*) fixed bin (35);
dcl rem fixed bin (35);
dcl saw_nzq bit (1);
dcl base fixed bin;

	  saw_nzq = "0"b;
	  rem = 0;
	  do x = 0 to hbound (words, 1);
	       buf = fixed (bit (rem, 35) || bit (words (x), 35), 70);
	       words (x) = divide (buf, base, 71, 0);
	       rem = mod (buf, base);
	       if words (x) ^= 0 then saw_nzq = "1"b;
	  end;
	  if ^saw_nzq then done = "1"b;
       end divider;
  end bigna_representer;

 end get_prinrep;
     end;






		    lisp_backquote_.lisp            07/06/83  0938.4r w 06/29/83  1542.9       74304



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************
;; -*- Lisp -*-

;;;BACKQUOTE:
;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
;;;
;;;   |`,|: [a] => a
;;;    NIL: [a] => a              ;the NIL flag is used only when a is NIL
;;;      T: [a] => a              ;the T flag is used when a is self-evaluating
;;;  QUOTE: [a] => (QUOTE a)
;;; APPEND: [a] => (APPEND . a)
;;;  NCONC: [a] => (NCONC . a)
;;;   LIST: [a] => (LIST . a)
;;;  LIST*: [a] => (LIST* . a)
;;;
;;; The flags are combined according to the following set of rules:
;;;  ([a] means that a should be converted according to the previous table)
;;;
;;;    \ car   ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|      |
;;;  cdr \     ||                 |    T or NIL     |                |                |
;;;====================================================================================
;;;    |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d]) |
;;;    NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a    |
;;; QUOTE or T || LIST* ([a] [d]) | QUOTE  (a . d)  | APPEND (a [d]) | NCONC  (a [d]) |
;;;   APPEND   || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC  (a [d]) |
;;;   NCONC    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a . d) |
;;;    LIST    || LIST  ([a] . d) | LIST  ([a] . d) | APPEND (a [d]) | NCONC  (a [d]) |
;;;    LIST*   || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC  (a [d]) |
;;;
;;;<hair> involves starting over again pretending you had read ".,a)" instead of ",@a)"

(setsyntax '/` 'macro 'xr-backquote-macro)
(setsyntax '/, 'macro 'xr-comma-macro)

(declare (special **backquote-flag**
	        **backquote-count**
	        **backquote-/,-flag**
	        **backquote-/,/@-flag**
	        **backquote-/,/.-flag**))

(setq **backquote-flag**)
(setq **backquote-count** 0)
(setq **backquote-/,-flag** (copysymbol '|`,| nil))
(setq **backquote-/,/@-flag** (copysymbol '|`,@| nil))
(setq **backquote-/,/.-flag** (copysymbol '|`,.| nil))

(defun xr-backquote-macro ()
       ((lambda (**backquote-count** **backquote-flag** thing)
                (setq thing (backquotify (read)))
                (cond ((eq **backquote-flag** **backquote-/,/@-flag**)
                       (error " "",@"" right after a ""`"" : " thing 'fail-act))
                      ((eq **backquote-flag** **backquote-/,/.-flag**)
                       (error " "",."" right after a ""`"" : " thing 'fail-act))
                      (t
                       (backquotify-1 **backquote-flag** thing))))
        (1+ **backquote-count**)
        nil
        nil))

(defun xr-comma-macro ()
       (or (> **backquote-count** 0)
           (error "Comma not inside a backquote. " nil 'fail-act))
       ((lambda (c **backquote-count**)
                (cond ((= c 100)                        ;#/@
                       (tyi)
                       (cons **backquote-/,/@-flag** (read)))
                      ((= c 56)                         ;#/.
                       (tyi)
                       (cons **backquote-/,/.-flag** (read)))
                      (t (cons **backquote-/,-flag** (read)))))
        (tyipeek)
        (1- **backquote-count**)))

(defun backquotify (code)
       (prog (aflag a dflag d)
             (cond ((atom code)
                    (cond ((null code)
                           (setq **backquote-flag** nil)
                           (return nil))
                          ((or (numberp code)
                               (eq code t))
                           (setq **backquote-flag** t)
                           (return code))
                          (t (setq **backquote-flag** 'quote)
                             (return code))))
                   ((eq (car code) **backquote-/,-flag**)
                    (setq code (cdr code))
                    (go comma))
                   ((eq (car code) **backquote-/,/@-flag**)
                    (setq **backquote-flag** **backquote-/,/@-flag**)
                    (return (cdr code)))
                   ((eq (car code) **backquote-/,/.-flag**)
                    (setq **backquote-flag** **backquote-/,/.-flag**)
                    (return (cdr code))))
             (setq a (backquotify (car code)))
             (setq aflag **backquote-flag**)
             (setq d (backquotify (cdr code)))
             (setq dflag **backquote-flag**)
             (and (eq dflag **backquote-/,/@-flag**)
                  (error " "",@"" after a ""."" : " code 'fail-act))
             (and (eq dflag **backquote-/,/.-flag**)
                  (error " "",."" after a ""."" : " code 'fail-act))
             (cond ((eq aflag **backquote-/,/@-flag**)
                    (cond ((null dflag)
                           (setq code a)
                           (go comma)))
                    (setq **backquote-flag** 'append)
                    (return (cond ((eq dflag 'append)
                                   (cons a d))
                                  (t (list a (backquotify-1 dflag d))))))
                   ((eq aflag **backquote-/,/.-flag**)
                    (cond ((null dflag)
                           (setq code a)
                           (go comma)))
                    (setq **backquote-flag** 'nconc)
                    (return (cond ((eq dflag 'nconc)
                                   (cons a d))
                                  (t (list a (backquotify-1 dflag d))))))
                   ((null dflag)
                    (cond ((memq aflag '(quote t nil))
                           (setq **backquote-flag** 'quote)
                           (return (list a)))
                          (t (setq **backquote-flag** 'list)
                             (return (list (backquotify-1 aflag a))))))
                   ((memq dflag '(quote t))
                    (cond ((memq aflag '(quote t nil))
                           (setq **backquote-flag** 'quote)
                           (return (cons a d)))
                          (t (setq **backquote-flag** 'list*)
                             (return (list (backquotify-1 aflag a)
                                           (backquotify-1 dflag d)))))))
             (setq a (backquotify-1 aflag a))
             (and (memq dflag '(list list*))
                  (setq **backquote-flag** dflag)
                  (return (cons a d)))
             (setq **backquote-flag** 'list*)
             (return (list a (backquotify-1 dflag d)))
       comma (cond ((atom code)
                    (cond ((null code)
                           (setq **backquote-flag** nil)
                           (return nil))
                          ((or (numberp code)
                               (eq code 't))
                           (setq **backquote-flag** t)
                           (return code))
                          (t (setq **backquote-flag**
                                   **backquote-/,-flag**)
                             (return code))))
	         ((eq (car code) 'quote)
		(setq **backquote-flag** 'quote)
		(return (cadr code)))
                   ((memq (car code) '(append list list* nconc))
                    (setq **backquote-flag** (car code))
                    (return (cdr code)))
                   ((eq (car code) 'cons)
                    (setq **backquote-flag** 'list*)
                    (return (cdr code)))
                   (t (setq **backquote-flag** **backquote-/,-flag**)
                      (return code)))))

(defun backquotify-1 (flag thing)
       (cond ((or (eq flag **backquote-/,-flag**)
                  (memq flag '(t nil)))
              thing)
             ((eq flag 'quote)
              (list 'quote thing))
             ((eq flag 'list*)
              (cond ((null (cddr thing))
                     (cons 'cons thing))
                    (t (cons 'list* thing))))
             (t (cons flag thing))))

(sstatus feature backquote)




		    lisp_defmacro_.lisp             07/06/83  0938.4r w 06/29/83  1542.9       50211



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

;; Written:  January 1980 by Alan Bawden
;; Modified:  March 1981 by Carl Hoffman
;;  Observe compiler "macros" flag.  Don't output an argument count check when
;;  the lambda list is (&optional ... &rest ...) or (&rest ...).
;; Modified:  March 1982 by Alan Bawden
;;  Now includes a macro macro.  That is, (macro foo (x) ...) is like 
;;  the good old (defun foo macro (x) ...).
;; Modified:  October 1982 by Carl Hoffman for installation in bound_lisp_library_

(%include backquote)
(%include destructuring_let)
(declare (macros t))

(declare (special macros))
(declare (*expr let-macro-flush-declares let-macro-cons-declares))

;; Note:  The "let" package must also be loaded at run time since defmacro
;; expands into "let" forms.  defmacro.incl.lisp does this.

(declare (special *rest* *normal* *optional* *body*))

(defun grok-&keyword-list (pattern body)
        (prog (pat x)
              (setq pat pattern)
	    (setq *body* body)
         norm (cond ((null pat) (return t))
                    ((atom pat) (setq *rest* pat) (return t)))
              (setq x (car pat))
              (cond ((eq x '&optional)
                     (go opt))
                    ((memq x '(&rest &body))
                     (go rst))
                    ((eq x '&aux)
                     (go ax)))
              (setq *normal* (cons x *normal*)
                    pat (cdr pat))
              (go norm)
          opt (cond ((null (setq pat (cdr pat))) (return t))
                    ((atom pat) (setq *rest* pat) (return t)))
              (setq x (car pat))
              (cond ((eq x '&optional)
                     (go barf))
                    ((memq x '(&rest &body))
                     (go rst))
                    ((eq x '&aux)
                     (go ax)))
              (cond ((atom x)
                     (setq *optional* (cons (list x nil) *optional*)))
                    (t
                     (setq *optional* (cons x *optional*))))
              (go opt)
          rst (or (and (not (null (setq pat (cdr pat))))
                       (not (atom pat))
                       (atom (setq x (car pat))))
                  (go barf))
              (setq *rest* x)
              (or (setq pat (cdr pat))
                  (return t))
              (and (or (atom pat)
                       (not (eq (car pat) '&aux)))
                   (go barf))
           ax (setq *body* `((let* ,(cdr pat) . ,*body*)))
              (return t)
         barf (error "Bad &keyword argument list: " pattern 'fail-act)))

(defprop defmacro defmacro/ macro macro)

(defun defmacro/ macro (x)
 (displace x
  (let (((nil name pattern . body) x)
        (var (gensym))
        *normal* *optional* *rest* *body*
        nname check-args guts tail)
    ;; make_atom returns an interned result.
    (setq nname (make_atom (catenate name " macro")))
    (grok-&keyword-list pattern (let-macro-flush-declares body))
    (setq check-args (length *normal*))
    ;; nreconc is broken.  This uses esoteric features of nconc:
    ;; (nconc '(a b c) 'd) --> (a b c . d)
    ;; (nconc nil 'x) -> x
    (setq *normal*
	(nconc (nreverse *normal*)
	       (cond ((null *optional*) *rest*)
		   (t (setq tail (gensym))))))
    (setq check-args
      (let ((cnd (cond ((null *rest*)
		    (cond ((null tail)
			 `(= (length ,var) ,(1+ check-args)))
			(t `(and (> (length ,var) ,check-args)
			         (< (length ,var)
				  ,(+ 2 check-args 
				      (length *optional*)))))))
		   ;; If we have a rest var, then there is no upper bound.
		   ;; If *normal* is atomic, then there is no lower bound.
		   ((and (atom *normal*) *rest*) nil)
		   (t `(> (length ,var) ,check-args)))))
        (and cnd
	   `((or ,cnd (error "Wrong number of args in macro form: "
			 ,var 'fail-act))))))
    (setq guts
      `((,var)
        .,(let-macro-cons-declares body
           `((comment args = ,pattern)
	   ,@check-args
	   (displace ,var
	     (let ((,*normal* (cdr ,var)))
	        . ,(cond (tail
		        (do ((o *optional* (cdr o))
			   (ps nil (cond ((null (cddar o)) ps)
				       (t (cons (caddar o) ps))))
			   (b (cond (*rest*
				    `((let ((,*rest* (cdr ,tail)))
					 . ,*body*)))
				  (t *body*))
			      `((let ((,(caar o)
				      (cond (,(cond ((null (cdr o))
						 tail)
						(t
						  `(setq ,tail (cdr ,tail))))
					    ,@(cond ((null (cddar o)) nil)
						  (t `((setq ,(caddar o)
							   t))))
					    (car ,tail))
					  (t ,(cadar o)))))
				   . ,b))))
			  ((null o)
			   (cond ((null ps) b)
			         (t `((let ,ps . ,b)))))))
		       (t *body*))))))))
    `(eval-when ,(cond ((and (boundp 'macros) macros) '(eval load compile))
		   (t '(eval compile)))
	      (defprop ,name ,nname macro)
	      (defun ,nname . ,guts)))))

;;;Probably defmacro should use this, but lets not toy with success.
(defprop macro macro/ macro macro)

(defun macro/ macro (x)
 (displace x
  (let (;; make_atom returns an interned result.
        (nname (make_atom (catenate (cadr x) " macro"))))
    `(eval-when ,(cond ((and (boundp 'macros) macros) `(eval load compile))
		   (t `(eval compile)))
	      (defprop ,(cadr x) ,nname macro)
	      (defun ,nname . ,(cddr x))))))

(sstatus feature defmacro)




		    lisp_defstruct_.lisp            07/06/83  0938.4r w 06/29/83  1542.9      511749



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************
;;; -*- Mode:Lisp; Package:SI; Lowercase:True -*-
;;;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;;;	** (c) Copyright 1981 Massachusetts Institute of Technology **

;The master copy of this file is in MC:ALAN;NSTRUCT >
;The current PDP10 MacLisp copy is in MC:ALAN;STRUCT >
;The current Lisp machine copy is in AI:LISPM2;STRUCT >
;The current Multics MacLisp copy is in >udd>Mathlab>Bawden>defstruct.lisp
;  on MIT-Multics
;The current VMS-NIL copy is in [NIL.SRC.SPEC]STRUCT.LSP on HTJR

;*****  READ THIS PLEASE!  *****
;If you are thinking of munging anything in this file you might want to
;consider finding me (ALAN) and asking me to mung it for you.  There is more
;than one copy of this file in the world (it runs in PDP10 and Multics MacLisp,
;NIL, Franz, PSL and on LispMachines) and whatever amazing features you are
;considering adding might be usefull to those people as well.  If you still
;cannot contain yourself long enough to find me, AT LEAST send me a piece of
;mail describing what you did and why.  Thanks for reading this flame.
;				Alan Bawden (ALAN@MC)

(eval-when (eval compile)
   (sstatus nofeature MacLisp-10))

(%include sharpsign)
(%include defmacro)
(%include other_other)
(%include defstruct)

(declare (genprefix defstruct-internal-)
         (*expr dpb ldb)
         (macros t))

(eval-when (eval compile)
  (setsyntax #/: (ascii #\space) nil))


(eval-when (eval compile load)

#+MacLisp
(defun defstruct-retry-keyword (x)
  (let ((l (exploden x)))
    (if (= (car l) #/:)
	(implode (cdr l))
	x)))

#+LispM
(defun defstruct-retry-keyword (x)
  (intern (get-pname x) si:pkg-user-package))

#+NIL
(defmacro defstruct-retry-keyword (x)
  `(to-keyword ,x))

);End of eval-when (eval compile load)

;;; Eval this before attempting incremental compilation
(eval-when (eval compile)

#+MacLisp-10
(defmacro append-symbols args
  (do ((l (reverse args) (cdr l))
       (x)
       (a nil (if (or (atom x)
		      (not (eq (car x) 'quote)))
		  (if (null a)
		      `(exploden ,x)
		      `(nconc (exploden ,x) ,a))
		  (let ((l (exploden (cadr x))))
		    (cond ((null a) `',l)
			  ((= 1 (length l)) `(cons ,(car l) ,a))
			  (t `(append ',l ,a)))))))
      ((null l) `(implode ,a))
    (setq x (car l))))

#+Multics
(defmacro append-symbols args
  `(make_atom (catenate ,@args)))

#+LispM
(defmacro append-symbols args
  `(intern (string-append ,@args)))

#+NIL
(defmacro append-symbols args
  `(symbolconc ,@args))

(defmacro defstruct-putprop (sym val ind)
  `(push `(defprop ,,sym ,,val ,,ind) returns))

#+Multics
;;;lcp gobbles (defprop ... macro) at compile time, so we have to use
;;;putprop to be certain macro definitions make it into the object:
(defmacro defstruct-put-macro (sym fcn)
  `(push `(putprop ',,sym ',,fcn 'macro) returns))

#+MacLisp-10
(defmacro defstruct-put-macro (sym fcn)
  `(push `(defprop ,,sym ,,fcn macro) returns))

#+LispM
(defmacro defstruct-put-macro (sym fcn)
  (setq fcn (if (and (not (atom fcn))
		     (eq (car fcn) 'quote))
		`'(macro . ,(cadr fcn))
		`(cons 'macro ,fcn)))
  `(push `(fdefine ',,sym ',,fcn t) returns))

#+NIL
(defmacro defstruct-put-macro (sym fcn)
  `(push `(add-macro-definition ',,sym ',,fcn) returns))
							
(defmacro make-empty () `'%%defstruct-empty%%)

(defmacro emptyp (x) `(eq ,x '%%defstruct-empty%%))

;;;Here we must deal with the fact that error reporting works
;;;differently everywhere!

#+MacLisp-10
;;;first arg is ALWAYS a symbol or a quoted symbol:
(defmacro defstruct-error (message &rest args)
  (let* ((chars (nconc (exploden (if (atom message)
				     message
				     (cadr message)))
		       '(#/.)))		;"Bad frob" => "Bad frob."
	 (new-message
	  (maknam (if (null args)
		      chars
		      (let ((c (car chars)))	;"Bad frob." => "-- bad frob."
			(or (< c #/A)
			    (> c #/Z)
			    (rplaca chars (+ c #o40)))
			(append '(#/- #/- #\space) chars))))))
  `(error ',new-message
	  ,@(cond ((null args) `())
		  ((null (cdr args)) `(,(car args)))
		  (t `((list ,@args)))))))

#+Multics
;;;first arg is ALWAYS a string:
(defmacro defstruct-error (message &rest args)
  `(error ,(catenate "defstruct: "
		     message
		     (if (null args)
			 "."
			 ": "))
	  ,@(cond ((null args) `())
		  ((null (cdr args)) `(,(car args)))
		  (t `((list ,@args))))))

#+(or LispM NIL)
;;;first arg is ALWAYS a string:
(defmacro defstruct-error (message &rest args)
  (do ((l args (cdr l))
       (fs "")
       (na nil))
      ((null l)
      `(ferror nil
	       ,(string-append message
			       (if (null args)
				   "."
				   (string-append ":" fs)))
	       ,.(nreverse na)))
    (cond ((and (not (atom (car l)))
		(eq (caar l) 'quote)
		(symbolp (cadar l)))
	   (setq fs (string-append fs " " (string-downcase (cadar l)))))
	  (t
	   (push (car l) na)
	   (setq fs (string-append fs " ~S"))))))

);End of eval-when (eval compile)

;;;If you mung the the ordering af any of the slots in this structure,
;;;be sure to change the version slot and the definition of the function
;;;get-defstruct-description.  Munging the defstruct-slot-description 
;;;structure should also cause you to change the version "number" in this
;;;manner.
(defstruct (defstruct-description
	     (:type :list)
	     (:default-pointer description)
	     (:conc-name defstruct-description-)
	     (:alterant ())
	  #+stingy-defstruct
	     (:eval-when (eval compile)))
  (version 'one)
  type
  dummy ;used to be the displace function
  slot-alist
  named-p
  constructors
  (default-pointer nil)
  (but-first nil)
  size
  (property-alist nil)
  ;;end of "expand-time" slots
  name
  include
  (initial-offset 0)
  (eval-when '(eval compile load))
  alterant
  (conc-name nil)
  (callable-accessors #-(or LispM NIL) nil #+(or LispM NIL) t)
  (size-macro nil)
  (size-symbol nil)
  (predicate nil)
  (copier nil)
  (print nil)
  )

(defun get-defstruct-description (name)
  (let ((description (get name 'defstruct-description)))
    (cond ((null description)
	   (defstruct-error
	     "A structure with this name has not been defined" name))
	  ((not (eq (defstruct-description-version) 'one))
	   (defstruct-error "The internal description of this structure is
incompatible with the currently loaded version of defstruct,
you will need to recompile its definition"
		  name))
	  (t description))))

;;;See note above defstruct-description structure before munging this one.
(defstruct (defstruct-slot-description
	     (:type :list)
	     (:default-pointer slot-description)
	     (:conc-name defstruct-slot-description-)
	     (:alterant ())
	  #+stingy-defstruct
	     (:eval-when (eval compile)))
  number
  (ppss nil)
  init-code
  (type 'notype)
  (property-alist nil)
  ref-macro-name
  )

;;;Perhaps this structure wants a version slot too?
(defstruct (defstruct-type-description
	     (:type :list)
	     (:default-pointer type-description)
	     (:conc-name defstruct-type-description-)
	     (:alterant ())
	  #+stingy-defstruct
	     (:eval-when (eval compile)))
  ref-expander
  ref-no-args
  cons-expander
  cons-flavor
  (cons-keywords nil)
  (named-type nil)
  (overhead 0)
  (defstruct-expander nil)
  (predicate nil)
  (copier nil)
  )

;; (DEFSTRUCT (<name> . <options>) . <slots>) or (DEFSTRUCT <name> . <slots>)
;;
;; <options> is of the form (<option> <option> (<option> <val>) ...)
;;
;; <slots> is of the form (<slot> (<slot> <initial-value>) ...)
;;
;; Options:
;;   :TYPE defaults to HUNK
;;   :CONSTRUCTOR defaults to "MAKE-<name>"
;;   :DEFAULT-POINTER defaults to empty (if no <val> given defaults to "<name>")
;;   :CONC-NAME defaults to empty (if no <val> given defaults to "<name>-")
;;   :SIZE-SYMBOL defaults to empty (if no <val> given defaults to "<name>-SIZE")
;;   :SIZE-MACRO defaults to empty (if no <val> given defaults to "<name>-SIZE")
;;   :ALTERANT defaults to "ALTER-<name>"
;;   :BUT-FIRST must have a <val> given
;;   :INCLUDE must have a <val> given
;;   :PROPERTY (:property foo bar) gives the structure a foo
;;     property of bar.  (:property foo) gives a foo property of T.
;;   :INITIAL-OFFSET can cause defstruct to skip over that many slots.
;;   :NAMED takes no value.  Tries to make the structure a named type.
;;   :CALLABLE-ACCESSORS defaults to true on the LispMachine and NIL.  False
;;     elsewhere. 
;;   :EVAL-WHEN defaults to (eval compile load).  <val> must be given.
;;   :PREDICATE defaults to empty (if no <val> given defaults
;;     to "<name>-P").  Generates a predicate if possible.
;;   :COPIER defaults to empty (if no <val> given defaults to
;;     "COPY-<name>").  Generates a function to copy this structure.
;;   :PRINT (:print "#<spaceship at ~S by ~S>" (x-pos spaceship)
;;     (y-pos spaceship))  The name of the structure is used as
;;     the variable.
;;   <type> any type name can be used without a <val> instead of
;;     saying (:TYPE <type>) 
;;   <other> any symbol with a non-nil :defstruct-option property.  You say
;;     (<other> <val>) and the effect is that of (:property <other> <val>)
;;
;; Symbol properties used:
;;   DEFSTRUCT-TYPE-DESCRIPTION each type has one, it is a type-description.
;;   DEFSTRUCT-NAME each constructor, alterant and size macro
;;     has one, it is a name. 
;;   DEFSTRUCT-DESCRIPTION each name has one, it is a description (see below).
;;   DEFSTRUCT-SLOT each accesor has one, it is of the form: (<name> . <slot>)
;;   :DEFSTRUCT-OPTION if a symbol FOO has this property then it can be used as
;;     an option giving the structure a FOO property of the value (or T).

#+LispM
(defprop defstruct "Structure" definition-type-name)

;;;The order of forms returned by defstruct is sometimes critical.  Keep this
;;;in mind when munging this code:
(defmacro defstruct (options &body items)
  (let* ((description (defstruct-parse-options options))
	 (type-description (get (defstruct-description-type)
				'defstruct-type-description))
	 (name (defstruct-description-name))
	 (new-slots (defstruct-parse-items items description))
	 (returns nil))
    (push `',name returns)
    ;;This must be last, since to compile it might require that the structure
    ;;already be operable:
    (cond ((defstruct-description-print)
	   (push (defstruct-define-printer name (defstruct-description-print))
		 returns)))
    ;;Keep this as close to last as possible:
    (cond ((defstruct-type-description-defstruct-expander)
	   (setq returns (append (funcall (defstruct-type-description-defstruct-expander)
					  description)
				 returns))))
 #+LispM
    (push `(record-source-file-name ',name 'defstruct) returns)
    (let ((alterant (defstruct-description-alterant))
	  (size-macro (defstruct-description-size-macro))
	  (size-symbol (defstruct-description-size-symbol))
	  (predicate (defstruct-description-predicate))
	  (copier (defstruct-description-copier)))
      (cond (predicate
	     (push (funcall (or (defstruct-type-description-predicate)
				(defstruct-error
				  "This defstruct type cannot produce a predicate"
				  (defstruct-description-type) 'in name))
			    description
			    predicate)
		   returns)))
      (cond (copier
	     (push
	       (let ((copy-fun (defstruct-type-description-copier)))
		 (cond (copy-fun
			(funcall copy-fun description copier))
		       ((not (= 1 (defstruct-type-description-ref-no-args)))
			(defstruct-error
			  "This defstruct type cannot produce a copying function"
			  (defstruct-description-type) 'in name))
		       (t (do ((i (1- (defstruct-description-size)) (1- i))
			       (l nil (cons (cons i (funcall (defstruct-type-description-ref-expander)
							     i description 'x))
					    l)))
			      ((< i 0)
			       `(defun ,copier (x)
				  ,(invoke-defstruct-constructor-expander
				     description type-description l nil)))))))
	       returns)))
      (cond (alterant
	     (defstruct-put-macro alterant 'defstruct-expand-alter-macro)
	     (defstruct-putprop alterant name 'defstruct-name)))
      (cond (size-macro
	     (defstruct-put-macro size-macro 'defstruct-expand-size-macro)
	     (defstruct-putprop size-macro name 'defstruct-name)))
      (cond (size-symbol
	     (push `(defconst ,size-symbol
		      ,(+ (defstruct-description-size)
			  (defstruct-type-description-overhead)))
		   returns))))
    (defstruct-putprop name description 'defstruct-description)
    (do ((cs (defstruct-description-constructors) (cdr cs)))
	((null cs))
      (defstruct-put-macro (caar cs) 'defstruct-expand-cons-macro)
      (defstruct-putprop (caar cs) name 'defstruct-name))
    `(eval-when ,(defstruct-description-eval-when)
		,.(defstruct-define-ref-macros new-slots description)
		,.returns)))

;;;General philosophy on the :print option is to not bother the
;;;user if printing cannot be controled.  This allows for
;;;portability without pain.  This may prove to be a bogus philoshphy.
#+MacLisp-10
(defun defstruct-define-printer (name rest)
  (let ((stream (gensym)))
    `(defun (,name named-hunk-printer) (,name ,stream)
       (?format ,stream ,@rest))))

#+LispM
(defun defstruct-define-printer (name rest)
  (let ((op (gensym))
	(args (gensym)))
    `(defun (,name named-structure-invoke) (,op ,name &rest ,args)
       (selectq ,op
	 (:print-self
	   (if print-readably (print-not-readable ,name))
	   (format (car ,args) ,@rest))
	 (:which-operations '(:print-self))
	 (t (ferror nil "Illegal operation ~S" ,op))))))

#+NIL
(defun defstruct-define-printer (name rest)
  (let ((method-function-name (symbolconc name "->PRINT-SELF#METHOD"))
	(stream-var (gensym))
	(gubble (gensym)))
    `(progn 'compile
	(defun ,method-function-name (,name () () ,stream-var &rest ,gubble)
	  ,gubble	;ignored
	  (format ,stream-var ,@rest))
	(add-flavor-method-info ',name ':print-self ',method-function-name))))

#-(or LispM MacLisp-10 NIL)
(defun defstruct-define-printer (name rest)
  `(comment ,name ,@rest))

(defun defstruct-parse-options (options)
  (let ((name (if (atom options) options (car options)))
	(type nil)
	(constructors (make-empty))
	(alterant (make-empty))
	(included nil)
	(named-p nil)
	(but-first nil)
	(description (make-defstruct-description)))
    (setf (defstruct-description-name) name)
    (do ((op) (val) (vals)
	 (options (if (atom options) nil (cdr options))
		  (cdr options)))
	((null options))
      (if (atom (setq op (car options)))
	  (setq vals nil)
	  (setq op (prog1 (car op) (setq vals (cdr op)))))
      (setq val (if (null vals) (make-empty) (car vals)))
AGAIN (selectq op
	(:type
	 (if (emptyp val)
	     (defstruct-error
	       "The type option to defstruct must have a value given"
	       name))
	 (setq type val))
	(:named
	 (or (emptyp val)
	     (defstruct-error
	       "The named option to defstruct doesn't take a value" name))
	 (setq named-p t))
	(:default-pointer
	 (setf (defstruct-description-default-pointer)
	       (if (emptyp val) name val)))
	(:conc-name
	 (setf (defstruct-description-conc-name)
	       (if (emptyp val)
		   (append-symbols name '-)
		   val)))
	(:print
	 (if (emptyp val)
	     (defstruct-error
	       "The print option to defstruct requires a value"
	       name))
	 (setf (defstruct-description-print) vals))
	(:include
	 (if (emptyp val)
	     (defstruct-error
	       "The include option to defstruct requires a value"
	       name))
	 (setq included val)
	 (setf (defstruct-description-include) vals))
	(:predicate
	 (setf (defstruct-description-predicate)
	       (if (emptyp val)
		   (append-symbols name '-p)
		   val)))
	(:constructor
	 (cond ((null val)
		(setq constructors nil))
	       (t
		(and (emptyp val)
		     (setq val (append-symbols 'make- name)))
		(setq val (cons val (cdr vals)))
		(if (emptyp constructors)
		    (setq constructors (list val))
		    (push val constructors)))))
	(:copier
	 (setf (defstruct-description-copier)
	       (if (emptyp val)
		   (append-symbols 'copy- name)
		   val)))
	(:eval-when
	 (and (emptyp val)
	      (defstruct-error
		"The eval-when option to defstruct requires a value"
		name))
	 (setf (defstruct-description-eval-when) val))
	(:alterant
	 (setq alterant val))
	(:but-first
	 (if (emptyp val)
	     (defstruct-error
	       "The but-first option to defstruct must have a value given"
	       name))
	 (setq but-first val)
	 (setf (defstruct-description-but-first) val))
	(:size-macro
	 (setf (defstruct-description-size-macro)
	       (if (emptyp val)
		   (append-symbols name '-size)
		   val)))
	(:size-symbol
	 (setf (defstruct-description-size-symbol)
	       (if (emptyp val)
		   (append-symbols name '-size)
		   val)))
	(:callable-accessors
	 (setf (defstruct-description-callable-accessors)
	       (if (emptyp val) t val)))
	(:property
	 (if (emptyp val)
	     (defstruct-error
	       "The property option to defstruct requires a value"
	       name))
	 (push (cons val (if (null (cdr vals)) t (cadr vals)))
	       (defstruct-description-property-alist)))
	(:initial-offset
	 (and (or (emptyp val)
		  (not (fixp val)))
	      (defstruct-error
		"The initial-offset option to defstruct requires a fixnum"
		name))
	 (setf (defstruct-description-initial-offset) val))
	(t
	 (cond ((get op 'defstruct-type-description)
		(or (emptyp val)
		    (defstruct-error
		      "defstruct type used as an option with a value"
		      op 'in name))
		(setq type op))
	       ((get op ':defstruct-option)
		(push (cons op (if (emptyp val) t val))
		      (defstruct-description-property-alist)))
	       (t
		(let ((new (defstruct-retry-keyword op)))
		  (cond ((not (eq new op))
			 (setq op new)
			 (go AGAIN)))
		  (defstruct-error
		    "defstruct doesn't understand this option"
		    op 'in name)))))))
    (cond ((emptyp constructors)
	   (setq constructors
		 (list (cons (append-symbols 'make- name)
			     nil)))))
    (setf (defstruct-description-constructors) constructors)
    (cond ((emptyp alterant)
	   (setq alterant
		 (append-symbols 'alter- name))))
    (setf (defstruct-description-alterant) alterant)
    (cond ((not (null type))
	   (let ((type-description
		  (or (get type 'defstruct-type-description)
		      (let ((new (defstruct-retry-keyword type)))
			(cond ((eq type new) nil)
			      (t
			       (setq type new)
			       (get type 'defstruct-type-description))))
		      (defstruct-error
			"Unknown type in defstruct"
			type 'in name))))
	     (if named-p
		 (setq type
		       (or (defstruct-type-description-named-type)
			   (defstruct-error
			    "There is no way to make this defstruct type named"
			    type 'in name)))))))
    (cond (included
	   (let ((d (get-defstruct-description included)))
	     (if (null type)
		 (setq type (defstruct-description-type d))
		 (or (eq type (defstruct-description-type d))
		     (defstruct-error
		       "defstruct types must agree for include option"
		       included 'included 'by name)))
	     (and named-p
		  (not (eq type (defstruct-type-description-named-type
				  (or (get type 'defstruct-type-description)
				      (defstruct-error
					"Unknown type in defstruct"
					type 'in name 'including included)))))
		  (defstruct-error
		    "Included defstruct's type isn't a named type"
		    included 'included 'by name))
	     (if (null but-first)
		 (setf (defstruct-description-but-first)
		       (defstruct-description-but-first d))
		 (or (equal but-first (defstruct-description-but-first d))
		     (defstruct-error
		       "but-first options must agree for include option"
		       included 'included 'by name)))))
	  ((null type)
	   (setq type
	     (cond (named-p
		    #+MacLisp-10 ':named-hunk
		    #+Multics ':named-list
		    #+LispM ':named-array
		    #+NIL ':extend)
		   (t
		    #+MacLisp-10 ':hunk
		    #+Multics ':list
		    #+LispM ':array
		    #+NIL ':vector)))))
    (let ((type-description (or (get type 'defstruct-type-description)
				(defstruct-error
				  "Undefined defstruct type"
				  type 'in name))))
      (setf (defstruct-description-type) type)
      (setf (defstruct-description-named-p)
	    (eq (defstruct-type-description-named-type) type)))
    description))

(defun defstruct-parse-items (items description)
  (let ((name (defstruct-description-name))
	(offset (defstruct-description-initial-offset))
	(include (defstruct-description-include))
	(o-slot-alist nil)
	(conc-name (defstruct-description-conc-name)))
    (or (null include)
	(let ((d (get (car include) 'defstruct-description)))
	  (setq offset (+ offset (defstruct-description-size d))) 
	  (setq o-slot-alist
		(subst nil nil (defstruct-description-slot-alist d)))
	  (do ((l (cdr include) (cdr l))
	       (it) (val))
	      ((null l))
	    (cond ((atom (setq it (car l)))
		   (setq val (make-empty)))
		  (t
		   (setq val (cadr it))
		   (setq it (car it))))
	    (let ((slot-description (cdr (assq it o-slot-alist))))
	      (and (null slot-description)
		   (defstruct-error
		     "Unknown slot in included defstruct"
		     it 'in include 'included 'by name))
	      (setf (defstruct-slot-description-init-code) val)))))
    (do ((i offset (1+ i))
	 (l items (cdr l))
	 (slot-alist nil)
	 #+MacLisp-10 (chars (exploden conc-name)))
	((null l)
	 (setq slot-alist (nreverse slot-alist))
	 (setf (defstruct-description-size) i)
	 (setf (defstruct-description-slot-alist)
	       (nconc o-slot-alist slot-alist))
	 slot-alist)
      (cond ((atom (car l))
	     (push (defstruct-parse-one-field
		     (car l) i nil nil conc-name #+MacLisp-10 chars)
		   slot-alist))
	    ((atom (caar l))
	     (push (defstruct-parse-one-field
		     (caar l) i nil (cdar l) conc-name #+MacLisp-10 chars)
		   slot-alist))
	    (t
	     (do ((ll (car l) (cdr ll)))
		 ((null ll))
	       (push (defstruct-parse-one-field
		       (caar ll) i (cadar ll)
		       (cddar ll) conc-name #+MacLisp-10 chars)
		     slot-alist)))))))

(defun defstruct-parse-one-field (it number ppss rest conc-name #+MacLisp-10 chars)
  (let ((mname (if conc-name #+MacLisp-10 (implode (append chars (exploden it)))
			     #-MacLisp-10 (append-symbols conc-name it)
		   it)))
    (cons it (make-defstruct-slot-description
	       number number
	       ppss ppss
	       init-code (if (null rest) (make-empty) (car rest))
	       ref-macro-name mname))))

(defun defstruct-define-ref-macros (new-slots description)
  (let ((name (defstruct-description-name))
	(returns nil))
    (if (not (defstruct-description-callable-accessors))
	(do ((l new-slots (cdr l))
	     (mname))
	    ((null l))
	  (setq mname (defstruct-slot-description-ref-macro-name (cdar l)))
	  (defstruct-put-macro mname 'defstruct-expand-ref-macro)
	  (defstruct-putprop mname (cons name (caar l)) 'defstruct-slot))
	(let ((type-description
		(get (defstruct-description-type)
		     'defstruct-type-description)))
	  (let ((code (defstruct-type-description-ref-expander))
		(n (defstruct-type-description-ref-no-args))
	     #+LispM
		(parent `(,name defstruct))
		(but-first (defstruct-description-but-first))
		(default-pointer (defstruct-description-default-pointer)))
	    (do ((args nil (cons (gensym) args))
		 (i n (1- i)))
		((< i 2)
		 ;;Last arg (if it exists) is name of structure,
		 ;; for documentation purposes.
		 (and (= i 1)
		      (setq args (cons name args)))
		 (let ((body (cons (if but-first
				       `(,but-first ,(car args))
				       (car args))
				   (cdr args))))
		   (and default-pointer
			(setq args `((,(car args) ,default-pointer)
				     &optional ,@(cdr args))))
		   (setq args (reverse args))
		   (setq body (reverse body))
		   (do ((l new-slots (cdr l))
			(mname))
		       ((null l))
		     (setq mname (defstruct-slot-description-ref-macro-name
				   (cdar l)))
		     #+MacLisp 
		     ;;This must come BEFORE the defun. THINK!
		     (defstruct-put-macro mname 'defstruct-expand-ref-macro)
		     (let ((ref (lexpr-funcall
				  code
				  (defstruct-slot-description-number (cdar l))
				  description
				  body))
			   (ppss (defstruct-slot-description-ppss (cdar l))))
		       (push `(#+LispM defsubst-with-parent
			       #+NIL defsubst
			       #-(or LispM NIL) defun
			         ,mname #+LispM ,parent ,args
				 ,(if (null ppss) ref `(ldb ,ppss ,ref)))
			   returns))
		     (defstruct-putprop mname
					(cons name (caar l))
					'defstruct-slot))))))))
    returns))

#+LispM 
(defprop defstruct-expand-cons-macro
	 defstruct-function-parent
	 macroexpander-function-parent)

#+LispM 
(defprop defstruct-expand-size-macro
	 defstruct-function-parent
	 macroexpander-function-parent)

#+LispM 
(defprop defstruct-expand-alter-macro
	 defstruct-function-parent
	 macroexpander-function-parent)

#+LispM 
(defprop defstruct-expand-ref-macro 
	 defstruct-function-parent
	 macroexpander-function-parent)

#+LispM
(defun defstruct-function-parent (sym)
  (values (or (get sym 'defstruct-name)
	      (car (get sym 'defstruct-slot)))
	  'defstruct))

(defun defstruct-expand-size-macro (x)
  (let ((description (get-defstruct-description (get (car x) 'defstruct-name))))
    (let ((type-description (or (get (defstruct-description-type)
				     'defstruct-type-description)
				(defstruct-error
				  "Unknown defstruct type"
				  (defstruct-description-type)))))
      (+ (defstruct-description-size)
	 (defstruct-type-description-overhead)))))

(defun defstruct-expand-ref-macro (x)
  (let* ((pair (get (car x) 'defstruct-slot))
	 (description (get-defstruct-description (car pair)))
	 (type-description (or (get (defstruct-description-type)
				    'defstruct-type-description)
			       (defstruct-error
				 "Unknown defstruct type"
				 (defstruct-description-type))))
	 (code (defstruct-type-description-ref-expander))
	 (n (defstruct-type-description-ref-no-args))
	 (args (reverse (cdr x)))
	 (nargs (length args))
	 (default (defstruct-description-default-pointer))
	 (but-first (defstruct-description-but-first)))
    (cond ((= n nargs)
	   (and but-first
		(rplaca args `(,but-first ,(car args)))))
	  ((and (= n (1+ nargs)) default)
	   (setq args (cons (if but-first
				`(,but-first ,default)
				default)
			    args)))
	  (t
	   (defstruct-error
	     "Wrong number of args to an accessor macro" x)))
    (let* ((slot-description 
	     (cdr (or (assq (cdr pair)
			    (defstruct-description-slot-alist))
		      (defstruct-error
			"This slot no longer exists in this structure"
			(cdr pair) 'in (car pair)))))
	    (ref (lexpr-funcall
		   code
		   (defstruct-slot-description-number)
		   description
		   (nreverse args)))
	    (ppss (defstruct-slot-description-ppss)))
      (if (null ppss)
	  ref
	  `(ldb ,ppss ,ref)))))

(defun defstruct-parse-setq-style-slots (l slots others x)
  (do ((l l (cddr l))
       (kludge (cons nil nil)))
      ((null l) kludge)
    (or (and (cdr l)
	     (symbolp (car l)))
	(defstruct-error
	  "Bad argument list to constructor or alterant macro" x))
    (defstruct-make-init-dsc kludge (car l) (cadr l) slots others x)))

(defun defstruct-make-init-dsc (kludge name code slots others x)
  (let ((p (assq name slots)))
    (if (null p)
	(if (memq name others)
	    (push (cons name code) (cdr kludge))
	    (let ((new (defstruct-retry-keyword name)))
	      (if (memq new others)
		  (push (cons new code) (cdr kludge))
		  (defstruct-error
		    "Unknown slot to constructor or alterant macro"
		    name 'in x))))
	(let* ((slot-description (cdr p))
	       (number (defstruct-slot-description-number))
	       (ppss (defstruct-slot-description-ppss))
	       (dsc (assoc number (car kludge))))
	  (cond ((null dsc)
		 (setq dsc (list* number nil (make-empty) 0 0 nil))
		 (push dsc (car kludge))))
	  (cond ((null ppss)
		 (setf (car (cddr dsc)) code)
		 (setf (cadr dsc) t))
		(t (cond ((and (numberp ppss) (numberp code))
			  (setf (ldb ppss (cadr (cddr dsc))) -1)
			  (setf (ldb ppss (caddr (cddr dsc))) code))
			 (t
			  (push (cons ppss code) (cdddr (cddr dsc)))))
		   (or (eq t (cadr dsc))
		       (push name (cadr dsc)))))))))

(defun defstruct-code-from-dsc (dsc)
  (let ((code (car (cddr dsc)))
	(mask (cadr (cddr dsc)))
	(bits (caddr (cddr dsc))))
    (if (emptyp code)
	(setq code bits)
	(or (zerop mask)
	    (setq code (if (numberp code)
			   (boole 7 bits (boole 2 mask code))
			   (if (zerop (logand mask
					      (1+ (logior mask (1- mask)))))
			       (let ((ss (haulong (boole 2 mask (1- mask)))))
				 `(dpb ,(lsh bits (- ss))
				       ,(logior (lsh ss 6)
						(logand #o77
							(- (haulong mask) ss)))
				       ,code))
			       `(boole 7 ,bits (boole 2 ,mask ,code)))))))
    (do ((l (cdddr (cddr dsc)) (cdr l)))
	((null l))
      (setq code `(dpb ,(cdar l) ,(caar l) ,code)))
    code))

(defun defstruct-expand-cons-macro (x)
  (let* ((description (get-defstruct-description (get (car x) 'defstruct-name)))
	 (type-description (or (get (defstruct-description-type)
				    'defstruct-type-description)
			       (defstruct-error
				 "Unknown defstruct type"
				 (defstruct-description-type))))
	 (slot-alist (defstruct-description-slot-alist))
	 (cons-keywords (defstruct-type-description-cons-keywords))
	 (kludge nil)
	 (constructor-description 
	   (cdr (or (assq (car x) (defstruct-description-constructors))
		    (defstruct-error
		      "This constructor is no longer defined for this structure"
		      (car x) 'in (defstruct-description-name)))))
	 (aux nil)
	 (aux-init nil))
     (if (null constructor-description)
	 (setq kludge (defstruct-parse-setq-style-slots (cdr x)
							slot-alist
							cons-keywords
							x))
	 (prog (args l)
	       (setq kludge (cons nil nil))
	       (setq args (cdr x))
	       (setq l (car constructor-description))
	     R (cond ((null l)
		      (if (null args)
			  (return nil)
			  (go barf-tma)))
		     ((atom l) (go barf))
		     ((eq (car l) '&optional) (go O))
		     ((eq (car l) '&rest) (go S))
		     ((eq (car l) '&aux) (go A))
		     ((null args) (go barf-tfa)))
	       (defstruct-make-init-dsc kludge
					(pop l)
					(pop args)
					slot-alist
					cons-keywords
					x)
	       (go R)
	     O (and (null args) (go OD))
	       (pop l)
	       (cond ((null l) (go barf-tma))
		     ((atom l) (go barf))
		     ((eq (car l) '&optional) (go barf))
		     ((eq (car l) '&rest) (go S))
		     ((eq (car l) '&aux) (go barf-tma)))
	       (defstruct-make-init-dsc kludge
					(if (atom (car l)) (car l) (caar l))
					(pop args)
					slot-alist
					cons-keywords
					x)
	       (go O)
	    OD (pop l)
	       (cond ((null l) (return nil))
		     ((atom l) (go barf))
		     ((eq (car l) '&optional) (go barf))
		     ((eq (car l) '&rest) (go S))
		     ((eq (car l) '&aux) (go A)))
	       (or (atom (car l))
		   (defstruct-make-init-dsc kludge
					    (caar l)
					    (cadar l)
					    slot-alist
					    cons-keywords
					    x))
	       (go OD)
	     S (and (atom (cdr l)) (go barf))
	       (defstruct-make-init-dsc kludge
					(cadr l)
					`(list ,@args)
					slot-alist
					cons-keywords
					x)
	       (setq l (cddr l))
	       (and (null l) (return nil))
	       (and (atom l) (go barf))
	       (or (eq (car l) '&aux) (go barf))
	     A (pop l)
	       (cond ((null l) (return nil))
		     ((atom l) (go barf))
		     ((atom (car l))
		      (push (car l) aux)
		      (push (make-empty) aux-init))
		     (t
		      (push (caar l) aux)
		      (push (cadar l) aux-init)))
	       (go A)
	  barf (defstruct-error
		 "Bad format for defstruct constructor arglist"
		 `(,(car x) ,@(car constructor-description)))
      barf-tfa (defstruct-error "Too few arguments to constructor macro" x)
      barf-tma (defstruct-error "Too many arguments to constructor macro" x)))
     (do ((l slot-alist (cdr l)))
	 ((null l))
       (let* ((name (caar l))
	      (slot-description (cdar l))
	      (code (do ((aux aux (cdr aux))
			 (aux-init aux-init (cdr aux-init)))
			((null aux) (defstruct-slot-description-init-code))
		      (and (eq name (car aux)) (return (car aux-init)))))
	      (ppss (defstruct-slot-description-ppss)))
	 (or (and (emptyp code) (null ppss))
	     (let* ((number (defstruct-slot-description-number))
		    (dsc (assoc number (car kludge))))
	       (cond ((null dsc)
		      (setq dsc (list* number nil (make-empty) 0 0 nil))
		      (push dsc (car kludge))))
	       (cond ((emptyp code))
		     ((eq t (cadr dsc)))
		     ((null ppss)
		      (and (emptyp (car (cddr dsc)))
			   (setf (car (cddr dsc)) code)))
		     ((memq name (cadr dsc)))
		     ((and (numberp ppss) (numberp code))
		      (setf (ldb ppss (cadr (cddr dsc))) -1)
		      (setf (ldb ppss (caddr (cddr dsc))) code))
		     (t
		      (push (cons ppss code) (cdddr (cddr dsc)))))))))
     (do ((l (car kludge) (cdr l)))
	 ((null l))
       (rplacd (car l) (defstruct-code-from-dsc (car l))))
     (invoke-defstruct-constructor-expander
       description type-description
       (car kludge) (cdr kludge))))

(defun invoke-defstruct-constructor-expander (description type-description arg etc)
  (funcall (defstruct-type-description-cons-expander)
	   (selectq (defstruct-type-description-cons-flavor)
	     (:list
	      (do ((l nil (cons nil l))
		   (i (defstruct-description-size) (1- i)))
		  ((= i 0)
		   (do ((arg arg (cdr arg)))
		       ((null arg))
		     (setf (nth (caar arg) l) (cdar arg)))
		   l)))
	     (:alist arg)
	     (t
	      (defstruct-error
		"Unknown constructor kind in this defstruct type"
		(defstruct-description-type))))
	   description etc))

(defun defstruct-expand-alter-macro (x)
  (let* ((description (get-defstruct-description (get (car x) 'defstruct-name)))
	 (type-description (or (get (defstruct-description-type)
				    'defstruct-type-description)
			       (defstruct-error
				 "Unknown defstruct type"
				 (defstruct-description-type))))
	 (ref-code (defstruct-type-description-ref-expander))
	 (ref-nargs (defstruct-type-description-ref-no-args)))
    (do ((l (car (defstruct-parse-setq-style-slots 
		   (nthcdr (1+ ref-nargs) x)
		   (defstruct-description-slot-alist)
		   nil
		   x))
	    (cdr l))
	 (but-first (defstruct-description-but-first))
	 (body nil)
	 (avars (do ((i 0 (1+ i))
		     (l nil (cons (gensym) l)))
		    ((= i ref-nargs) l)))
	 (vars nil)
	 (vals nil))
	((null l)
	 `((lambda ,avars
	     ,@(if (null vars)
		   body
		   `(((lambda ,vars ,@body) ,.vals))))
	   ,@(do ((i (1- ref-nargs) (1- i))
		  (l `(,(if but-first
			    `(,but-first ,(nth ref-nargs x))
			    (nth ref-nargs x)))
		     (cons (nth i x) l)))
		 ((= i 0) l))))
      (let ((ref (lexpr-funcall ref-code (caar l) description avars)))
	(and (emptyp (car (cddr (car l))))
	     (setf (car (cddr (car l))) ref))
	(let ((code (defstruct-code-from-dsc (car l))))
	  (if (null (cdr l))
	      (push `(setf ,ref ,code) body)
	      (let ((sym (gensym)))
		(push `(setf ,ref ,sym) body)
		(push sym vars)
		(push code vals))))))))

(defmacro defstruct-define-type (type &body options)
  (do ((options options (cdr options))
       (op) (args)
       (type-description (make-defstruct-type-description))
       (cons-expander nil)
       (ref-expander nil)
       (returns `(',type)))
      ((null options)
       (or cons-expander
	   (defstruct-error "No cons option in defstruct-define-type" type))
       (or ref-expander
	   (defstruct-error "No ref option in defstruct-define-type" type))
       `(progn 'compile
	       ,cons-expander
	       ,ref-expander
	       (defprop ,type ,type-description defstruct-type-description)
	       ,@returns))
    (cond ((atom (setq op (car options)))
	   (setq args nil))
	  (t
	   (setq args (cdr op))
	   (setq op (car op))))
 AGAIN
    (selectq op
      (:cons
        (or (> (length args) 2)
	    (defstruct-error
	      "Bad cons option in defstruct-define-type"
	      (car options) 'in type))
	(let ((n (length (car args)))
	      (name (append-symbols type '-defstruct-cons)))
	  (or (= n 3)
	      (defstruct-error
		"Bad cons option in defstruct-define-type"
		(car options) 'in type))
	  (setf (defstruct-type-description-cons-flavor)
		(defstruct-retry-keyword (cadr args)))
	  (setf (defstruct-type-description-cons-expander) name)
	  (setq cons-expander `(defun ,name ,(car args)
				 ,@(cddr args)))))
      (:ref
        (or (> (length args) 1)
	    (defstruct-error
	      "Bad ref option in defstruct-define-type"
	      (car options) 'in type))
	(let ((n (length (car args)))
	      (name (append-symbols type '-defstruct-ref)))
	  (or (> n 2)
	      (defstruct-error
		"Bad ref option in defstruct-define-type"
		(car options) 'in type))
	  (setf (defstruct-type-description-ref-no-args) (- n 2))
	  (setf (defstruct-type-description-ref-expander) name)
	  (setq ref-expander `(defun ,name ,(car args)
				,@(cdr args)))))
      (:predicate
        (or (> (length args) 1)
	    (defstruct-error
	      "Bad predicate option in defstruct-define-type"
	      (car options) 'in type))
        (let ((name (append-symbols type '-defstruct-predicate)))
	  (setf (defstruct-type-description-predicate) name)
	  (push `(defun ,name ,(car args)
		   ,@(cdr args))
		returns)))
      (:copier
        (or (> (length args) 1)
	    (defstruct-error
	      "Bad copier option in defstruct-define-type"
	      (car options) 'in type))
        (let ((name (append-symbols type '-defstruct-copier)))
	  (setf (defstruct-type-description-copier) name)
	  (push `(defun ,name ,(car args)
		   ,@(cdr args))
		returns)))
      (:overhead
        (setf (defstruct-type-description-overhead)
	      (if (null args)
		  (defstruct-error
		    "Bad option to defstruct-define-type"
		    (car options) 'in type)
		  (car args))))
      (:named
        (setf (defstruct-type-description-named-type)
	      (if (null args)
		  type
		  (car args))))
      (:keywords
        (setf (defstruct-type-description-cons-keywords) args))
      (:defstruct
        (or (> (length args) 1)
	    (defstruct-error
	      "Bad defstruct option in defstruct-define-type"
	      (car options) 'in type))
	(let ((name (append-symbols type '-defstruct-expand)))
	  (setf (defstruct-type-description-defstruct-expander) name)
	  (push `(defun ,name ,@args) returns)))
      (t
       (let ((new (defstruct-retry-keyword op)))
	 (cond ((not (eq op new))
		(setq op new)
		(go AGAIN)))
	 (defstruct-error
	   "Unknown option to defstruct-define-type"
	   op 'in type))))))

#+LispM
(defprop :make-array t :defstruct-option)

#+LispM
(defstruct-define-type :array
  (:named :named-array)
  (:keywords :make-array)
  (:cons (arg description etc) :alist
    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
			       description etc nil nil nil 1))
  (:ref (n description arg)
    description		;ignored
    `(aref ,arg ,n)))

#+MacLisp
(defstruct-define-type :array
  (:cons (arg description etc) :alist
    etc
    (maclisp-array-for-defstruct arg description 't))
  (:ref (n description arg)
    description		;ignored
    `(arraycall t ,arg ,n)))

#+NIL
(defstruct-define-type :array
  (:cons (arg description etc) :alist
    etc
    (NIL-array-for-defstruct arg description))
  (:ref (n description arg)
    description		;ignored
    `(aref ,arg ,n)))

#+LispM
(defstruct-define-type :named-array
  (:keywords :make-array)
  :named (:overhead 1)
  (:cons (arg description etc) :alist
    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,(1+ i)))
			       description etc nil t nil 1))
  (:ref (n description arg)
    description		;ignored
    `(aref ,arg ,(1+ n)))
  (:predicate (description name)
    `(defsubst ,name (x)
       (typep x ',(defstruct-description-name)))))

#+LispM
(defstruct-define-type :fixnum-array
  (:keywords :make-array)
  (:cons (arg description etc) :alist
    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
			       description etc 'art-32b nil nil 1))
  (:ref (n description arg)
    description		;ignored
    `(aref ,arg ,n)))

#+MacLisp
(defstruct-define-type :fixnum-array
  (:cons (arg description etc) :alist
    etc
    (maclisp-array-for-defstruct arg description 'fixnum))
  (:ref (n description arg)
    description		;ignored
    `(arraycall fixnum ,arg ,n)))

#+LispM
(defstruct-define-type :flonum-array
  (:keywords :make-array)
  (:cons (arg description etc) :alist
    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
			       description etc 'art-float nil nil 1))
  (:ref (n description arg)
    description		;ignored
    `(aref ,arg ,n)))

#+MacLisp
(defstruct-define-type :flonum-array
  (:cons (arg description etc) :alist
    etc
    (maclisp-array-for-defstruct arg description 'flonum))
  (:ref (n description arg)
    description		;ignored
    `(arraycall flonum ,arg ,n)))

#+MacLisp-10
(defstruct-define-type :un-gc-array
  (:cons (arg description etc) :alist
    etc			;ignored
    (maclisp-array-for-defstruct arg description nil))
  (:ref (n description arg)
    description		;ignored
    `(arraycall nil ,arg ,n)))

#+LispM
(defstruct-define-type :array-leader
  (:named :named-array-leader)
  (:keywords :make-array)
  (:cons (arg description etc) :alist
    (lispm-array-for-defstruct arg #'(lambda (v a i)
				       `(store-array-leader ,v ,a ,i))
			       description etc nil nil t 1))
  (:ref (n description arg)
    description		;ignored
    `(array-leader ,arg ,n)))

#+LispM
(defstruct-define-type :named-array-leader
  (:keywords :make-array)
  :named (:overhead 1)
  (:cons (arg description etc) :alist
    (lispm-array-for-defstruct
      arg
      #'(lambda (v a i)
	  `(store-array-leader ,v ,a ,(if (zerop i)
					  0
					  (1+ i))))
      description etc nil t t 1))
  (:ref (n description arg)
    description		;ignored
    (if (zerop n)
	`(array-leader ,arg 0)
	`(array-leader ,arg ,(1+ n))))
  (:predicate (description name)
    `(defsubst ,name (x)
       (typep x ',(defstruct-description-name)))))

#+LispM
(defprop :times t :defstruct-option)

#+LispM
(defstruct-define-type :grouped-array
  (:keywords :make-array :times)
  (:cons (arg description etc) :alist
    (lispm-array-for-defstruct
      arg
      #'(lambda (v a i) `(aset ,v ,a ,i))
      description etc nil nil nil
      (or (cdr (or (assq ':times etc)
		   (assq ':times (defstruct-description-property-alist))))
	  1)))
  (:ref (n description index arg)
    description		;ignored
    (cond ((numberp index)
	   `(aref ,arg ,(+ n index)))
	  ((zerop n)
	   `(aref ,arg ,index))
	  (t `(aref ,arg (+ ,n ,index))))))

#+LispM
(defun lispm-array-for-defstruct (arg cons-init description etc type named-p leader-p times)
  (let ((p (cons nil nil))
	(no-op nil))
    (defstruct-grok-make-array-args
      (cdr (assq ':make-array (defstruct-description-property-alist)))
      p)
    (defstruct-grok-make-array-args
      (cdr (assq ':make-array etc))
      p)
    (and type (putprop p type ':type))
    (and named-p (putprop p `',(defstruct-description-name) ':named-structure-symbol))
    (putprop p
	     (let ((size (if named-p
			     (1+ (defstruct-description-size))
			     (defstruct-description-size))))
	       (if (numberp times)
		   (* size times)
		   `(* ,size ,times)))	     
	     (if leader-p ':leader-length ':dimensions))
    (or leader-p
	(if (get p ':initial-value)
	    (setq no-op (make-empty))
	    (let ((type (get p ':type)))
	      (or (atom type)
		  (not (eq (car type) 'quote))
		  (setq type (cadr type)))
	      (caseq type
		((nil art-q art-q-list))
		((art-32b art-16b art-8b art-4b art-2b art-1b art-string)
		 (setq no-op 0))
		((art-float) (setq no-op 0.0))
		(t (setq no-op (make-empty)))))))
    (do ((creator
	   (let ((dims (remprop p ':dimensions)))
	     (do ((l (cdr p) (cddr l)))
		 ((null l))
	       (rplaca l `',(car l)))
	     `(make-array ,(if (null dims) 0 (car dims)) ,@(cdr p))))
	 (var (gensym))
	 (set-ups nil (if (equal (cdar l) no-op)
			  set-ups
			  (cons (funcall cons-init (cdar l) var (caar l))
				set-ups)))
	 (l arg (cdr l)))
	((null l)
	 (if set-ups
	     `((lambda (,var)
		 ,@(nreverse set-ups)
		 ,var)
	       ,creator)
	     creator)))))

#+LispM
(defun defstruct-grok-make-array-args (args p)
  (do ((l args (cddr l)))
      ((null l) p)
    (if (or (null (cdr l))
	    (not (memq (car l) '(:area :type :displaced-to :leader-list
				 :leader-length :displaced-index-offset
				 :named-structure-symbol :dimensions
				 :length :initial-value))))
	(defstruct-error
	  "defstruct can't grok these make-array arguments"
	  args))
    (putprop p
	     (cadr l)
	     (if (eq (car l) ':length)
		 ':dimensions
		 (car l)))))

#+NIL
(defun NIL-array-for-defstruct (arg description)
  (do ((creator `(make-array ',(defstruct-description-size)))
       (var (gensym))
       (set-ups nil (if (null (cdar l))
			set-ups
			(cons `(aset ,(cdar l) ,var ,(caar l))
			      set-ups)))
       (l arg (cdr l)))
      ((null l)
       (if set-ups
	   `((lambda (,var)
	       ,@(nreverse set-ups)
	       ,var)
	     ,creator)
	   creator))))

#+MacLisp
(defun maclisp-array-for-defstruct (arg description type)
  (do ((creator `(array nil ,type ,(defstruct-description-size)))
       (var (gensym))
       (no-op (caseq type
		(fixnum 0)
		(flonum 0.0)
		((t nil) nil)))
       (set-ups nil (if (equal (cdar l) no-op)
			set-ups
			(cons `(store (arraycall ,type ,var ,(caar l))
				      ,(cdar l))
			      set-ups)))
       (l arg (cdr l)))
      ((null l)
       (if set-ups
	   `((lambda (,var)
	       ,@(nreverse set-ups)
	       ,var)
	     ,creator)
	   creator))))

#+(or MacLisp-10 NIL)
(defprop :sfa-function t :defstruct-option)

#+(or MacLisp-10 NIL)
(defprop :sfa-name t :defstruct-option)

#+(or MacLisp-10 NIL)
(defstruct-define-type :sfa
  (:keywords :sfa-function :sfa-name)
  (:cons (arg description etc) :alist
    (do ((creator `(sfa-create ,(or (cdr (or (assq ':sfa-function etc)
					     (assq ':sfa-function (defstruct-description-property-alist))))
				     `',(defstruct-description-name))
			       ,(defstruct-description-size)
			       ,(or (cdr (or (assq ':sfa-name etc)
					     (assq ':sfa-name (defstruct-description-property-alist))))
				    `',(defstruct-description-name))))
	 (l arg (cdr l))
	 (var (gensym))
	 (set-ups nil (if (null (cdar l))
			  set-ups
			  (cons `(sfa-store ,var ,(caar l)
					    ,(cdar l))
				set-ups))))
	((null l)
	 (if set-ups
	     `((lambda (,var)
		 ,@(nreverse set-ups)
		 ,var)
	       ,creator)
	     creator))))
  (:ref (n description arg)
    description		;ignored
    `(sfa-get ,arg ,n))
  (:predicate (description name)
    `(defun ,name (x)
       (and (sfap x)
	    (eq (sfa-get x 'pname)
		,(or (cdr (assq ':sfa-name (defstruct-description-property-alist)))
		     `',(defstruct-description-name)))))))

#+MacLisp-10
(defstruct-define-type :hunk
  (:named :named-hunk)
  (:cons (arg description etc) :list
    description		;ignored
    etc			;ignored
    (if arg
	`(hunk ,.(nconc (cdr arg) (ncons (car arg))))
	(defstruct-error "No slots in hunk type defstruct")))
  (:ref (n description arg)
    description		;ignored
    `(cxr ,n ,arg)))

#+MacLisp-10
(defstruct-define-type :named-hunk
  :named (:overhead 1)
  (:cons (arg description etc) :list
    etc			;ignored
    (if arg
	`(hunk ',(defstruct-description-name)
	       ,.(nconc (cdr arg) (ncons (car arg))))
	`(hunk ',(defstruct-description-name) nil)))
  (:ref (n description arg)
    description		;ignored
    (cond ((= n 0) `(cxr 0 ,arg))
	  (t `(cxr ,(1+ n) ,arg))))
  (:predicate (description name)
    `(defun ,name (x)
       (and (hunkp x)
	    (eq (car x) ',(defstruct-description-name))))))

#+(or MacLisp-10 NIL)
(defstruct-define-type :vector
  (:named :named-vector)
  (:cons (arg description etc) :list
    description		;ignored
    etc			;ignored
    `(vector ,@arg))
  (:ref (n description arg)
    description		;ignored
    `(vref ,arg ,n)))

#+(or MacLisp-10 NIL)
(defstruct-define-type :named-vector
  :named (:overhead 1)
  (:cons (arg description etc) :list
    etc			;ignored
    `(vector ',(defstruct-description-name) ,@arg))
  (:ref (n description arg)
    description		;ignored
    `(vref ,arg ,(1+ n)))
  (:predicate (description name)
    `(defun ,name (x)
       (and (vectorp x)
	    (eq (vref x 0) ',(defstruct-description-name))))))

#+NIL
(defprop :class-symbol t :defstruct-option)

#+NIL
(defstruct-define-type :extend
  :named
  (:defstruct (description)
    (if (assq ':class-symbol (defstruct-description-property-alist))
	;; if class-symbol is given then assume user is setting up
	;; his own class.
	()
	(let* ((name (defstruct-description-name))
	       (class-symbol (append-symbols name '-class)))
	  (push (cons ':class-symbol class-symbol)
		(defstruct-description-property-alist))
	  `((defstruct-class-setup ,name ,class-symbol)))))
  (:cons (arg description etc) :alist
    etc			;ignored
    (do ((l arg (cdr l))
	 (creator `(si:make-extend
		    ,(defstruct-description-size)
		    ,(cdr (assq ':class-symbol
				(defstruct-description-property-alist)))))
	 (var (gensym))
	 (set-ups () (if (null (cdar l))
			 set-ups
			 (cons `(si:xset ,var ,(caar l) ,(cdar l))
			       set-ups))))
	((null l)
	 (if set-ups
	     `((lambda (,var)
		 ,.(nreverse set-ups)
		 ,var)
	       ,creator)
	     creator))))
  (:ref (n description arg)
    description		;ignored
    `(si:xref ,arg ,n))
  (:predicate (description name)
    `(defsubst ,name (x)
       (of-type x ',(defstruct-description-name)))))

(defstruct-define-type :list
  (:named :named-list)
  (:cons (arg description etc) :list
    description		;ignored
    etc			;ignored
    `(list ,.arg))
  (:ref (n description arg)
    description		;ignored
 #+Multics
    `(,(let ((i (\ n 4)))
	 (cond ((= i 0) 'car)
	       ((= i 1) 'cadr)
	       ((= i 2) 'caddr)
	       (t 'cadddr)))
      ,(do ((a arg `(cddddr ,a))
	    (i (// n 4) (1- i)))
	   ((= i 0) a)))
 #-Multics
    `(nth ,n ,arg))
  (:copier (description name)
    (do ((l `((car x)) (cons `(prog1 (car x) (setq x (cdr x))) l))
	 (i (defstruct-description-size) (1- i)))
	((<= i 1)
	 `(defun ,name (x)
	    (list ,@l))))))

(defstruct-define-type :named-list
  :named (:overhead 1)
  (:cons (arg description etc) :list
    etc			;ignored
    `(list ',(defstruct-description-name) ,.arg))
  (:ref (n description arg)
    description		;ignored
 #+Multics
    `(,(let ((i (\ (1+ n) 4)))
	 (cond ((= i 0) 'car)
	       ((= i 1) 'cadr)
	       ((= i 2) 'caddr)
	       (t 'cadddr)))
      ,(do ((a arg `(cddddr ,a))
	    (i (// (1+ n) 4) (1- i)))
	   ((= i 0) a)))
 #-Multics
    `(nth ,(1+ n) ,arg))
  (:predicate (description name)
    `(defun ,name (x)
       (and
      #-MacLisp-10
	 (not (atom x))
      #+MacLisp-10	;Watch out for hunks!
         (eq (typep x) 'list)
	 (eq (car x) ',(defstruct-description-name)))))
  (:copier (description name)
    (do ((l `((car x)) (cons `(prog1 (car x) (setq x (cdr x))) l))
	 (i (defstruct-description-size) (1- i)))
	((<= i 1)
	 `(defun ,name (x)
	    (setq x (cdr x))
	    (list ',(defstruct-description-name) ,@l))))))

(defstruct-define-type :list*
  (:cons (arg description etc) :list
    description		;ignored
    etc			;ignored
    `(list* ,.arg))
  (:ref (n description arg)
    (let ((size (1- (defstruct-description-size))))
   #+Multics
      (do ((a arg `(cddddr ,a))
	   (i (// n 4) (1- i)))
	  ((= i 0)
	   (let* ((i (\ n 4))
		  (a (cond ((= i 0) a)
			   ((= i 1) `(cdr ,a))
			   ((= i 2) `(cddr ,a))
			   (t `(cdddr ,a)))))
	     (if (< n size) `(car ,a) a))))
   #-Multics
      (if (< n size)
	  `(nth ,n ,arg)
	  `(nthcdr ,n ,arg))))
  (:defstruct (description)
    (and (defstruct-description-include)
	 (defstruct-error
	   "Structure of type list* cannot include another"
	   (defstruct-description-name)))
    nil)
  (:copier (description name)
    (do ((l `(x) (cons `(prog1 (car x) (setq x (cdr x))) l))
	 (i (defstruct-description-size) (1- i)))
	((<= i 1)
	 `(defun ,name (x)
	    (list* ,@l))))))

(defstruct-define-type :tree
  (:cons (arg description etc) :list
    etc			;ignored
    (if (null arg) (defstruct-error
		     "defstruct cannot make an empty tree"
		     (defstruct-description-name)))
    (make-tree-for-defstruct arg (defstruct-description-size)))
  (:ref (n description arg)
    (do ((size (defstruct-description-size))
	 (a arg)
	 (tem))
	(nil)
      (cond ((= size 1) (return a))
	    ((< n (setq tem (// size 2)))
	     (setq a `(car ,a))
	     (setq size tem))
	    (t (setq a `(cdr ,a))
	       (setq size (- size tem))
	       (setq n (- n tem))))))
  (:defstruct (description)
    (and (defstruct-description-include)
	 (defstruct-error
	   "Structure of type tree cannot include another"
	   (defstruct-description-name)))
    nil)
  (:copier (description name)
    `(defun ,name (x)
       ,(copy-tree-for-defstruct nil (defstruct-description-size)))))

(defun make-tree-for-defstruct (arg size)
  (cond ((= size 1) (car arg))
	((= size 2) `(cons ,(car arg) ,(cadr arg)))
	(t (do ((a (cdr arg) (cdr a))
		(m (// size 2))
		(n (1- (// size 2)) (1- n)))
	       ((zerop n)
		`(cons ,(make-tree-for-defstruct arg m)
		       ,(make-tree-for-defstruct a (- size m))))))))

(defun copy-tree-for-defstruct (popx? size)
  (cond ((= size 1)
	 (if popx?
	     `(prog1 (car x) (setq x (cdr x)))
	     `x))
	((= size 2)
	 (if popx?
	     `((lambda (x) (cons (car x) (cdr x)))
	       (prog1 (car x) (setq x (cdr x))))
	     `(cons (car x) (cdr x))))
	(popx?
	 `((lambda (x)
	     (cons ,(copy-tree-for-defstruct t (// size 2))
		   ,(copy-tree-for-defstruct nil (- size (// size 2)))))
	   (prog1 (car x) (setq x (cdr x)))))
	(t
	 `(cons ,(copy-tree-for-defstruct t (// size 2))
		,(copy-tree-for-defstruct nil (- size (// size 2)))))))

(defstruct-define-type :fixnum
  (:cons (arg description etc) :list
    etc			;ignored
    (and (or (null arg)
	     (not (null (cdr arg))))
	 (defstruct-error
	   "Structure of type fixnum must have exactly 1 slot to be constructable"
	   (defstruct-description-name)))
    (car arg))
  (:ref (n description arg)
    n			;ignored
    description		;ignored
    arg))

#+Multics
(defprop :external-ptr t :defstruct-option)

#+Multics
(defstruct-define-type :external
  (:keywords :external-ptr)
  (:cons (arg description etc) :alist
    (let ((ptr (cdr (or (assq ':external-ptr etc)
			(assq ':external-ptr
			      (defstruct-description-property-alist))
			(defstruct-error
			  "No pointer given for external array"
			  (defstruct-description-name))))))
      (do ((creator `(array nil external ,ptr ,(defstruct-description-size)))
	   (var (gensym))
	   (alist arg (cdr alist))
	   (inits nil (cons `(store (arraycall fixnum ,var ,(caar alist))
				    ,(cdar alist))
			    inits)))
	  ((null alist)
	   (if (null inits)
	       creator
	       `((lambda (,var) ,.inits ,var)
		 ,creator))))))
  (:ref (n description arg)
    description	;ignored
    `(arraycall fixnum ,arg ,n)))

(defvar *defstruct-examine&deposit-arg*)

(defun defstruct-examine (*defstruct-examine&deposit-arg*
			  name slot-name)
  (eval (list (defstruct-slot-description-ref-macro-name
		(defstruct-examine&deposit-find-slot-description
		  name slot-name))
	      '*defstruct-examine&deposit-arg*)))

(defvar *defstruct-examine&deposit-val*)

(defun defstruct-deposit (*defstruct-examine&deposit-val*
			  *defstruct-examine&deposit-arg*
			  name slot-name)
  (eval (list 'setf
	      (list (defstruct-slot-description-ref-macro-name
		     (defstruct-examine&deposit-find-slot-description
		       name slot-name))
		    '*defstruct-examine&deposit-arg*)
	      '*defstruct-examine&deposit-val*)))

#+LispM
(defun defstruct-get-locative (*defstruct-examine&deposit-arg*
			       name slot-name)
  (let ((slot-description (defstruct-examine&deposit-find-slot-description
			    name slot-name)))
    (or (null (defstruct-slot-description-ppss))
	(defstruct-error
	  "You cannot get a locative to a byte field"
	  slot-name 'in name))
    (eval (list 'locf
		(list (defstruct-slot-description-ref-macro-name)
		      '*defstruct-examine&deposit-arg*)))))

(defun defstruct-examine&deposit-find-slot-description (name slot-name)
  (let ((description (get-defstruct-description name)))
    (let ((slot-description
	    (cdr (or (assq slot-name (defstruct-description-slot-alist))
		     (defstruct-error
		       "No such slot in this structure"
		       slot-name 'in name))))
	  (type-description
	    (or (get (defstruct-description-type) 'defstruct-type-description)
		(defstruct-error
		  "Undefined defstruct type"
		  (defstruct-description-type)))))
      (or (= (defstruct-type-description-ref-no-args) 1)
	  (defstruct-error
	    "defstruct-examine and defstruct-deposit cannot handle structures of this type"
	    (defstruct-description-type)))
      slot-description)))

#+MacLisp-10
(defprop defstruct
	 #.(and (status feature MacLisp-10)
		(caddr (truename infile)))
	 version)

(sstatus feature defstruct)




		    lisp_defun_.lisp                07/06/83  0938.4r w 06/29/83  1542.9       36018



;;; **************************************************************
;;; *                                                            *
;;; * 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)




		    lisp_destructuring_let_.lisp    07/06/83  0938.4r w 06/29/83  1542.9       45360



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

(%include backquote)
(declare (macros t))

(declare (special let-macro-vals))

(defprop let let/ macro macro)

(defun let/ macro (x)
 (displace x
  (do ((body (let-macro-flush-declares (cddr x)))
       (pairs (reverse (cadr x)) (cdr pairs))
       (vars nil)
       (let-macro-vals nil)
       (tem))
      ((null pairs)
       (setq body (let-macro-cons-declares (cddr x) body))
       (cond ((or (not (null vars))
	        (not (null (cdr body))))
	    `((lambda ,vars . ,body) . ,let-macro-vals))
	   (t (car body))))
      (cond ((atom (car pairs))
	   (or (symbolp (car pairs))
	       (error "Garbage found in LET pattern: " (car pairs) 'fail-act))
	   (setq vars (cons (car pairs) vars))
	   (setq let-macro-vals (cons nil let-macro-vals)))
	  (t
	    (setq tem vars)
	    (setq vars (let-macro-get-vars (caar pairs) vars))
	    (or (eq tem vars)
	        (setq body (nconc (let-macro-hair (caar pairs)
					  (cadar pairs)
					  let-macro-vals)
			      body))))))))

(defun let-macro-get-vars (pattern vars)
  (cond ((null pattern) vars)
        ((atom pattern)
         (or (symbolp pattern)
	   (error "Garbage found in LET pattern: " pattern 'fail-act))
         (setq let-macro-vals (cons nil let-macro-vals))
         (cons pattern vars))
        (t (let-macro-get-vars (cdr pattern)
			 (let-macro-get-vars (car pattern) vars)))))

(defun let-macro-flush-declares (body)
  (cond ((or (atom body)
	   (atom (car body))
	   (not (eq (caar body) 'declare)))
         body)
        (t (let-macro-flush-declares (cdr body)))))

(defun let-macro-cons-declares (obody nbody)
  (cond ((or (atom obody)
	   (atom (car obody))
	   (not (eq (caar obody) 'declare)))
         nbody)
        (t (cons (car obody) (let-macro-cons-declares (cdr obody) nbody)))))

(defprop desetq desetq/ macro macro)

(defun desetq/ macro (x)
 (displace x
  (do ((p (cdr x) (cddr p))
       (body nil)
       (tem))
      ((null p) `(progn . ,body))
      (cond ((atom (cdr p))
	   (error "Odd number of args to DESETQ: " x 'fail-act))
	  ((atom (car p))
	   (or (symbolp (car p))
	       (error "Garbage found in DESETQ pattern: " (car p) 'fail-act))
	   (and (null (car p))
	        (error "Bad DESETQ pattern: " (car p) 'fail-act))
	   (setq body (nconc body `((setq ,(car p) ,(cadr p))))))
	  (t
	    (setq tem (cons nil nil))
	    (setq body (nconc body
			  `((setq ,(let-macro-get-last-var (car p))
				. ,tem)
			    . ,(let-macro-hair (car p) (cadr p) tem)))))))))

(defun let-macro-get-last-var (pattern)
       (cond ((atom pattern) pattern)
             (t
              (or (let-macro-get-last-var (cdr pattern))
                  (let-macro-get-last-var (car pattern))))))

(defun let-macro-hair (pattern code cell)
       (cond ((null pattern) nil)
             ((atom pattern)
              (rplaca cell code)
              nil)
             (t
              ((lambda (avar dvar)
                    (cond ((null avar)
                           (cond ((null dvar) nil)
                                 (t (let-macro-hair (cdr pattern)
                                                    `(cdr ,code)
                                                    cell))))
                          ((null dvar)
                           (let-macro-hair (car pattern)
                                           `(car ,code)
                                           cell))
                          (t
                           (rplaca cell code)
                           ((lambda (acell dcell)
                                 (cons `(setq ,avar . ,acell)
                                       (nconc (let-macro-hair (car pattern)
                                                              `(car ,dvar)
                                                              acell)
                                              (cons `(setq ,dvar . ,dcell)
                                                    (let-macro-hair (cdr pattern)
                                                                    `(cdr ,dvar)
                                                                    dcell)))))
                            (cons nil nil)
                            (cons nil nil)))))
               (let-macro-get-last-var (car pattern))
               (let-macro-get-last-var (cdr pattern))))))

(defprop let* let*/ macro macro)

(defun let*/ macro (x)
 (displace x
  (cond ((null (cdadr x)) `(let . ,(cdr x)))
        (t
	(do ((a (reverse (cadr x)) (cdr a))
	     (b (let-macro-flush-declares (cddr x))
	        `((let (,(car a)) . ,b))))
	    ((null (cdr a))
	     `(let (,(car a)) . ,(let-macro-cons-declares (cddr x) b))))))))

(sstatus feature destructuring_let)




		    lisp_editor_.lisp               10/05/83  1315.9r   10/05/83  1240.2      141489



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************
;;; LISP Editor.
;;; Written 74.04.22 by DAM

;;;in this editor, internal variables and functions
;;; have names that start with a tilde (~).
;;; Tilde is defined as a macro character which changes the names to something else.
;;; The one exception is the variable, it, which is the current item.

;;;COMMANDS:
;;;
;;;	Note:  (n),(m) represent decimal numbers.  (S) represents a read-able
;;;	       S-expression, which is evaluated if a colon precedes the command.
;;;
;;; a	go to the car (of the current item).
;;; (n)a 	do a (n) times.  It stops when it hits an atom.
;;; b	go backward from the current item (following print-order).
;;; (n)b	do it (n) times.  It stops when it gets all the way up to the top.
;;; d	go to the cdr.
;;; (n)d	do it (n) times.  It stops when it hits an atom.
;;; f	go forward from the current item (in print-order).
;;; (n)f	do it (n) times.  It stops when it has wrapped around to the beginning.
;;; g	prettily print the current item (Grind).

;;; h	go to the head of the list containing current item.
;;; (n)h	do this (n) times.
;;; i(S)	insert (S) in the list which is the current item, at the front.
;;; j(S)	jump to position labelled (S), saved by rp command.
;;; k	delete the first thing in the current list.
;;; (n)k	delete (n) times.
;;; l	go to the last part of the current list.
;;;	lt prints "(...)"
;;;	lu gets to the last cons in the current list.
;;; m(S)	macro.  apply the function (S) to one argument, the current item.
;;;	it can use the various special variables declared below.
;;; n	repeat the previous search (find Next instance.) Takes numeric arguments like s.
;;;	the search is repeated from the point at which it matched.
;;; p	print the current item.
;;; q	leave the editor.
;;; ra(S)	rplaca the current item to (S).
;;; rd(S)	rplacd the current item to (S).
;;; re(S)	replaces the current item with (S).
;;; ri(S)	"remember it."  setq the variable (S) to the current item.
;;; rp(S)	"remember place."  save the current place, and label it (S).  j gets back there.
;;; s(S)	search for the next instance of (S), looking in print-order.
;;;	thus if not found in current item, can go up.
;;;	match is by equal except ?? inside (S) matches anything.
;;;	~maxlevel controls how deep it can car/cdr before it dies.
;;; 	after finding it, it does h once so you can see the surrounding context.
;;;	the 0s command is useful if you want it to stay at the place where it matched
;;; (n)s(S)  same as s(S) except after finding, it goes u (n) times.
;;; (m),(n)s(S) also binds ~maxlevel to (n).
;;; t	print the current item with limited length and depth.
;;; (n)t	print the current item, limiting length to (n) and depth to default.
;;; (m),(n)t  print the current item, limiting length to (m) and depth to (n).
;;; u	go up from the current item.  (i.e. to that item whose car or
;;;	cdr is the current item.)
;;; (n)u	go up (n) times.  Note that it won't go up past what you started editing.
;;; w	"where."  prints a skeleton of the whole thing being edited,
;;;	leading down to the current item.
;;; x(S)	execute (evaluate) (S) as LISP code.


;;; ENTRIES TO THE EDITOR:
;;;
;;;	(editf fn) - fexpr
;;;	 edits the function fn.  The definition is copied and only
;;;	 updated on the property list after the q command, so it
;;;	 is possible to ctrl/G out.
;;;
;;;	(editp atom property) - fexpr
;;;	 edits the property property of atom.  Same copy-update as editf.
;;;
;;;	(editv atom) - fexpr
;;;	 edits the value of atom.  Same copy-update as editf.
;;;
;;;	(edit S-expr) - expr
;;;	 edits arbitrary data, in place, without copying, and returns it.

;;;for losing systems that don't have strings, make a macro character:

(declare (eval (read)))

;;*eval (read)

(or (memq 'string (status features))
    (setsyntax 42 'macro '(lambda nil
                             (do ((s) (c (tyi) (tyi)))
                                 ((= c 42)
                                  (list 'quote (maknam (nreverse s))))
			 (setq s (cons c s)) ))))





;;; This macro implements the naming convention for internal editor functions and variables.
;;; currently they are on the regular obarray but the names begin and end with a plus sign.

(declare (eval (read)))

(setsyntax '/~ 'macro '(lambda nil (implode (cons '+ (nconc (exploden (read)) '(+))))))

;;; declaration of how the editor's place is remembered.

(declare (special it ~stack))	;it=current item
			;~stack = list of dotted pairs (it.car) or (it.cdr).

;;; routines to move around in the current item.
;;; they return non-nil if they find they can't move.

(defun ~car nil
    (or (atom it)	;if done car'ing, stop and return t
        (progn
	(setq ~stack (cons (cons it 'car) ~stack))
	(setq it (car it))
	nil)))

(defun ~cdr nil
    (or (atom it)
        (progn
	(setq ~stack (cons (cons it 'cdr) ~stack))
	(setq it (cdr it))
	nil)))

(defun ~up nil
    (or (null ~stack)	;if can't go up any fiurther, return t
        (progn
	(setq it (caar ~stack))
	(setq ~stack (cdr ~stack))
	nil)))

(defun ~fwd nil		;go forward, in print-order
    (cond ((not (atom it))	;can go down
	 (~car))
	((~fwd1)) ))	;can't go down, try to go up and forward

(defun ~fwd1 nil
    (cond ((null ~stack))	;can't go up cause there ain't nothing there.
	((eq (cdar ~stack) 'cdr)	;got here by cdr, keep going up.
	 (~up)
	 (~fwd1))
	(t		;got here by car, go up and over.
	 (~up)
	 (and (~cdr)	;go up, try to go over
	      (~fwd1) ))))	;can't, go fwd again. (end of list)

(defun ~back nil		;go backward, in print-order
    (cond ((null ~stack))		;error return, we are all the way back.
	((eq (cdar ~stack) 'car)	;got here by car, back up.
	 (~up))
	(t			;got here by cdr, go back and down.
	 (setq it (caaar ~stack))
	 (rplacd (car ~stack) 'car)
	 nil)))			;success return.

(defun ~listop nil		;get to top (head) of list containing current item.
 (or (~up)		;go up into containing list.
    (cond ((null ~stack) t)	;done if at top. (and can't go farther)
	((eq (cdar ~stack) 'car) nil)	;done if this is a list element, not partial list.
	((~listop)) )))	;this is a partial list, go up and try again.

(defun ~last nil		;get to end of current list.
    (cond ((atom it))	;no conses.
	(t (~cdr)		;not end, take cdr and
	   (~last))))	;loop until end of list.


(declare (special ~arg ~colon))

(defun ~arg (number default)		;get numeric argument
    (do ((number number (1- number))
         (argl (reverse ~arg) (and argl (cdr argl))))
        ((= number 1)
         (cond (argl (car argl))
               (default))) ))

(defun ~read nil			;read S-expression argument.
    (cond (~colon (eval (read)))
	((read)) ))


(declare (special prinlevel prinlength ~prinlevel ~prinlength) (fixnum prinlevel prinlength ~prinlevel ~prinlength (tyi)))
 (setq ~prinlevel 3 ~prinlength 4)

(defun ~print (prinlevel prinlength)
      (cond ((and ~stack (eq (cdar ~stack) 'cdr))		;this is a partial list.
	   (princ "(...")					;print it specially.
	   (~print2)
	   (princ ")"))
	  (t (prin1 it)))	;normal data, just print it.
	)

(defun ~print2 nil		;routine to print interior of partial list.
    ((lambda (prinlevel z)
;	(mapc '(lambda (x) (princ " ") (prin1 x))
;	      it)
	(do x it (cdr x) (atom x)	;mapc questionable because list is dotted
		(princ " ") (prin1 (car x)))
	(cond (z
		(princ " . ")
		(prin1 z)))
	)
     (and prinlevel (1- prinlevel))
     (cond ((atom it) it) ((cdr (last it)))) ))

(defun ~erase macro (x)
    (cond ((memq 'its (status features))
           '(cursorpos 'C))
	(t '(tyo 14))))

(defun ~clear macro (x)
    (cond ((memq 'newio (status features))
	 '(clear-input nil))
	(nil)))

;;;search routine


(declare (special ~search-arg ~search-loc ~maxlevel) (fixnum ~maxlevel))
(setq ~search-loc nil ~search-arg nil)

(declare (eval (read)))
 (or (memq 'string (status features))
     (defun macro stringp (x) nil))	;make dummy stringp if there are no strings.


(defun ~compare (x y level)		;compares two items, using ?? and care with level.
				;x is the pattern, in which ?? may appear.
    (cond ((eq x '/?/?)
	 t)			;?? matches anything - return t.
	((numberp x)		;numbers are compared with equal
	 (equal x y))
	((stringp x)		;so are strings
	 (equal x y))
	((atom x)			;other atoms are compared with eq
	 (eq x y))
	((atom y)			;make sure both are lists
	 nil)			;(atom can't match list)
	((> level ~maxlevel)	;if we are too deep, they can't be equal.
	 nil)
	((and (~compare (car x) (car y) (1+ level))
	      (~compare (cdr x) (cdr y) (1+ level))))))


(defun ~search (x)			;x is item to be searched for.
    (do ((~maxlevel (~arg 2 300.))) nil
     loop
	(and (~fwd) (error "S: fail"))
	(or (~compare x it (length ~stack))
	    (go loop))	;not found, keep searching.
	(setq ~search-loc (cons it ~stack))	;remember for N command.
	(do i (~arg 1 1) (1- i) (< i 1)
	   (~listop))
	))

;;;;command - interface routines

(defun editf fexpr (x)
    (setq x (~editp (car x) '(expr fexpr macro)))
    (cond ((atom x) x)	;won
	('(undefined function)) )) ;lost

(defun editp fexpr (x)
    (~editp (car x) (cadr x)))

(defun ~editp (f p)
    (and (atom p) (setq p (list p)))
    (setq p (getl f p))
    (cond ((null p) '(property not found))
	(t
	  (rplaca (cdr p)
		((lambda (it ~stack) (~edit))
		     (subst nil nil (cadr p))
		     nil))
	  'LISP)))

(defun editv fexpr (x)
    (cond ((not (boundp (setq x (car x))))
	 '(variable is undefined))
	(t (set x ((lambda (it ~stack) (~edit))
			(subst nil nil (eval x)) nil))
	   'LISP)))

(defun edit (x)
    ((lambda (it ~stack) (~edit))
	x nil))

;;;main editor

(declare (*expr sprinter))

(defun ~edit nil		;called with it, ~stack bound to initial values.
  (terpri)
  (do ((x) (save-it) (save-stack) (places) (~colon) (~arg) (cmd)) (nil)	;do forever
    (setq cmd (tyi))
    (and (> cmd 140) (setq cmd (- cmd 40)))	;monocase
		;the following cond, which does it all, is enclosed in an errset.
    (setq save-it it save-stack ~stack)
    (or (errset (progn
    (cond ((= cmd 40))			;ignore space,
	((= cmd 12))			;linefeed,
	((= cmd 15))			;carriage-return,
	((= cmd 14)			;newpage - erase the screen.
	 (~erase))
	((and (> cmd 57) (< cmd 72))		;digit - accumulate number.
	 (or ~arg (setq ~arg (list 0)))
	 (rplaca ~arg (+ (* (car ~arg) 10.) cmd -60))
	 (go numeric-value))
	((= cmd 72)			;colon
	 (setq ~colon t)
	 (go numeric-value))
	((= cmd 54)			;comma
	 (setq ~arg (cons 0 ~arg))		;begin new numeric argument.
	 (go numeric-value))
	((setq x (assoc cmd '((101 . ~car)	;motion commands: a,b,d,f,u.
			  (102 . ~back)
			  (104 . ~cdr)
			  (106 . ~fwd)
			  (110 . ~listop)
			  (125 . ~up)) ))
	 (do i (~arg 1 1) (1- i) (< i 1)
		(and ((cdr x)) (return nil)) ))	;do (n) times, or until it says stop.
	((= cmd 107)			;g command - grind it
	 (terpri)
	 (sprinter it)
	 (terpri))
	((= cmd 111)			;i command - insert in list
	 (or ~stack (error "Can't insert!"))
	 (setq x (cons (~read) it))		;new front of list, will replace 'it'
	 (setq ~search-loc nil)		;clobbering.
	 (and (eq (caaar ~stack) it)
	      (rplaca (caar ~stack) x))
	 (and (eq (cdaar ~stack) it)
	      (rplacd (caar ~stack) x))
		;should patch it to x everywhere it appears in places, but not with subst.
		;cases are:  has become inaccessible, has become inaccessible through different path.
	 (setq it x))
	((= cmd 112)			;j command - today we choose places.
	 (setq x (assq (~read) places))	;find saved place.
	 (or x (error "No RP command was done with that tag."))
	 (setq ~search-loc nil)		;clobbering.
	 (setq it (cadr x) ~stack (cddr x)))
	((= cmd 113)			;k command - delete from list.
	 (or ~stack (error "Can't kill."))
	 (setq ~search-loc nil)		;clobbering.
	 (do ((i (~arg 1 1) (1- i))
	      (x it (cdr x)))
	     ((or (< i 1) (atom x))
	      (and (eq it (caaar ~stack))
		 (rplaca (caar ~stack) x))
	      (and (eq it (cdaar ~stack))
		 (rplacd (caar ~stack) x)) 
	      (setq it x) ))
		;should also patch places as with I command.
	       )
	((= cmd 114)			;l command - last of list.
	 (~last))
	((= cmd 115)			;m command - macro.
	 (funcall (~read) it))
	((= cmd 116)			;n command - repeat search.
	 (or ~search-arg (error "No search to repeat."))
	 (or ~search-loc (princ "Loose Search..."))
	 (and ~search-loc (setq it (car ~search-loc) ~stack (cdr ~search-loc)))
	 (~search ~search-arg))
	((= cmd 120)			;p command - print it.
	 (terpri)
	 (~print nil nil)
	 (terpri))
	((= cmd 121)			;q command - depart.
	 (do () ((~up)))			;go all the way up.
	 (return it))			;and return the result of editing to caller.
	((= cmd 122)			;r commands - 2 letters:
	 (setq cmd (tyi))
	 (and (> cmd 140) (setq cmd (- cmd 40)))	;monocase
	 (cond ((= cmd 101)			;ra command - rplaca
	        (and (atom it) (error "RA: atom?"))
	        (rplaca it (~read)))
	       ((= cmd 104)			;rd command - rplacd
	        (setq ~search-loc nil)		;prob. clobbering
	        (and (atom it) (error "RD: atom?"))
	        (rplacd it (~read)))
	       ((= cmd 105)			;re command - replace it.
	        (or ~stack (error "Can't replace!"))	;LIE.
	        (setq x (~read))
	        (setq ~search-loc nil)	;clobbering.
	        (and (eq it (caaar ~stack))
		   (rplaca (caar ~stack) x))
	        (and (eq it (cdaar ~stack))
		   (rplacd (caar ~stack) x))
	        (setq it x))
	       ((= cmd 111)			;ri command - remember it.
	        (set (~read) it))
	       ((= cmd 120)			;rp command - remember place.
	        (setq places (cons (cons (~read) (cons it ~stack))
			        places)))
	       ((error (maknam (list 122 cmd '/: '/  '/?))))))
	((= cmd 123)			;s command -search
	 (~search (setq ~search-arg (~read))))
	((= cmd 124)			;t command - type out with limitation.
	 (terpri)
	 (~print (~arg 2 ~prinlevel) (~arg 1 ~prinlength))
	 (terpri))
	((= cmd 127)			;w command - tell where we are.
	 (terpri)
	 (~where (reverse ~stack))
	 (terpri))
	((= cmd 130)			;x command - evaluate cruft
					;also treats colon differently.
	 (setq x (eval (read)))
	 (and ~colon (progn (print x)(terpri))))
	((error (maknam (list cmd '/: '/  '/?)))))	;unknown command.  This also ends the errset.
    nil))	;make the cond not be for value and end the progn and the errset.
        ;come here when an error occurred.
        (~clear)				;flush already-typed commands.
        (setq it save-it ~stack save-stack))	;error - restore values
    (setq ~arg nil ~colon nil)			;finished with command, clear arguments for next command.
numeric-value					;go here if numeric-value to be kept.
    ))	;keep on looping in the do.

;;;Routine to Reveal Context - W command.

(defun ~where (st)
    (cond ((null st)			;here we are
	 (~print (~arg 2 ~prinlevel) (~arg 1 ~prinlength)))
	(t		;go down into a list
	  (princ "(")
	  (do ((x nil t) (y nil x) (this (caar st)))
	      ((or (null st) (eq (cdar st) 'car))
	       (and x	;this is not first, put first atom in car, dot dot dot
		  (progn
		    (~atomic-car (car this))
		    (cond (y (princ "..."))	;put three dots if item is not 1st or second
		          ((princ " ")) )))
		;display the item
	       (cond (st		;item is list element.
		    (~where (cdr st))
		    (and (cdaar st) (princ "...")))	;not last in list
		   ((atom it)	;dotted pair - item is cdr of.
		    (princ " . ")
		    (prin1 it))
		   (t		;partial list.
		    (~print2)))
	      (princ ")"))
	   (setq st (cdr st))))))

(defun ~atomic-car (this)
    (cond ((atom this)
	 (prin1 this))
	(t
	 (princ "(")
	 (~atomic-car (car this))
	 (and (cdr this) (princ "..."))
	 (princ ")"))))




		    lisp_format_.lsb                07/06/83  0938.4re  06/29/83  1543.0     1292067



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************
;5:45pm  Tuesday, 23 February 1982   -*-  Mode:Lisp;  LSB:Format,Format  -*-

;;;; Maclisp FORMAT

; For now, a bootstrap:
(eval-when (compile)
    ; Note that because of Multics LSB deficiencies, it is necessary
    ; for things to be ordered properly.  This is the main reason
    ; why the documentation is so randomly ordered.
    (cond ((status feature Multics)
	   (load ">udd>Mathlab>LSB>compilation-environment.lisp")
	   (%include backquote))))


(module format format)

{(only-for PDP-10)
   (declare (muzzled t) (setq use-strt7 t))
   (cond ((fboundp 'ferror))
	 ((equal (get 'ferror 'autoload) (get 'format 'autoload))
	    ; Certain old things may think that FERROR comes with FORMAT.
	    (defun ferror n
		(funcall autoload '(ferror . ((lisp) cerror)))
		(apply 'ferror (listify n))))
	 ((not (get 'ferror 'autoload))
	    (defprop ferror ((lisp) cerror) autoload)))
   }

{-- The documentation will be constructed in several sections, with
the intent of having them concatentated together again to make a
chapter of documentation.
	PROLOG	-  the introduction, and the .defun of FORMAT and ?FORMAT.
	OPS	-  .table of the operators
	PUBDOC	-  other public functions/variables/descriptions/crap
	IDEFS	-  documentation of things needed for "defining your own"
	STRING  -  cruft having to do with FORMAT using "strings"
	CHART	-  a one-page very brief listing of the commands
}

{(only-for PDP-10)
   {-- This drives whether or not we will allow the format operator
       properties to be subr pointers themselves.  This is detected
       by their being of typep RANDOM.  so instead of doing
       (defun (a format-ctl-one-arg) ...) one can do
       (defun (a format-ctl-one-arg format-ctl-one-arg) ...)
       and not have that random gratuitous unnecessary symbol.
       NOTE!  it does not work on Multics because of the way defun
       gets redefined to hack &-keywords (if in fact the three-list
       type of defun ever worked).  So this conditional hack should
       NOT be used on multics until that is fixed, if ever.
       }
   (forms-needed-for (system-compilation)
      (sstatus feature Format-Subr-Properties))
   }

{(divert-documentation-to prolog)
.chapter "Format"
.setq format-chapter chapter-number
.setq format-section-page section-page
.setq format-page page

.c This is the entire PROLOG documentation.  FORMAT and ?FORMAT
.c are .defuned here explicitly.

.c Lots of stuff here is copied verbatim from the Lisp Machine
.c Manual.

.defun format destination control-string 1(any-number-of*args1)*
3format* is used to produce formatted output.  3format*
outputs the characters of 2control-string*, except that tilde
("3~*") introduces a directive.  The character after the tilde,
possibly preceded by arguments and modifiers, specifies what kind of
formatting is desired.  Some directives use an element of 2args*
to create their output.
.end_defun

.c Here we break off the .defun so we can hack semantically... (sigh)

	The output is sent to 2destination*.  If
2destination* is 3nil*, a string
is created which contains the output (see section
(string-section) on 3format* and strings, (string-section-page)).
If 2destination* is 3t*, the output is sent to the "default
output destination", which in Maclisp is the output filespec
3nil*--the terminal (controlled by the variable 3^w*) and
3outfiles* (controlled by 3^r*).  With those exceptions,
2destination* may be any legitimate output file specification.
	A directive consists of a tilde, optional decimal numeric parameters
separated by commas, optional colon ("3:*") and atsign ("3@*")
modifiers, and a single character indicating what kind of directive
this is.  The alphabetic case of the character is ignored.
Examples of control strings:
.lisp
"~S"        ; 1This is an S directive with no parameters.*
"~3,4:@s"   ; 1This is an S directive with two parameters, 3 and 4,*
            ; 1   and both the colon and atsign flags.*
.end_lisp

3format* includes some extremely complicated and specialized
features.  It is not necessary to understand all or even most of its
features to use 3format* efficiently.  The beginner should
skip over anything in the following documentation that is not
immediately useful or clear.  The more sophisticated features are
there for the convenience of programs with complicated formatting
requirements.

	Sometimes a numeric parameter is used to specify a character,
for instance the padding character in a right- or left-justifying
operation.  In this case a single quote (3'*) followed by the
desired character may be used as a numeric argument.  For example,
you can use
.lisp
"~5,'0d"
.end_lisp
to print a decimal number in five columns with leading zeros (the
first two parameters to 3~D* are the number of columns and the
padding character).

	In place of a numeric parameter to a directive, you can put
the letter 3v*, which takes an argument from 2args* as a
parameter to the directive.  Normally this should be a number but it
doesn't really have to be.  This feature allows variable column-widths
and the like.  Also, you can use the character 3#* in place of a
parameter; it represents the number of arguments remaining to be
processed.
	It is possible to have a directive name of more than one
'setq multi-character-operator-page page
character.  The name need simply be enclosed in backslashes
("3\*");  for example,
.lisp
(format t "~\now\" (status daytime))
.end_lisp
As always, case is ignored here.  There is no way to quote a backslash
in such a construct.  No multi-character operators come with
3format*.
	Note that the characters 3@*, 3#*, and 3\* which
are used by 3format* are special to the default Multics input
processor, and may need to be quoted accordingly when typed in
(normally, with 3\*).
	Once upon a time, various strange and wonderful
interpretations were made on 2control-string* when it was neither
a string nor a symbol.  Some of these are still supported for
compatibility with existing code (if any) which uses them;  new code,
however, should only use a string or symbol for 2control-string*.
	This document describes an implementation of 3format*
which is currently in use in Maclisp (both PDP-10 and Multics), and is
intended to be transported to NIL.  It thus is oriented towards the
Maclisp dialect of Lisp.  The behaviour of 3format* operators
should be fairly consistent across Lisp dialects;  entries documented
here other than 3format*, however, exist only in the Maclisp
implementation at this time, although they could be added to other
3format* implementations without difficulty.
}


{(divert-documentation-to ops)
.section "The Operators"
	Here are the operators.
.table 3 250 500
}

{(divert-documentation-to chart)
.headings off
	This chart is intended only as a reminder of what 3format*
operations are available.  Most of the operators have additional
parameters and options which are not listed here.
.c Last number is leading between .items.
.table 3 300 1000 15
}

{(divert-documentation-to string)
.section "Format and Strings"
'setq string-section css-number
'setq string-section-page page
	In the PDP-10 Maclisp implementation, 3format* has
provision for using a user supplied 3string* implementation.
Normally, 3format* expects to use symbols.  However, if 3(fboundp
'stringp*) is true, then 3format* will use the 3stringp*
'findex stringp
predicate to see if its argument is a string.  If that
is the case, then the function 3string-length*
'findex string-length
will be used to find the size of the string, and 3char-n*
'findex char-n
will be
used to fetch characters out of the string.  Both of these routines
should have been declared 3fixnum* when compiled (i.e., be
ncallable).  Internally, tests are ordered such that string-ness is
independent on atomic-ness.  In addition, the 3character*
'findex character
routine may be used to canonicalize something to a character code.

	The Multics implementation is similar to the PDP-10 Maclisp
implementation, but uses different routines;  3stringlength* to
get the size of the string (or symbol), and 3getcharn* to fetch a
character out of the string.  The 3character* routine is not used.
}

;;;; Bootstrap macros


{(only-for Multics)

; Multics doesn't have NTH and NTHCDR.
(define-private-routine (format-nthcdr (fixnum index) l)
    (loop for subl on l for i from 0 below index finally (return subl)))

(define-private-open-codable-routine (format-nth (fixnum index) l)
    (declarations (use-sublis-for-open-coding)
		  (needed-for macros interpretation) ; not in object segment
		  )
    (car (format-nthcdr index l)))
}

{(except-for Multics)

(define-private-xmacro (format-nthcdr index l)
    `(nthcdr ,index ,l))

(define-private-xmacro (format-nth index l)
    `(nth ,index ,l))
}


{(only-for PDP-10)
; Randomness.
(define-private-variable *format-sail-tilde
  (reference system)
  (default-init (cond ((status feature Sail) 26.) (t -1))))
}


(define-system-open-codable-routine (format-tildep (character-code ch))
  (dcls (needed-for macros interpretation)) ; not in pdp10 fasl
  {(only-for PDP-10) (or (= ch #/~) (= ch *format-sail-tilde))}
  {(except-for PDP-10)
     (dcls (use-sublis-for-open-coding))
     (= ch #/~)})


(define-private-xmacro (format-catch
		         tag-or-list-of-tags
			 (any-number-of forms))

    {-- Multics doesn't have *CATCH or *THROW.
	  (For *THROW we just fudge where necessary.)
	PDP10 and NIL *CATCH can take a list of tags.
	Lispm *CATCH only allows one "body" form.
	All CATCH instances in format have constant tags.  So we macroify
	it thusly.
	}

    {(only-for Lispm)
       (bindq basis `(progn . ,forms))
       (cond ((atom tag-or-list-of-tags)
	        `(*catch ',tag-or-list-of-tags ,basis))
	     (t (loop for tt in tag-or-list-of-tags
		      do (setq basis `(*catch ',tt ,basis)))
		basis))}
    {(except-for Lispm)
       {(only-for Multics)
          (bindq basis `(progn . ,forms))
	  (cond ((atom tag-or-list-of-tags)
		   `(catch ,basis ,tag-or-list-of-tags))
		(t (loop for tt in tag-or-list-of-tags
			 do (setq basis `(catch ,basis ,tt)))
		   basis))}
       {(except-for Multics)
	  `(*catch ',tag-or-list-of-tags . ,forms)}})


;Get the string-length of the frobozz used internally by Format.  Depending
; on the implemenetation, this may be always a string (Lispm and NIL, where
; doing symbol->string coercion involves no consing) or a string or symbol
; (as in Maclisp).
(define-system-xmacro (format-string-length frobozz)
  ; Get the "string-length" of either a string or symbol.
  {(only-for (or Lispm NIL))
     `(string-length ,frobozz)}
  {(except-for (or Lispm NIL))
     {(only-for Multics)
        ;STRINGLENGTH is faster than FLATC and works on both symbols
	; and strings.
	`(stringlength ,frobozz)}
     {(except-for Multics)
        ;FLATC is best for symbols, and will work for user strings,
	; so we use it for them so we don't have to check.
	`(flatc ,frobozz)}})



{(only-for PDP-10)
   {-- PDP10 Maclisp normally implements doublequoted frobnitzes as uninterned
       symbols which self-evaluate.  They get dumped out "properly" in the
       fasl file.  However, all uses in FORMAT are restricted such that they
       only need to pseudo-self-evaluate when used, not when passed around.
       So in the compiler, we turn them into squidified symbols;  this has
       the effect of keeping them as symbols, making them seem to
       self-evaluate in the compiler, but not making the compiled output
       contain lots of extra garbage.
       }
   (forms-needed-for (system-compilation)
       (setsyntax '/" 'macro
		  '(lambda ()
		      (do ((ch (tyi) (tyi)) (l nil (cons ch l)))
			  ((= ch #/")
			     (setq l (nreverse l))
			     (cond (compiler-state
				      (list squid (list 'quote (implode l))))
				   (t (setq l (maknam l)) (set l l))))
			(and (= ch #//) (setq ch (tyi)))))))

   {-- Similarly, we find that doing a STRT type PRINC is better than
       a TYO of 2 args, in terms of amounts of inline code.  So we do:}
   (define-system-optimizer (tyo char (optional stream))
       (and (or (fixp char)
		(and (not (atom char))
		     (eq (car char) 'quote)
		     (fixp (setq char (cadr char)))))
	    (not (or (null stream)
		     (and (not (atom stream))
			  (eq (car stream) 'quote)
			  (null (cadr stream)))))
	    `(princ ',(ascii char) ,stream)))
   }



;;;; Random Declarations, stringp stuff


; The following may be used, and either aren't defined here, or may be
; used before defined:

(declare-routine (ferror condition-name control-string
			 (any-number-of arguments))
    (slow-and-hairy))


{(only-for PDP-10)

(declare-routine (stringp frob)

    (value-type truthvalue))


(declare-routine (string-length string)

    (value-type fixnum))


(declare-routine (char-n string (fixnum index))

    (value-type character-code))


(declare-routine (character frob)

    ; (value-type character-code)
    ; Jonl's isn't declared properly yet
    )
}

{(only-for PDP-10)
; We keep this because a call to (status feature foo) takes over 100.
; instructions simply to get to the MEMQ part, at which point the
; MEMQ of a typical feature list could take another 100.  It will
; be set again at each major call into FORMAT if it is NIL.

(define-private-variable *format-in-string-environment?
    (reference system)
    (init (status feature string)))
}


(define-system-xmacro (format-stringp frob)
    ; to make the stringp test easier, based on the above flag:
    {(only-for PDP-10) `(and *format-in-string-environment? (stringp ,frob))}
    {(except-for PDP-10) `(stringp ,frob)})


;;;; Random stream stuff

{(public-documentation)
.section "Other Entries"
}


{(only-for PDP-10)
; And here is some LAP code to help.

(define-private-routine (format-stream-ops x)
    )

(lap-a-list
  '((lap format-stream-ops subr)
    (args format-stream-ops (nil . 1))

    (defsym asar 0 ttsar 1 as*fil 40000 as*sfa 200000 tts*ty 400)

    format-stream-ops
	(movei ar1 0 a)
	(jsp tt xfosp)
	  (ler3 0 (% sixbit |NOT FILE OR SFA!|))
	  (jrst 0 frob-is-file)
	;;;(movei tt sfcali)
	(setzb tt c)
	(movei b 'which-operations)
	(xct 0 @ 1 a)
	(popj p)

    frob-is-file
	(movei a '(cursorpos charpos linel tyo terpri))
	(move tt ttsar ar1)
	(tlnn tt tts*ty)
	  (hrrz a 0 a)
	(popj p)
    nil))
}


{(except-for Maclisp)

(define-private-xmacro (format-stream-call stream op (any-number-of args))
    `({NIL send} {Lispm funcall} ,stream ,op . ,args))

(define-private-routine (format-decode-output-stream stream)
    {(only-for Lispm)
       (dcls (open-code) (use-sublis-for-open-coding))
       (si:decode-print-arg stream)
       }
    {(except-for Lispm)
       (cond ((null stream) standard-output)
	     ((or (eq stream 't) (eq stream #T)) terminal-io)
	     ('t stream))
       }
    )
}


;;;; where we find the operators

{(divert-documentation-to idefs)
.section "Defining your own"
.setq define-your-own-section-page section-page
}

{(only-for Maclisp)
   (define-private-variable *format-obarray
        (default-init obarray))
   }
{(except-for Maclisp)
   (define-private-variable *format-package
        (default-init package))
   }


{(only-for Maclisp)
  (divert-forms-to (compilation-environment sysdcl)
     (array* (notype (format-char-table ?))))
}

{(only-for NIL)
(define-system-variable *format-character-table
  (reference public)
  (data-type vector)
  (default-init (loop with v = (make-vector 256.)
		      for x being the vector-elements of v using (index i)
		      do (vset v i (intern (string-upcase (to-string i))
					   *format-package))
		      finally (return v))))

(define-system-open-codable-routine (format-char-table (fixnum index))
    (dcls (use-sublis-for-open-coding) (reference public))
    (vref *format-character-table index))
}


{(except-for NIL)
   ((lambda (n)
       (array format-char-table t n)
       (do ((obarray *format-obarray) (i 0 (1+ i))) ((= i n))
	 (store (format-char-table i)
		(ascii (cond ((lessp #.(1- #/a) i #.(1+ #/z))
				(- i #.(- #/a #/A)))
			     (t i))))))
    {(only-for Lispm) 256.}
    {(except-for Lispm) 128.})
   }


;;;; Defining FORMAT operators

{(system-documentation)
	For convenience, one may use the following to define
3format* operators.
}

;Canonicalise a format operator name, as an interned symbol.
(define-private-routine (make-format-op-name name)
  (dcls (needed-for public-compilation umacs))
  {(only-for Maclisp)
     (implode (loop for c in (if (fixp name) (list name) (exploden name))
		    collect (if (lessp #.(1- #/a) c #.(1+ #/z))
				(- c #.(- #/a #/A))
				c)))
     }
  {(except-for Maclisp)
     ;Assume string-upcase does appropriate conversion (character, fixnum,
     ; etc.)
     (intern (string-upcase name))
     }
  )


(define-private-routine (format-make-propdef item value propname)
  (dcls (needed-for umacs public-compilation))
  `((lambda (s) (remprop s ',propname) (putprop s ',value ',propname))
    ,(lsb:mx-full `(format-make-realsym ',item))))


{(only-for Resident-Format)
(define-private-routine (format-make-realsym name)
  (dcls (also-needed-for private-compilation))
  (if (= (flatc name) 1)
      (format-char-table (getcharn name 1))
      {(only-for Maclisp)
         ((lambda (obarray)
	    {(only-for Multics) (make_atom (get_pname name))}
	    {(except-for Multics) (pnput (pnget name 7) t)})
	  *format-obarray)}
      {(except-for Maclisp) (intern (get-pname name) *format-package)}))
}

{(except-for Resident-Format)
(define-private-xmacro (format-make-realsym name)
  (dcls (needed-for public-compilation macros))
  (if (and (not (atom name)) (eq (car name) 'quote) (= (flatc (cadr name)) 1))
      `(format-char-table ,(getcharn (cadr name) 1))
      `((lambda (name)
	  (cond ((= (flatc name) 1)
		  (format-char-table (getcharn name 1)))
		({(only-for Maclisp)
		    `((lambda (obarray)
			{(only-for Multics) (make_atom (get_pname name))}
			{(except-for Multics) (pnput (pnget name 7) t)})
		      *format-obarray)}
		 {(except-for Maclisp)
		    (intern (get-pname name) *format-pacakge)})))
	,name)))
}

{(only-for Resident-Format)
(define-private-routine (format-make-op-setup name prop)
  (auxs (newname (format-make-realsym name)))
  (cond ((not (eq name newname))
	 (remprop newname prop)			; simulate a defprop
	 (putprop newname (car (remprop name prop)) prop)))
  ())
}

{(except-for Resident-Format)
(define-private-macro (format-make-op-setup name prop)
  (dcls (needed-for public-compilation umacs))
  ;Following isn't really necessary, but makes life simpler and also
  ; allows the format-make-realsym to optimize.
  (or (and (and (not (atom name)) (eq (car name) 'quote))
	   (and (not (atom prop)) (eq (car prop) 'quote)))
      (error '|format-make-op-setup loss| (list name prop)))
  `((lambda (newname)
      (cond ((not (eq ,name newname))
	     (remprop newname ,prop)		; simulate a defprop
	     (putprop newname (car (remprop ,name ,prop)) ,prop))))
    ;This mx-full kludge is for Multics which doesn't (currently)
    ; do recursive macro-expansion on toplevel forms (eval mungeables).
    ,(lsb:mx-full `(format-make-realsym ,name))))
}


;;;; Actually define the operator

(define-public-macro (define-format-op name arglist (body body-forms))
  (dcls (divdoc idefs) (needed-for public-compilation umacs))
  (setq name (make-format-op-name name))
  (bindq newname () def-form () propname ())
  (cond ((fixp arglist)
	   (format-make-propdef name arglist 'format-ctl-repeat-char))
	('t (setq propname
		  (cond ((null (cdr arglist)) 'format-ctl-no-arg)
			((atom (cdr arglist))
			   (setq arglist (list (cdr arglist) (car arglist)))
			   'format-ctl-multi-arg)
			('t (setq arglist (list (cadr arglist) (car arglist)))
			    'format-ctl-one-arg)))
	    (setq newname (list name propname
				{Format-Subr-Properties propname}))
	    (setq def-form
		  (if (status feature lsb)
		      `(define-private-routine (,newname . ,arglist)
			 . ,body-forms)
		      `(defun ,newname ,arglist . ,body-forms)))
	    `(progn 'compile
		    ,def-form
		    (format-make-op-setup ',name ',propname)))))



{(document-routine)
This may be used in two formats:
.lisp
(define-format-op 2operator* 2varlist* 2body-forms...*)
.end_lisp
and
.lisp
(define-format-op 2operator* 2fixnum-character-code*)
.end_lisp
The 2operator* may be the fixnum code for a character, or a symbol
with the same print-name as the operator.  Whichever, it is
canonicalized (into upper case) and will be interned into the same
obarray/package which 3format* resides in.
For example, the 3format* operator for 2tilde* could be
defined as
.lisp
(define-format-op /~ #/~)
.end_lisp
where "#/~" represents the fixnum character code for tilde.
.break
For the first format, the type of operator is determined by decoding
2varlist*, which may have one of the following formats:
.table 3 250 500
.item (2params-var*)
An operator of exactly zero arguments;  2params-var* will get
bound to the parameters list.
.item (2params-var*2arg-var*)
An operator of exactly one argument;  2params-var* will get bound
to the parameters list, and 2arg-var* to the argument.
.item (2params-var*.2args-var*)
An operator of a variable number of args;  2params-var* will get
bound to the parameters list, and 2args-var* to the remaining
arguments to 3format* (or to the recursive 3~{*
'c matching "}"
arguments).  The operator should return as its value some sublist of
2args-var*, so that 3format* knows how many were used.
.end_table

A definition for the appropriate function is produced with a bvl
derived from the variables in 2varlist* and a body of
2body-forms*.  (The argument ordering in the function produced is
compatible with that on the Lisp Machine, which is 2arg-var*
(if any) first, and then 2params-var*.)
}


{(only-for PDP-10)
  (progn ; Non-modular piece of shit.
	 (defprop define-format-op |DEFINE-FORMAT-OP.RMac| macro)
	 (defprop |DEFINE-FORMAT-OP.RMac| ((lisp)format umacs) autoload)
	 )
  }


;;;; Autoloadable operators

(define-private-xmacro (define-autoload-op 
			  name arglist divstream
			  (any-number-of body-forms))

  {(except-for PDP-10) `(define-format-op ,name ,arglist . ,body-forms)}

  {(only-for PDP-10)

    (auxiliary-bindings newname propname)

    (setq name (make-format-op-name name))
    (cond ((fixp arglist)
	     (format-make-propdef name arglist 'format-ctl-repeat-char))
	  (t (setq newname (implode (append '(/f /m /t /.)
					    (exploden name)
					    '(/. /o /p /|)))
		   propname
		   (cond ((null (cdr arglist)) 'format-ctl-no-arg)
			 ((atom (cdr arglist))
			    (setq arglist (list (cdr arglist) (car arglist)))
			    'format-ctl-multi-arg)
			 (t (setq arglist (list (cadr arglist) (car arglist)))
			    'format-ctl-one-arg)))
	     `(progn 'compile
		 (define-private-hack (,newname . ,arglist) ,divstream
		   . ,body-forms)
		 ,(format-make-propdef name newname propname))))
    })


(define-private-routine (hack-the-hack definition-fn prototype-call
				       divstream body-forms)
    (dcls (needed-for macros compilation interpretation))
    {(only-for PDP-10)
       `(progn 'compile
	   (,definition-fn ,prototype-call
		(dcls (needed-for ,divstream interpretation))
		. ,body-forms)
	   (or (fboundp ',(car prototype-call))
	       (defprop ,(car prototype-call)
		 ((lisp) format ,divstream) autoload)))}
    {(except-for PDP-10)
       `(,definition-fn ,prototype-call . ,body-forms)})



(define-private-xmacro (define-system-hack
		          prototype-call divstream (any-number-of forms))
    (hack-the-hack 'define-system-routine prototype-call
		   divstream forms))


(define-private-xmacro (define-private-hack
		          prototype-call divstream (any-number-of forms))
    (hack-the-hack 'define-private-routine prototype-call divstream forms))


(define-private-xmacro (define-hidden-hack
		         prototype-call divstream (any-number-of forms))

    `(define-private-routine ,prototype-call
	 {(only-for PDP-10)
	    (declarations (needed-for ,divstream interpretation))}
	 . ,forms))



;;;; Fetch an operator definition


(define-private-routine (format-op? frob)
  ;This choice has to do with the way loading treats constant datastructure
  ; appearing in multiple places.
  {PDP-10 (dcls (open-code) (use-sublis-for-open-coding) (needed-for macros))}
  (getl frob '(format-ctl-one-arg format-ctl-no-arg
	       format-ctl-multi-arg format-ctl-repeat-char)))


{(only-for PDP-10)
  (mapc '(lambda (x) (or (memq x putprop) (push x putprop)))
	'(format-ctl-repeat-char format-ctl-one-arg 
	  format-ctl-no-arg format-ctl-multi-arg))
  }

;;;; random variables

(define-public-variable standard-output
    {(except-for Maclisp) (dummy-definition)}
    (divdoc idefs))

{(document-variable)
Output from 3format* operators should be sent to the stream which
is the value of 3standard-output*.  In the Multics implementation
of 3format*, this value may sometimes be an object which is not
suitable for being fed to standard Lisp output functions (e.g.,
3princ*);  3format* has definitions of various output
functions which handle this case properly, and may be used for
defining operators which will work compatibly in Multics Maclisp.
They are documented below.  Note that because of the way 3format*
interprets its destination, it is not necessarily safe to recursively
call 3format* on the value of 3standard-output* in PDP-10
Maclisp.  It 2is* safe, however, to use 3?format*
((?format-fun)) instead, 2or* to call 3format* with a
2destination* of the symbol 3format*.
}


;;;; Gratuitous Documentation


{(divert-documentation-to idefs)
	Maclisp 3format* will also accept a 2destination* of
3format* to mean "use the 3format* destination already in
effect".  This is primarily for the benefit of Multics Maclisp, since
there the value of 3standard-output* cannot be passed around as a
stream.  The 3format* operator 3now*, which prints the current
time, could be defined as
.lisp
(define-format-op now (params)
   params		; unused
   (let ((now (status daytime)))
     (format 'format "~2,'0D:~2,'0D:~2,'0D"
	     (car now) (cadr now) (caddr now))))
.end_lisp
with the result that
.lisp
(format nil "The current time is ~\now\.")
.end_lisp
could produce the string
.lisp
"The current time is 02:59:00."
.end_lisp
}

;;;; More variables

;;;*****  Note!  Due to autoloading, diverted code should reference
;;; the OLD variables for some indeterminate time.

(define-public-variable format:colon-flag
    (divdoc idefs))

(define-public-variable format:atsign-flag
    (divdoc idefs))

{(only-for Maclisp)
 (define-private-variable colon-flag)
 (define-private-variable atsign-flag)
 }

{(document-variables format:colon-flag format:atsign-flag)
These tell whether or not we have seen a colon or atsign respectively
while parsing the parameters to a 3format* operator.  They are
only bound in the toplevel call to 3format*, so are only really
valid when the 3format* operator is first called;  if the operator
does more parameter parsing (like 3~[* does) their values should be
saved if they will be needed.

These variables used to be named just 3colon-flag* and
3atsign-flag*.  In the interest of transporting 3format* code
to Lisp implementations with packages, their names have been changed.
Thus, in either implementation one references them with the
'cindex packages
"3format:*" at the front of the name, which in Maclisp is just
part of the print-name.
}


;;;; parameter hacking

{(divert-documentation-to idefs)
	The 2params* are passed in as a list.  This list, however,
is temporary storage only.  If it is going to be passed back, it
2must be copied*.  In Maclisp and NIL, it is an ordinary list
which, in PDP-10 Maclisp, will be 3reclaim*ed after the operator
has run. On the Lisp Machine, it will be a list-pointer into an
3art-q-list* array, possibly in a temporary area.  Thus, although
it is safe to save values in this list with 3rplaca*, one should
not ever use 3rplacd* on it, either explicitly or implicitly (by
use of 3nconc* or 3nreverse*).
}

{-- to hack the params in a reasonable manner, we define a "list
buffer" which is something we can (1) queue elements on (2) retreive a
list from and (3) maybe reclaim the storage of.
}


(define-private-xmacro (format-make-list-buffer)
    {(only-for Lispm) '(make-array nil 'art-q-list 1 '(0))}
    {(except-for Lispm) '()})


{-- all of the following frobs assume that buffer will be a variable,
hence can be repeatedly eval'ed, setqed, etc.
}


(define-private-xmacro (format-push-list-buffer frob buffer)
    {(only-for lispm) `(array-push-extend ,buffer ,frob)}
    {(except-for lispm) `(push ,frob ,buffer)})


(define-private-xmacro (format-get-list-buffer-pointer buffer)
    {(only-for lispm) `(g-l-p ,buffer)}
    {(except-for lispm) `(setq ,buffer (nreverse ,buffer))})


(define-private-xmacro (format-reclaim-list-buffer buffer)
    {(only-for Lispm)
       `(return-array (prog1 ,buffer (setq ,buffer nil)))}
    {(except-for Lispm)
       {(only-for PDP-10) `(reclaim ,buffer (setq ,buffer nil))}
       {(except-for PDP-10) buffer}})


;;;; Invocation...

{(divert-documentation-to idefs)
	Conceptually, 3format* operates by performing output to
some stream.  In practice, this is what occurs in most
implementations;  in Maclisp, there are a few special SFAs used by
3format*.  This may not be possible in all implementations,
however.  To get around this, 3format* has a mechanism for
allowing the output to go to a pseudo-stream, and supplies a set of
functions which will interact with these when they are used.
}


{(except-for Lispm)
(define-private-variable *format-sfap)
}

{(except-for Maclisp)
(define-system-xmacro (format-code-for-sfas sfa-code (body non-sfa-code))
  {(only-for NIL)
     `(cond (*format-sfap ,sfa-code)
	    (#t ,@non-sfa-code))
     }
  {(except-for NIL)
     `(progn ,@non-sfa-code)
     }
  )
}


;;;; Multics stream op hacks

{(only-for Multics)

(define-system-routine (format-icall0 op)
    (let ((p (plist (cadr standard-output))))
       (cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) standard-output op))
	     (t (funcall (cadr standard-output) standard-output op)))))

(define-system-routine (format-icall1 op arg1)
    (let ((p (plist (cadr standard-output))))
       (cond ((eq (car p) 'lsubr)
	        (lsubrcall nil (cadr p) standard-output op arg1))
	     (t (funcall (cadr standard-output) standard-output op arg1)))))

(define-system-routine (format-icall2 op arg1 arg2)
  (let ((p (plist (cadr standard-output))))
    (cond ((eq (car p) 'lsubr)
	     (lsubrcall nil (cadr p) standard-output op arg1 arg2))
	  (t (funcall (cadr standard-output) op arg1 arg2)))))

(define-system-routine (format-call0 s op)
    (let ((p (plist (cadr s))))
       (cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) s op))
	     (t (funcall (cadr s) s op)))))

(define-system-routine (format-call1 s op arg1)
    (let ((p (plist (cadr s))))
       (cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) s op arg1))
	     (t (funcall (cadr s) s op arg1)))))


(define-public-routine (format-stream-default crock op arg1 rest)
    (auxs t1 t2)
    (selectq op
      ((princ prin1)
         (setq t1 (typep arg1))
	 (cond ((cond ((eq op 'princ) (memq t1 '(string symbol)))
		      ((eq t1 'symbol)
		         (= (setq t2 (stringlength arg1)) (flatsize arg1))))
		  (loop for i from 1 to (or t2 (stringlength arg1))
			do (format-call1 crock 'tyo (getcharn arg1 i))))
	       (t (loop for x in (if (eq op 'princ) (exploden arg1)
				     (map '(lambda (x)
					       (rplaca x (CtoI (car x))))
					  (explode arg1)))
			do (format-call1 crock 'tyo x)))))
      (terpri (format-call1 crock 'tyo #\cr))
      (fresh-line
         (or (zerop (format-call0 crock 'charpos))
	     (format-call0 crock 'terpri)))
      (formfeed (format-call1 crock 'tyo #\ff))
      (tab-to
         (setq t1 arg1 t2 (or (car rest) 1))
	 (let* ((here (format-call0 crock 'charpos))
		(there (+ t1 (* (// (+ (- (if (> t1 here) t1 here) t1)
				       (1- t2))
				    t2)
				t2))))
	     (declare (fixnum here there))
	     (loop repeat (- there here)
		   do (format-call1 crock 'tyo #\sp))))
      (t (error "Not supported -- " (list* crock op arg1 rest)))))
}


;;;; Output partial definitions

(define-public-routine (format-tyo character)
    (dcls (divdoc idefs))
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((not (null *format-sfap)) (format-icall1 'tyo character))
		((null standard-output) (tyo character))
		(t (tyo character standard-output)))}
       {(except-for Multics)
	  {(only-for NIL)
	     (setq character (code-char character))
	     (if *format-sfap
		 (ixsfa-call standard-output ':ouch (code-char character))
		 (send standard-output ':ouch (code-char character)))
	     }
	  {(except-for NIL)
	     (dcls (open-code) (use-sublis-for-open-coding))
	     {(only-for Lispm)
	        (funcall standard-output ':tyo character)
		}
	     {(except-for Lispm)
	        (tyo character)}
	     }
	  }
       }
    {(only-for PDP-10)
	(dcls (assembly-language-definition))
	(skipe 0 (special *format-sfap))
	  (jrst 0 format-tyo-to-sfa)
	(push p a)
	(push p (special standard-output))
	(movni t 2)
	(jcall 16 'tyo)

    format-tyo-to-sfa
	(movei c 0 a)
	(movei b 'tyo)
	(move a (special standard-output))
	(movei tt sfcali)
	(xct 0 @ 1 a)
	(popj p)
	}
    )

{(document-routine)
3tyo*s 2character* to the 3format* output destination.
}



(define-public-routine (format-princ object)
    (dcls (divdoc idefs))
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((not (null *format-sfap)) (format-icall1 'princ object))
		((null standard-output) (princ object))
		(t (princ object standard-output)))}
       {(except-for Multics)
	  (dcls (open-code) (use-sublis-for-open-coding))
	  (princ object) ; standard-output is the default?
	  }
       }
    {(only-for PDP-10)
       (dcls (assembly-language-definition))
	(push p a)
	(push p (special standard-output))
	(movni t 2)
	(jcall 14. 'princ)
	}
    )


{(document-routine)
3princ*s 2object* to the 3format* output destination.
}


{(only-for PDP-10)

(declare-variable squid)

(define-public-optimizer (format-princ x)
    (and (cond ((atom x)
		  (or (and (fboundp 'stringp) (stringp x))
		      (and (symbolp x) (get x '+internal-string-marker))
		      (floatp x)))
	       ((eq (car x) 'quote)
		  (setq x (cadr x))
		  (or (and (fboundp 'stringp) (stringp x))
		      (symbolp x)
		      (floatp x)))
	       ((eq (car x) squid)
		   (and (not (atom (setq x (cadr x))))
			(eq (car x) 'quote)
			(symbolp (cadr x))
			(setq x (cadr x)))))
	 `(princ ',x standard-output)))
}



(define-public-routine (format-prin1 object)
    (dcls (divdoc idefs))
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((not (null *format-sfap)) (format-icall1 'prin1 object))
		((null standard-output) (prin1 object))
		(t (prin1 object standard-output)))}
       {(except-for Multics)
	  (dcls (open-code) (use-sublis-for-open-coding))
	  (prin1 object)}
       }
    {(only-for PDP-10)
       (dcls (assembly-language-definition))
       (push p a)
       (push p (special standard-output))
       (movni t 2)
       (jcall 14. 'prin1)
       }
    )

{(document-routine)
3prin1*s 2frob* to the 3format* output destination.
}



(define-public-routine (format-lcprinc string capitalize?)
  (dcls (divdoc idefs))
  {(only-for Maclisp)
     (loop {(only-for Multics)
	      for i from 1 to (stringlength string)
	      as ch fixnum = (getcharn string i)
	      }
	   {(except-for Multics)
	      ; Use exploden because it's the easiest way to support
	      ; any kind of "string" or symbol.
	      with l = (exploden string)
	      for ch fixnum in l
	      }
	   when (lessp #.(1- #/A) (boole 1 ch #o137) #.(1+ #/Z))
	     do (setq ch (if capitalize? (boole 4 ch #o40)
			     (boole 7 ch #o40)))
	   do (format-tyo ch) (setq capitalize? ())
	   {(only-for PDP-10)
	      finally (reclaim l (setq l nil))
	      }
	   )
     }
  {(except-for Maclisp)
     {(except-for Lispm)
        ;Misplaced modularity.
	(loop for c being the characters of (to-string string)
	      do (ouch (if capitalize? (char-upcase c) (char-downcase c)))
		 (setq capitalize? ()))}
     {(only-for Lispm)
        (loop for c being the array-elements of (string string)
	      do (format-tyo
		    (if capitalize? (char-upcase c) (char-downcase c)))
		 (setq capitalize? ()))}
     }
  )


{(document-routine)
This outputs 2string*, which must be a string or symbol, to the
3format* output destination in lower-case.  If 2capitalize?*
is not 3nil*, then the first character is converted to upper case
rather than lower.
}


(define-public-routine (format-terpri)
    (dcls (divdoc idefs))
    {(only-for PDP-10)
       (dcls (assembly-language-definition))
       (push p (special standard-output))
       (movni t 1)
       (jcall 14. 'terpri)
       }
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((not (null *format-sfap)) (format-icall0 'terpri))
		((null standard-output) (terpri))
		(t (terpri standard-output)))
	  }
       {(except-for Multics)
	  {(only-for NIL)
	     (if (memq ':terpri *format-sfap)
		 (ixsfa-call *format-sfap ':terpri ())
		 (if (not *format-sfap)
		     (send standard-output ':terpri)
		     (terpri)))
	     }
	  {(except-for NIL)
	     (dcls (open-code) (use-sublis-for-open-coding))
	     (terpri)
	     }
	  }
       }
    )

{(document-routine)
Does a 3terpri* to the 3format* output destination.
}


(define-public-routine (format-charpos)
  (dcls (value-type fixnum) (divdoc idefs))
  {(only-for PDP-10) (dcls (implement-as expr))}
  {(except-for PDP-10)
     {(only-for Multics)
	(if (not (null *format-sfap)) (format-icall0 'charpos)
	    (charpos (or standard-output (null ^w) (null ^r)
			 (null outfiles) (car outfiles))))}
     {(except-for Multics)
	{(only-for NIL)
	   (if *format-sfap
	       (ixsfa-call standard-output ':charpos ())
	       (send standard-output ':charpos))
	   }
	{(except-for NIL)
	   (bindq wops (format-stream-call standard-output ':which-operations)
		  tem (or (memq ':read-cursorpos wops) (memq ':charpos wops)))
	   (if tem (format-stream-call standard-output (car tem))
	       (ferror ()
		  "The stream ~S does not support a :CHARPOS-like operation"
		  standard-output))}}})


(define-public-routine (format-linel)
  (dcls (value-type fixnum) (divdoc idefs))
  {(only-for PDP-10) (dcls (implement-as expr))}
  {(except-for PDP-10)
     {(only-for Multics)
	(if (not (null *format-sfap)) (format-icall0 'linel)
	    (linel (or standard-output (null ^w) (null ^r)
		       (null outfiles) (car outfiles))))}
     {(except-for Multics)
        {(only-for NIL)
	   (if *format-sfap
	       (ixsfa-call standard-output ':linel)
	       (send standard-output ':linel))
	   }
	{(except-for NIL)
	   (bindq wops (format-stream-call standard-output ':which-operations)
		  tem (or (memq ':inside-width wops) (memq ':linel wops)))
	   (if tem (format-stream-call standard-output (car tem))
	       (ferror ()
		  "The stream ~S does not support a :LINEL-like operation"
		  standard-output))}}})

{(document-routines format-charpos format-linel)
Return the 3charpos* and 3linel* of the 3format*
output destination.  Since in the Maclisp implementation multiple
output destinations may be implicitly in use (via 3outfiles*, for
instance) this attempts to choose a representative one.  The terminal
is preferred if it is involved.
}



{(only-for PDP10)

(lap-a-list
  '((lap format-charpos subr)
    (args format-charpos (nil . 0))
	(push p (% 0 0 fix1))
	(pushj fxp foo)
	(njcall 14. 'charpos)
    (entry format-linel subr)
    (args format-linel (nil . 0))
	(push p (% 0 0 fix1))
	(pushj fxp foo)
	(njcall 14. 'linel)

    foo	(skipn a (special standard-output))
	  (jrst 0 choose-default)
	(movei t 0 a)
	(lsh t -9.)
	(skipge 0 st t)
	  (hlrz a 0 a)
    bar (push p a)
	(movni t 1)
	(popj fxp)

    choose-default
	(skipn 0 (special ^w))
	  (skipe 0 (special ^r))
	    (jrst 0 baz)
    default-is-tty
	(move a (special tyo))
	(jrst 0 bar)

    baz (skipn a (special outfiles))
	  (jrst 0 default-is-tty)
	(hlrz a 0 a)
	(jrst 0 bar)

    nil))
}

;;;; Maclisp "mapping" over streams

{(only-for Maclisp)

(define-private-routine (format-stream-map fn stream)
    (bindq singlet nil list nil)
    (cond ((null stream)
	     (or ^w (setq singlet {PDP-10 tyo} {Multics t}))
	     (and ^r (setq list outfiles)))
	{(only-for PDP-10)
	  ((atom stream)
	     (if (eq stream 't)
		 (and (not ^w) (setq singlet tyo))
		 (setq singlet stream)))
	  (t (setq list stream))}
	{(only-for Multics)
	  (t (setq singlet stream))}
	  )
    (and singlet (funcall fn singlet))
    (loop for x in list
	  when (or (not ^w) (not (eq x t)))
	    do (funcall fn {PDP-10 (cond ((eq x t) tyo) (t x))} {Multics x})))
}


;;;; Fresh-line

(define-public-routine (format-fresh-line)
  (dcls (divdoc idefs))
  {(except-for Maclisp)
     {(only-for NIL)
        (if *format-sfap
	    (ixsfa-call standard-output ':fresh-line ())
	    (send standard-output ':fresh-line))
	}
     {(except-for NIL)
	(bindq wops (format-stream-call standard-output ':which-operations)
	       tem ())
	(cond ((memq ':fresh-line wops)
		 (format-stream-call standard-output ':fresh-line))
	      ((and (setq tem (or (memq ':read-cursorpos wops)
				  (memq ':charpos wops)))
		    (zerop (format-stream-call standard-output (car tem)))))
	      ('t (format-stream-call standard-output ':terpri)))
	}
     }
  {(only-for Maclisp)
     {(only-for Multics)
	(if *format-sfap (format-icall0 'fresh-line)
	    (format-stream-map #'format-fresh-line-1 standard-output))
	}
     {(except-for Multics)
	(format-stream-map #'format-fresh-line-1 standard-output)
	}
     }
  )


{(only-for Maclisp)

(define-private-routine (format-fresh-line-1 stream)

   {(only-for PDP-10)
      (bindq ops (format-stream-ops stream))
      (cond ((memq 'fresh-line ops) (sfa-call stream 'fresh-line nil))
	    ((and (memq 'cursorpos ops) (cursorpos 'a stream)))
	    ((or (not (memq 'charpos ops)) (plusp (charpos stream)))
	       (terpri stream)))
      }
   {(except-for PDP-10)
     (or (zerop (charpos stream)) (terpri stream))
     }
   t
   )
}


{(document-routine format-fresh-line)
This performs the 3fresh-line* operation to the default
3format* destination.  In PDP-10 Maclisp, this first will try the
3fresh-line* operation if the destination is an SFA and supports
it.  Otherwise, if the destination is a terminal or an SFA which
supports 3cursorpos*, it will try 3(cursorpos 'a)*.  Otherwise,
it will do a 3terpri* if the 3charpos* is not 30*.  In the
Maclisp implementation, where multiple output destinations may be
implicitly involved (via 3outfiles*, for instance), this handles
each such destination separately.
}


;;;; tab-to

(define-private-xmacro (format-next-tabpos pos tabsize)
  (cond ((null tabsize)
	   (setq tabsize {Multics 10.} {(except-for Multics) 8.})))
  (cond ((fixp tabsize)
	   (if (= tabsize 8.)
	       `(boole 4 (+ ,pos 8) 7)
	       `(* (// (+ ,pos ,(1- tabsize)) ,tabsize) ,tabsize)))
	((and (atom pos) (atom tabsize))
	   `(* (// (+ ,pos (1- ,tabsize)) ,tabsize) ,tabsize))
	(t `((lambda (pos tabsize) (format-next-tabpos pos tabsize))
	     ,pos ,tabsize))))


(define-public-routine (format-tab-to
			  (fixnum destination) (optional increment?)
			  {(except-for Maclisp) (optional units ':character)})

  (dcls (divdoc idefs))
  {(except-for Maclisp)
     (dcls (returnable))
     (format-code-for-sfas
        (let ((ops (ixsfa-call standard-output ':which-operations ())))
	  (cond ((memq ':tab-to ops)
		   (funcall #'(lambda (&rest kludgery)
				(ixsfa-call standard-output ':tab-to kludgery))
			    destination increment units)
		   (return #t))
		((memq ':charpos ops)
		   (setq pos (ixsfa-call standard-output ':charpos ())))
		(#t (setq pos (- destination 2) units ':character))))
	(cond ((format-stream-call standard-output
				   ':operation-handled-p ':tab-to)
	         (format-stream-call standard-output ':tab-to
				     destination increment units)
		 (return #t))
	      ((format-stream-call standard-output ':operation-handled-p
				   ':read-cursorpos)
	         (multiple-value (() pos)
		   (format-stream-call standard-output ':read-cursorpos)))
	      ((and (eq units ':character)
		    (format-stream-call standard-output
		      ':operation-handled-p ':charpos))
	         (setq pos (format-stream-call standard-output ':charpos)))
	      (#t (setq pos (- destination 2) units ':character))))
     (setq destination
	   (+ destination
	      (* (// (+ (- (if (< destination pos) destination pos)
			   destination)
			(1- increment))
		     increment)
		 increment)))
     (format-code-for-sfas
        (cond ((memq ':set-hpos *format-sfap)
	         (ixsfa-call standard-output ':set-hpos destination))
	      ((memq ':set-cursorpos *format-sfap)
	         (funcall #'(lambda (&rest ohfoo)
			      (ixsfa-call standard-output ':set-cursorpos
					  ohfoo))
			  () destination))
	      ((eq units ':character)
	         (loop repeat (- destination pos) do (format-tyo #\sp)))
	      (t (break barf)))
	(cond ((format-stream-call standard-output ':operation-handled-p
				   ':set-cursorpos)
	         (format-stream-call standard-output
		   ':set-cursorpos () destination))
	      ((eq units ':character)
	         (loop repeat (- destination pos) do (format-typ #\sp)))
	      (t (break barf))))
     }

  {(only-for Maclisp)
     (dcls (implement-as lexpr n n))
     {(only-for Multics)
        (if *format-sfap
	    (format-icall2 'tab-to (arg 1) (or (and (> n 2) (arg 2)) 1))
	    (format-stream-map #'format-tab-to-1 standard-output))
	}
     {(except-for Multics)
        (format-stream-map #'format-tab-to-1 standard-output)
	}
     }
  't)


{(only-for Maclisp)

(define-private-routine (format-tab-to-1 s)
    (bindq (fixnum here) 0 (fixnum there) 0 (fixnum dest) (arg 1)
	   (fixnum inc) (or (and (> (arg nil) 1) (arg 2)) 1))
    (cond 
       {(only-for PDP-10)
	  ((let ((ops (format-stream-ops s)))
	     (cond ((memq 'tab-to ops) (sfa-call s 'tab-to (cons dest inc)) t)
		   ((not (memq 'charpos ops)) (princ '|  | s) t))))
	  }
	  (t (setq here (charpos s))
	     (setq there (+ dest (* (// (+ (- (if (> dest here) dest here)
					      dest)
					   (1- inc))
					inc)
				    inc)))
	     {-- Do we want to use tabs?
		 (loop as next fixnum = (format-next-tabpos here)
		       until (> next there)
		       do (tyo #\tab s) (setq here next))
		 }
	     (loop until (= here there)
		   do (tyo #\sp s) (setq here (1+ here)))))
    t)
}


{(document-routine format-tab-to)
This implements 3~T* to the current 3format* destination (q.v.).
In PDP-10 Maclisp, this operation on an SFA will use the 3tab-to*
operation if it supported, passing in arguments of 2destination*
and 2increment* (as a dotted pair); otherwise, 3charpos* will
be used to compute the number of spaces to be output.  If
3charpos* is not supported, two spaces will be output.
}


;;;; formfeed

(define-public-routine (format-formfeed)

    (dcls (divdoc idefs))
    {(except-for Maclisp)
       (format-code-for-sfas
	 (let ((tem (or (memq ':formfeed *format-sfap)
			(memq ':clear-screen *format-sfap))))
	   (cond (tem (ixsfa-call standard-output (car tem) ()))
		 ((and (memq ':cursorpos *format-sfap)
		       (ixsfa-call standard-output ':cursorpos '(c))))
		 ('t (format-tyo #\ff))))
	 (cond ((format-stream-call standard-output
		  ':operation-handled-p ':formfeed)
		  (format-stream-call standard-output ':formfeed))
	       ((format-stream-call standard-output
		  ':operation-handled-p ':clear-screen)
		  (format-stream-call standard-output ':clear-screen))
	       (#t (format-tyo #\ff))))}

    {(only-for Maclisp)
       {(only-for Multics)
	  (if *format-sfap (format-icall0 'formfeed)
	      (format-stream-map #'format-formfeed-1 standard-output))
	  }
       {(except-for Multics)
	  (format-stream-map #'format-formfeed-1 standard-output)
	  }
       }
    't)


{(only-for Maclisp)

(define-private-routine (format-formfeed-1 s)

    {(only-for PDP10)
       (bindq ops (format-stream-ops s))
       (cond ((memq 'formfeed ops) (sfa-call s 'formfeed format:colon-flag))
	     ((and (memq 'cursorpos ops) (cursorpos 'c s)))
	     (t (tyo #\ff s)))}
    {(except-for PDP-10) (tyo #\ff s)}
    t)
}


{(document-routine format-formfeed)
Performs a 3formfeed* on the 3format* output destination.  In
Multics Maclisp, this will normally just 3tyo* the character code
for a formfeed.  In PDP-10 Maclisp, this will use the 3formfeed*
operation if the destination is an SFA and supports it, otherwise it
will do a 3(cursorpos 'c)* if the destination is a TTY file array
(or an SFA) and supports it, otherwise it simply outputs the character
code for a formfeed.
}


;;;; Character fetching hair.

; The "source" string:
(define-private-variable *format-string)

; the (0-origined) index into it:
(define-private-variable *format-string-index (data-type fixnum))
; the index will always be passed in and incremented explicitly.

; the size of the "string":
(define-private-variable *format-string-length (data-type fixnum))


; Here we have the problem that we may have strings, but we may not,
; and we must always handle symbols in their place.  Hence, we have
; a special-variable which tells whether or not the "string" is a real
; string.

; We assume that the routine CHAR-N is the "canonical" way to get a
; character out of a "string" (as a fixnum character code).  Lispm
; strings are special cased to use AR-1 (since they are 1-d arrays),
; and in PDP-10 Maclisp lap-code similar to GETCHARN (but without the error
; checking) is used.


{(only-for PDP-10)
 ; If we are hacking a "string", this is it (rather than just being T).
 (define-private-variable *format-stringp)
 }

(define-private-routine (format-get-char (fixnum index))
  (dcls (value-type character-code))
  {(except-for PDP-10)
     (dcls (open-code) (use-sublis-for-open-coding))
     {(only-for lispm)
	(ar-1 *format-string index)
	}
     {(except-for Lispm)
	{(only-for Multics)
	   (getcharn *format-string (1+ index))
	   }
	{(except-for Multics)
	   (char-n *format-string index)
	   }
	}
     }
  {(only-for PDP-10)
	(dcls (assembly-language-definition))
	(push p (% 0 0 fix1))
	(skipe b (special *format-stringp))
	  (jrst 0 get-char-from-string)
	(move tt 0 a)
	(hlrz a @ (special *format-string))
	(skipn 0 a)
	  (skipa a (% 0 0 '#.(pnget nil 7.)))
	(hrrz a 1 a)
	(idivi tt 5)
	(jumpe tt foo)
    lp	(hrrz a 0 a)
	(sojg tt lp)
    foo	(hlrz a 0 a)
	(ldb tt byte-table d)
	(popj p)

    byte-table
	(350700_22 0 0 a)
	(260700_22 0 0 a)
	(170700_22 0 0 a)
	(100700_22 0 0 a)
	(010700_22 0 0 a)

    get-char-from-string
	(exch a b)
	; Perhaps use +INTERNAL-CHAR-N ???
	(njcall 2 'char-n)
	}
  )

;;;; arguments


(define-system-variable *format-args)

{(document-variable)
This is the current value of the 3format* 2arguments*.
Whenever another is needed, it is 3pop*ped off of this.
}


(define-system-variable *format-original-args)

{(document-variable)
This is the original value of 3*format-args*.  It is used whenever
we need to "back up", as with 3~G*.
}

{-- 
    Some stuff just ain't worth documenting or supplying as
"system" routines/macros, because then it would need to exist at
runtime.  Since the format is defined, and the chance of them being
needed is minimal, the following crap stays private.
}


(define-private-routine (format-pop-one-arg)

  {-- In the pdp-10 implementation we will lap code this so that
      we can fit in a trivial error uuo (it used to not check at all).}

  {(except-for PDP-10)
     (if (null *format-args)
	 (format-err1 "ran out of args" *format-original-args)
	 (prog1 (car *format-args) (setq *format-args (cdr *format-args))))
     }
  {(only-for PDP-10)
    (dcls (assembly-language-definition))
	(skipn b (special *format-args))
	  (jrst 0 lose-lose)
	(hlrz a 0 b)
	(hrrz b 0 b)
	(movem b (special *format-args))
	(popj p)

    lose-lose
	(move a (special *format-original-args))
	(move b (special *format-string))
	(jsp t %xcons)
	(move b (special standard-output))
	(jsp t %xcons)
	(movei b 'format)
	(jsp t %xcons)
	(erint 6 (% sixbit |FORMAT RAN OUT OF ARGS!|)) ; fail-act error
	(popj p)
	}
    )


;;;; Errors

(define-system-routine (format-err short-message)
    {(only-for Maclisp)
       (let ((msg (format nil
		     {(only-for Multics)
		        "lisp:  ~A at decimal pos ~D in format string "
			}
		     {(except-for Multics)
		        "- ~A at decimal pos ~D in format string"
			}
		     short-message *format-string-index)))
	 (error msg *format-string 'fail-act)
	 (error msg *format-string))}
    {(except-for Maclisp)
       {(only-for Lispm) (dcls (open-code) (use-sublis-for-open-coding))}
       (ferror () "~A at pos ~D in format string ~S"
	       short-message *format-string-index *format-string)})


(define-system-routine (format-err1 short-message datum)
  {(only-for Maclisp)
     (let ((msg (format nil
		 {(only-for Multics)
		    "lisp:  ~A~:[~; (decimal pos ~D in format string ~S)~] - "
		    }
		 {(except-for Multics)
		    "- ~A~:[~; (decimal pos ~D in format string ~S)~]"
		    }
		 short-message *format-string
		 *format-string-index *format-string)))
       (error msg datum 'fail-act)
       (error msg datum))}
  {(except-for Maclisp)
    {Lispm (dcls (open-code) (use-sublis-for-open-coding))}
    (ferror ()
     "~1g~S - ~0g~A~2g ~:[in format~;(decimal pos ~D in format string ~S)~]"
     short-message datum *format-string
     *format-string-index *format-string)})


(define-system-routine (format-call-op op params)
  (auxs (suggestion (format-op? op)) (z (cadr suggestion)))
  {-- Consider, for PDP-10, changing the FUNCALL to LEXPR-FUNCALL
      with last arg of NIL, which is significantly faster, especially
      in (*RSET T) mode which is pretty common.}
  (selectq (car suggestion)
     (format-ctl-one-arg
	{(only-for Format-Subr-Properties)
	   (if (eq (typep z) 'random)
	       (subrcall nil z (format-pop-one-arg) params)
	       (funcall z (format-pop-one-arg) params))
	   }
	{(except-for Format-Subr-Properties)
	   (funcall z (format-pop-one-arg) params)
	   })
     (format-ctl-no-arg
	{(only-for Format-Subr-Properties)
	   (if (eq (typep z) 'random)
	       (subrcall nil z params)
	       (funcall z params))
	       }
	{(except-for Format-Subr-Properties)
	   (funcall z params)
	   }
	)
     (format-ctl-multi-arg
	(setq *format-args
	      {(only-for Format-Subr-Properties)
		 (if (eq (typep z) 'random)
		     (subrcall nil z *format-args params)
		     (funcall z *format-args params))}
	      {(except-for Format-Subr-Properties)
		 (funcall z *format-args params)}))
     (format-ctl-repeat-char
	(format-repeat-char (format-character z) (or (car params) 1)))
     (t (format-err1 "not defined as format op" op))))

{(document-routine)
This is the primitive routine for calling a 3format* operator.
2op* is the operator (a symbol), 2params* is the parameters
(as returned by 3format-collect-params*,
(format-collect-params-fun), q.v.),
and 2suggestion?* tells us if we already know if 2op* is
defined as a 3format* operator.  If it is non-3nil*, it should
be the result of a 3getl* on 2op* of the appropriate list of
properties.  This saves us from doing the 3getl* twice where it
has been done to see if 2op* is really a 3format* operator.
this routine performs the appropriate manipulations of the
3format* 2arguments*.
}


{-- For PDP-10, consider consolidating the following 2 routines into a
    single lap-coded one...}

(define-system-routine (format-process-text)
    {(only-for Lispm)
       ; Here we can use STRING-SEARCH-CHAR to find the "next" operator.
       (bindq i (%string-search-char *format-string #/~ *format-string-index))
       (format-stream-call standard-output ':string-out
	 *format-string-index
	 (setq *format-string-index (or i *format-string-length)))
       (not (null i))}
    {(only-for NIL)
       ;This is an important optimization.
       (bindq (fixnum cnt) (- *format-string-length *format-string-index))
       (bindq i (%string-posq ~/~ *format-string *format-string-index cnt))
       (oustr *format-string standard-output
	      *format-string-index (if i (- i *format-string-index) cnt))
       (cond ((not (null i)) (setq *format-string-index i) #t)
	     (#t (setq *format-string-index *format-string-length) ()))}
    {(only-for Multics)
       ;Hopefully, this is a significant optimization.
       (if *format-sfap
	   (loop with fn = (cadr standard-output) and subrp = () and tem = ()
		 initially (when (eq (car (setq tem (plist fn))) 'lsubr)
			     (setq subrp (setq fn (cadr tem))))
		 for i from (1+ *format-string-index)
		 until (> i *format-string-length)
		 as char fixnum = (getcharn *format-string i)
		 when (format-tildep char)
		   do (setq *format-string-index i) (return 't)
		 do (if subrp (lsubrcall nil fn standard-output 'tyo char)
			(funcall fn standard-output 'tyo char))
		 finally (setq *format-string-index *format-string-length))
	   (let* ((old (1+ *format-string-index))
		  (new (loop for i from old
			     until (> i *format-string-length)
			     as char fixnum = (getcharn *format-string i)
			     when (= char #/~)
			       return (setq *format-string-index i)))
		  (res (if new new
			 (setq *format-string-index *format-string-length
			       new (1+ *format-string-length))
			 ())))
	     (caseq (- new old)
	       (0 ())
	       (1 (let ((c (getcharn *format-string old)))
		    (if standard-output (tyo c standard-output) (tyo c))))
	       (t (let ((s (substr *format-string old (- new old))))
		    (if standard-output (princ s standard-output) (princ s)))))
	     (setq *format-string-index new)
	     res))}
    {(except-for (or Lispm NIL Multics))
       ; Here we must check char-at-a-time.
       (loop for i from *format-string-index
	     while (< i *format-string-length)
	     as char fixnum = (format-get-char i)
	     when (format-tildep char)
	       do (setq *format-string-index (1+ i))
		  (return 't)
	     do (format-tyo char)
	     finally (setq *format-string-index i))})

{(document-routine)
This processes 2control-string* from wherever its "pointer" was up
to the next operator, or the end of the string.  in the former case it
returns 3t* and leaves the "pointer" pointing at the character
after the tilde, otherwise it returns 3nil*.  the characters are
"processed" by being copied to 3standard-output*.
}

(define-system-routine (format-skip-text)
    {(only-for Lispm)
       ; here we can use string-search-char to find the "next" operator.
       (bindq i (%string-search-char *format-string #/~ *format-string-index))
       (setq *format-string-index (or i *format-string-length))
       (not (null i))}
    {(only-for NIL)
       (bindq i (%string-posq ~/~ *format-string *format-string-index
			      (- *format-string-length *format-string-index)))
       (if i (setq *format-string-index i)
	 (setq *format-string-index *format-string-length)
	 ())}
    {(except-for (or Lispm NIL))
       ; Here we must check char-at-a-time.
       (loop for i from *format-string-index
	     while (< i *format-string-length)
	     when (format-tildep (format-get-char i))
	       do (setq *format-string-index (1+ i))
	       and return 't
	     finally (setq *format-string-index i))})

{(document-routine)
This is just like 3format-process-text*, except the characters are
not copied to 3standard-output*.  It is used, for example, by
3~[* to skip alternative strings.
}



(define-system-routine (format-collect-params)

    (setq format:colon-flag () format:atsign-flag ()
	  {Maclisp colon-flag () atsign-flag ()})

    (loop with params = (format-make-list-buffer)
	    and i fixnum = *format-string-index
	    and (n argp v?) (fixnum)
	  for ch fixnum = (format-get-char i)
	do (cond ((lessp #.(1- #/0) ch #.(1+ #/9))
		    (setq argp t v? () n (+ (* n 10.) (- ch #/0))))
		 ((= ch #/:)
		    (setq format:colon-flag 't)
		    {Maclisp (setq colon-flag 't)})
		 ((= ch #/@)
		    (setq format:atsign-flag 't)
		    {Maclisp (setq atsign-flag 't)})
		 ((= ch #/,)
		    (or v? (format-push-list-buffer (and argp n) params))
		    (setq argp () v? () n 0))
		 ((= ch #/')
		    (cond ((not (null argp))
			     (format-push-list-buffer n params)
			     (setq argp () n 0)))
		    (format-push-list-buffer
		       (format-get-char (setq i (1+ i)))
		       params)
		    (setq v? 't))
		 ('t (cond ((not (null argp))
			      (format-push-list-buffer n params)
			      (setq argp () n 0)))
		     (cond ((or (= ch #/V) (= ch #/v))
			      (format-push-list-buffer
				 (format-pop-one-arg) params)
			      (setq v? 't))
			   ((= ch #/#)
			      (format-push-list-buffer
				 (length *format-args) params)
			      (setq v? 't))
			   ('t (setq *format-string-index i)
			       (return params)))))
	when (not (< (setq i (1+ i)) *format-string-length))
	  do (format-err "Malformed operator")))


{(document-routine)
This should be called to fetch the 2params* for the next operator.
The "pointer" in the 2control-string* should be pointing at the
first character after the tilde, as it is after either
3format-process-text* or 3format-skip-text* have been called
(and have returned 3t*).  The params are returned in the
implementation dependent form described above.  In addition,
3format:colon-flag* and 3format:atsign-flag* will be set if
either of those modifiers were seen.  Note that the use of the
"parameter" 3v* will cause the format 2arguments* to get
popped;  if you are "skipping" part of the 2control-string*, you
probably want 3format-skip-params*, below.
}


(define-system-routine (format-skip-params)

    (setq format:colon-flag () format:atsign-flag ()
	  {Maclisp colon-flag () atsign-flag ()})

    (loop with paramsp and i fixnum = *format-string-index
	  for ch fixnum = (format-get-char i)
	do (cond ((or (lessp #.(1- #/0) ch #.(1+ #/9))
		      (= ch #/,) (= ch #/v) (= ch #/V) (= ch #/#))
		    (setq paramsp 't))
		 ((= ch #/:)
		    (setq format:colon-flag 't)
		    {Maclisp (setq colon-flag 't)})
		 ((= ch #/@)
		    (setq format:atsign-flag 't)
		    {Maclisp (setq atsign-flag 't)})
		 ((= ch #/') (setq i (1+ i)) (setq paramsp 't))
		 ('t (setq *format-string-index i) (return paramsp)))
	when (not (< (setq i (1+ i)) *format-string-length))
	  do (format-err "Malformed operator")))


{(document-routine)
This is the no-op variation of 3format-collect-params*.  It does
not pop the 3format* 2arguments* if 3v* is seen and does
not collect the parameters, although it 2does* set
3format:colon-flag* and 3format:atsign-flag* if appropriate.
It returns 3t* if any parameters (other than the flags) were seen,
3nil* otherwise.
}


(define-private-routine (format-intern spec)
  ; In Maclisp, spec is a list of character codes.
  ; Elsewhere, a string (probably nsubstring).
  {(only-for Maclisp)
     (loop for l on spec
	   as c fixnum = (car l)
	   when (lessp #.(1- #/a) c #.(1+ #/z))
	     do (rplaca l (- c #.(- #/a #/A))))
     (let ((obarray *format-obarray))
       {(only-for Multics) (implode spec)}
       {(except-for Multics)
	  (prog1 (implode spec) (reclaim spec (setq spec nil)))})}
  {(except-for Maclisp)
     (let ((str (string-upcase spec)) (sym) (foundp))
       (multiple-value (sym foundp) (intern-soft str *format-package))
       (prog1 (if foundp sym (format-err1 "Not defined as format op" str))
	      {Lispm (return-array str)}))})

(define-system-routine (format-read-op)
    (bindq (character-code ch) (format-get-char *format-string-index))
    (setq *format-string-index (1+ *format-string-index))
    (if (= ch #/\)
	(format-intern
	   {(only-for Maclisp)
	      (loop with l = () for i from *format-string-index
		    when (= i *format-string-length)
		      do (format-err "Unbalanced backslashes")
		    until (= (setq ch (format-get-char i)) #/\)
		    do (push ch l)
		    finally (setq *format-string-index (1+ i))
			    (return (nreverse l)))}
	   {(except-for Maclisp)
	      (let ((i (string-search-char #/\ *format-string
					   *format-string-index)))
		 (if (null i) (format-err "Unbalanced backslashes")
		     (prog1 (nsubstring *format-string
					*format-string-index (1- i))
			    (setq *format-string-index (1+ i)))))})
	(format-char-table {(only-for Lispm) (ldb %%ch-char ch)}
			   {(except-for Lispm) ch})))


{(document-routine)
This "reads" the format operator we are processing.  It should only be
called after either 3format-collect-params* or
3format-skip-params* have been called.  It also advances the
"pointer" into 2control-string* appropriately.
}


{-- now we define the stuff to allow us to collect output as a "string".
for each implementation, we simply define a stream and some associated
variables and macros.
}

(define-private-xmacro (format-collect-string-internal (any-number-of forms))
  {(only-for Maclisp)
     `((lambda (*format-collecting-string standard-output
		  *format-string-charpos *format-sfap
		  *format-string-linel)
	   ,@forms
	   (nreverse *format-collecting-string))
       nil *format-string-stream 0 t
       ((lambda (n) (declare (fixnum n)) (cond ((> n 69.) n) (t 69.)))
	(linel nil)))}
  {(except-for Maclisp)
     (with-output-to-string (standard-output)
       (let ((*format-sfap ())) ,@forms))
     }
  )


;Within the DYNAMIC environment of a FORMAT-COLLECT-STRING, determine
; the "charpos" of the string being accumulated.
(define-private-xmacro (format-collected-string-charpos)
  {(only-for Maclisp) '*format-string-charpos}
  {(except-for Maclisp) (format-charpos)})


(define-private-xmacro (format-collected-string-length collected-string)
  {(only-for Maclisp) `(length ,collected-string)}
  {(except-for Maclisp) `(string-length ,collected-string)})


(define-private-xmacro (format-do-over-collected-string var+frob (body forms))
  {(only-for Maclisp)
     `(loop for ,(car var+frob) in ,(cadr var+frob) do (progn ,@forms))
     }
  {(except-for Maclisp)
     `(loop for ,(car var+frob)
	        being the {(only-for Lispm) array-elements}
			  {(except-for Lispm) characters}
	        of ,(cadr var+frob)
	    do {(only-for NIL)
		  (setq ,(car var+frob) (char-code ,(car var+frob)))
		  }
	       (progn ,@forms))
     }
  )


;And the special case:
(define-private-xmacro (format-string-out-collected-string collected-string)
  {(only-for Maclisp) `(mapc #'format-tyo ,collected-string)}
  {(except-for Maclisp)
     {(only-for NIL)
        (xoustr string)
	}
     {(except-for NIL)
        (format-stream-call standard-output ':string-out ,collected-string)
	}
     }
  )


(define-private-xmacro (format-externalize-collected-string collected-string)
  {(only-for Maclisp)
     `(funcall *format-string-generator ,collected-string)
     }
  {(except-for Maclisp)
     collected-string
     }
  )


(define-private-xmacro (format-reclaim-collected-string collected-string)
  {(only-for PDP10)
     `(reclaim ,collected-string nil)
     }
  {(except-for PDP10)
     `(progn ,collected-string ())
     }
  )


(define-private-xmacro (format-collect-string (any-number-of forms))
  (bindq v (gensym))
  `((lambda (,v)
      (format-reclaim-collected-string
         (prog1 ,v (setq ,v (format-externalize-collected-string ,v))))
      ,v)
    (format-collect-string-internal ,@forms)))


{(only-for Maclisp)

(define-private-variable *format-collecting-string)

(define-private-variable *format-string-charpos
	(data-type fixnum))

(define-private-variable *format-string-linel
	(data-type fixnum))

;In Maclisp, we have yet another special hook into string
; simulation packages:  we call this to "produce" a string from our
; output.


(define-private-routine (format-string-generator character-list)
  {(only-for Multics)
     (get_pname (maknam character-list))
     }
  {(except-for Multics)
     (let ((str (maknam character-list)))
       (setplist str '(+internal-string-marker t))
       (set str str))
     }
  )
}

(define-public-variable *format-string-generator
  {(except-for Maclisp) (dummy-definition)}
  (divert-documentation-to string)
  (default-init #'format-string-generator))

{(document-variable)
This variable, which exists only in the Maclisp implementation of
3format*, should have as its value a function to convert a list of
characters to a "string" to be returned by 3format*.  In the Multics
implementation, it is a function which does
.lisp
(get_pname (maknam 2character-list*))
.end_lisp
and may be modified, if desired, to something more efficient.  In the
PDP-10 implementation, it is a function which returns an atomic symbol
which evaluates to itself and which has a
3+internal-string-marker* property of 3t*.

The name of this variable differs from that of other user-accessible
3format* variables for historical reasons;  it will not be
changed, because it only exists in Maclisp.
}

;;;; the string-collecting streams

; in pdp-10 maclisp, an sfa:

{(only-for PDP-10)

(define-private-routine (fsfa/| s op arg)

    (caseq op
       (tyo
	  (cond ((< arg 0)
		   (or (> *format-string-linel (- *format-string-charpos arg))
		       (terpri s)))
		(t (push arg *format-collecting-string)
		   (setq *format-string-charpos
			 (caseq arg
			    ((#\cr #\ff) 0)
			    (#\lf *format-string-charpos)
			    (#\bs {-- (max (1- *format-string-charpos) 0)}
				  (cond ((plusp *format-string-charpos)
					   (1- *format-string-charpos))
					(t 0)))
			    (#\tab
			       (format-next-tabpos *format-string-charpos))
			    (t (1+ *format-string-charpos)))))))
       (formfeed (or (zerop *format-string-charpos) (terpri s)) (terpri s) t)
       (charpos *format-string-charpos)
       (linel *format-string-linel)
       (which-operations '(tyo formfeed charpos linel))
       (t (error '|Unhandled sfa operation in formatting to a string| op))))

(define-private-variable *format-string-stream
     (initialization (sfa-create 'fsfa/| 0 '*format-string-stream)))}


{(only-for Multics)

(define-private-routine (fsfa/| s op (optional arg1) (any-number-of rest))
    (caseq op
       (tyo (push arg1 *format-collecting-string)
	    (setq *format-string-charpos
		  (caseq arg1
		     ((#\cr #\ff) 0)
		     (#\lf *format-string-charpos)
		     (#\bs (max (1- *format-string-charpos) 0))
		     (#\tab (let ((new (+ *format-string-charpos 10.)))
			       (- new (\ new 10.))))
		     (t (1+ *format-string-charpos)))))
       (charpos (cond ((null arg1) *format-string-charpos)
		      (t (setq *format-string-charpos arg1))))
       (linel (cond ((null arg1) *format-string-linel)
		    (t (setq *format-string-linel arg1))))
       (which-operations '(tyo charpos linel))
       (t (format-stream-default s op arg1 rest))))

(define-private-variable *format-string-stream
    (default-initialization '(format-stream fsfa/|)))}


{-- we also define a mechanism for finding out the "flatc" of something;
ie, the number of characters which are output via some arbitrary 
printing of something. }


(define-public-macro (format-flatc (any-number-of forms))

    (dcls (needed-for public-compilation umacs) (divdoc idefs))
    {(only-for NIL)
       (counting-characters-output (standard-output)
	 (let ((*format-sfap ())) ,@forms))
       }
    {(except-for NIL)
       `(let ((*format-flatc 0)
	      (standard-output *format-flatc-stream)
	      {(only-for Maclisp) (*format-sfap 't)})
	   ,@forms
	   *format-flatc)
       }
    )

{(except-for NIL)

{(only-for PDP-10)
  (progn ; Another non-modular piece of shit.
	 (defprop format-flatc |FORMAT-FLATC.RMac| macro)
	 (defprop |FORMAT-FLATC.RMac| ((lisp) format umacs) autoload))}


(define-private-variable *format-flatc 
    (referenced-at-visibility-class public)
    (data-type fixnum))


{(only-for PDP-10)

(define-private-routine (format-flatc-stream (unused s) op arg)

    (caseq op
       (tyo (or (< arg 0) (setq *format-flatc (1+ *format-flatc))))
       (which-operations '(tyo))
       (t (error '|is an illegal operation in a format-flatc| op))))
}


{(only-for Multics)
(define-private-routine (format-flatc-stream
			   s op (optional arg1) (any-number-of rest))

    (caseq op
       (tyo (setq *format-flatc (1+ *format-flatc)))
       (which-operations '(tyo))
       (t (format-stream-default s op arg1 rest))))
}


(define-private-variable *format-flatc-stream
    (referenced-at-visibility-class public)	; see format-flatc
    (initialization
       {(only-for PDP-10)
	  (sfa-create #'format-flatc-stream 0 'format-flatc-stream)}
       {(except-for PDP-10) '(format-stream format-flatc-stream)}))

}

{(document-routine format-flatc)
.lisp
(format-flatc 2form1* 2form2* ... 2formn*)
.end_lisp
The 2form*s are evaluated in an environment similar to that used
inside of 3format*:  the various 3format* output-performing
routines such as 3format-tyo* and 3format-princ* may be used
to "perform output".  In ald but the Multics Maclisp implementation,
3standard-output* will be a stream which simply counts the
characters output--it will only support the 3tyo* operation.
}


;;;; Toplevel Dispatches


(define-system-routine (format-one-string string-or-symbol)
    ; Actually, string-or-symbol should never be a symbol in implementations
    ; where it is possible to convert it to a string with no datastructure
    ; creation;  i.e., Lispm and NIL where the get-pname of a symbol
    ; simply accesses the pname slot of it.  In those cases it may be operated
    ; on without checking.
    (bindq *format-string string-or-symbol
	   *format-string-length 0
	   *format-string-index 0)
    {(except-for Maclisp)
       (or (stringp string-or-symbol)
	   (setq string-or-symbol (string string-or-symbol)))
       }
    (setq *format-string-length (format-string-length string-or-symbol))
    (loop while (format-process-text)
	  as params = (format-collect-params)
	  do (format-call-op
	        (format-read-op)
		(format-get-list-buffer-pointer params))
	     (format-reclaim-list-buffer params)))

;;;; Interpret a format argument


(define-system-routine (format-interpret-arg arg)
  (bindq format:colon-flag () format:atsign-flag ()
	 {Maclisp colon-flag () atsign-flag () {PDP-10 *format-stringp nil}})
  {(only-for PDP-10)
     (or *format-in-string-environment?
	 (and (fboundp 'stringp) (setq *format-in-string-environment? t)))
     }
  (cond ((symbolp arg)
	   (format-one-string {(only-for Maclisp) arg}
			      {(except-for Maclisp) (get-pname arg)}))
	((format-stringp arg)
	   {PDP-10 (setq *format-stringp arg)} (format-one-string arg))
	((atom arg) (format-err1 "Garbage format control string" arg))
	('t (loop for frob in arg
		  do (if {(only-for Multics) (not (eq (typep frob) 'list))}
			 {(except-for Multics) (not (pairp frob))}
			 (format-princ frob)
			 (format-call-op
			    (if (format-op? (car frob))
				(car frob)
				(format-intern
				  {(only-for Maclisp) (exploden (car frob))}
				  {(except-for Maclisp)
				     (to-string (car frob))}))
			    (cdr frob)))))))

;;;; format-internal

(define-system-routine (format-internal stream control-string arglist)

    (bindq *format-original-args arglist
	   *format-args arglist
	   *format-string ()			; .see format-err1
	   )
    (if (eq stream 'string)
	(format-collect-string
	  (format-catch (format-/:/^-tag format-/^-tag)
	    (format-interpret-arg control-string)))
	(format-catch (format-/:/^-tag format-/^-tag)
	   (cond ((eq stream 'format) (format-interpret-arg control-string))
		 ('t {(only-for PDP-10)
			(and (not (atom stream))
			     (null (cdr stream))
			     (not (eq (car stream) t))
			     (setq stream (car stream)))
			}
		     (let ((standard-output stream)
			   {(only-for (or Maclisp NIL)) (*format-sfap nil)})
			{(only-for (or PDP-10 NIL))
			   (setq *format-sfap (sfap stream))
			   }
			(format-interpret-arg control-string)))))))


;;;; Character hacks

(define-system-routine (format-character frob)
    (declarations (value-type character-code))
    {(only-for PDP-10)
	(dcls (assembly-language-definition))
	(push p (% 0 0 fix1))
    format-character
	(skipn t a)
	  (jrst 0 foo-baz)
	(lsh t -9.)
	(hrrz t st t)
	(cain t 'fixnum)
	  (jrst 0 foo-bar)
	(cain t 'symbol)
	  (jrst 0 foo-baz)
	(skipn 0 (special *format-in-string-environment?))
	  (jrst 0 lose-lose)
	(call 1 'character)			; jonl's isn't ncallable
    foo-bar
	(move tt 0 a)
	(popj p)

    lose-lose
	(erint 2 (% sixbit |not a character!|))
	(jrst 0 format-character)

    foo-baz
	(movei b '1)
	(njcall 2 'getcharn)
    }
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((fixp frob) frob) (t (CtoI frob)))
	  }
       {(except-for Multics)
	  (dcls (open-code) (use-sublis-for-open-coding))
	  (character frob)
	  }
       }
    )

{(document-routine)
This performs coerces its argument to a fixnum code for a character,
in a method dependent on the implementation.
}


(define-system-routine (format-repeat-char char (fixnum n))
			    
    (bindq (character-code c) (format-character char))

    (loop repeat n do (format-tyo c)))


{(document-routine)
This outputs 2char* 2n* times.
}


;;;; FORMAT, ?FORMAT

(define-public-routine (format stream control-string (any-number-of frobs))
		       
    (declarations (slow-and-hairy))

    {(except-for PDP-10)
       (format-internal
	  (cond ((eq stream 't) ())
		((null stream) 'string)
		('t stream))
	  control-string frobs)})


(define-public-routine (?format destination control-string
				(any-number-of frobs))

    (declarations (slow-and-hairy))
    {(except-for PDP-10)
       (format-internal destination control-string frobs)})

{(only-for PDP-10)
; Eliminate user LSUBR calling sequence overhead, and at the same time
; get to use Lisp's LSUBR argument-number-checker.
(lap-a-list
  '((lap format lsubr)
    (args format (2 . 510.))
	(jsp tt lwnack)
	(#o777770_22 0 'format)
	(jsp r frobnicate)
	(skipn 0 a)
	  (movei a 'string)
	(came a (special *:truth))
	  (cain a 't)
	    (setz a)
	(jcall 3 'format-internal)

    frobnicate
	(setz a)
	(addi t 2)
	(skipn f t)
	  (jrst 0 foo)
    lp	(pop p b)
	(jsp t %pdlxc)
	(aojl f lp)
    foo	(movei c 0 a)
	(pop p b)
	(pop p a)
	(jrst 0 0 r)

    (entry ?format lsubr)
    (args ?format (2 . 510.))
	(jsp tt lwnack)
	  (#o777770_22 0 '?format)
	(jsp r frobnicate)
	(jcall 3 'format-internal)
    nil))
}


{(document-routine)
This is equivalent to 3format* except that 2destination* is
interpreted like the second argument to 3print*--3nil* means
"the default", and 3t* means "the terminal".  This only exists in
Maclisp at the moment.
}


;;;; format-justify

{(system-documentation)
.subsection "Useful Internal Routines"
	Here are various internal routines which may be of use to
3format* operators.
}


(define-system-routine (format-justify
			  how mincol? colinc? minpad? padchar?
			  function (any-number-of additional-args))

    (declarations (slow-and-hairy))

    (auxiliary-bindings
	((fixnum mincol) (or mincol? 0))
	((fixnum colinc) (or colinc? 1))
	((fixnum minpad) (or minpad? 0))
	((character-code padchar)
	   (if padchar? (format-character padchar?) #\sp))
	((fixnum size) (if (not (plusp mincol))
			   (setq mincol 0)
			   (format-flatc (apply function additional-args))))
	((fixnum leftpad)) ((fixnum rightpad)) ((fixnum fullpad)))

    (and (< colinc 1) (setq colinc 1))
    (and (< minpad 0) (setq minpad 0))

    (setq fullpad (+ size minpad))
    (and (< fullpad mincol)
	 (setq fullpad (+ fullpad (* colinc (// (+ (- mincol fullpad)
						   (1- colinc))
						colinc)))))
	   
    ;; Figure out how many pad characters we want:
    (setq fullpad (- fullpad size))

    ;; and distribute them.
    (caseq how
      (right (setq leftpad fullpad))
      (center (setq leftpad (// fullpad 2) rightpad (- fullpad leftpad)))
      (t ; Default is left
	 (setq rightpad fullpad)))

    (format-repeat-char padchar leftpad)
    (apply function additional-args)
    (format-repeat-char padchar rightpad)

    {(only-for PDP-10) (reclaim additional-args (setq additional-args nil))})


{(document-routine)
This is the primitive routine for outputting something in a
fixed-width field.  2how* should be one of the atoms 3left*,
3right*, or 3center*.  2function* is applied to
2additional-arguments* once to see how much space that output
will take, and then a second time amidst the appropriate padding.
2mincol*, 2colinc*, 2minpad*, and 2padchar* are used
as described under 3~A* to determine the total amount of pad
characters necessary;  in fact, 3~a* uses this routine.
}

;;;; Output some random object

(define-system-routine (format-lisp-object-op object params printing-function)

    (and format:colon-flag (null object)
	 (setq printing-function 'format-princ object "()"))
    ; Check for trivial special case:
    (if (null params) (funcall printing-function object)
	(format-justify (if format:atsign-flag 'right 'left)
			(car params) ;mincol
			(car (setq params (cdr params))) ;colinc
			(car (setq params (cdr params))) ;minpad
			(car (setq params (cdr params))) ;padchar
			printing-function object)))


{(document-routine)
This is the routine which implements 3~A* and 3~S*.
2object* is the arg, 2params* the parameters, and
2printing-function* the 3format* outputting function which
produces the output:  for 3~A* it is 3format-princ* and for
3~S* it is 3format-prin1*, for example.  If
3format:colon-flag* is not 3nil* and 2object* is, then
this behaves as if 2object* were the string 3"()"* and
2printing-function* were 3format-princ*--it prints 3()*.
}


(define-format-op A (params arg)
     (format-lisp-object-op arg params 'format-princ))

(define-format-op S (params arg)
    (format-lisp-object-op arg params 'format-prin1))

{(divert-documentation-to ops)
.item ~A
2arg*, any Lisp object, is printed without slashification (like
3princ*).  3~2n*A* inserts spaces on the right, if
necessary, to make the column width at least 2n*.
3~2mincol,colinc,minpad,padchar*A* is the full form of
3~A*, which allows aleborate control of the padding.  The string
is padded on the right with at least 2minpad* copies of
2padchar*;  padding characters are then inserted 2colinc*
characters at a time until the total width is at least 2mincol*.
The defaults are 30* for 2mincol* and 2minpad*, 31*
for 2colinc*, and 2space* for 2padchar*.  The atsign
modifier causes the output to be right-justified in the field instead
of left-justified.  (The same algorithm for calculating how many pad
characters to output is used.)  The colon modifier causes an 2arg*
of 3nil* to be output as 3()*.

.item ~S
This is identical to 3~A* except that it uses 3prin1* instead
of 3princ*.
}

{(divert-documentation-to chart)
.item ~A
3princ*s 2arg*.
.item ~S
3prin1*s 2arg*.
}

;;;; Integer hackery

{(system-documentation)
	The following are used to output integers.
}


(define-system-routine (format-tyo-digit (fixnum integer))
  ; Used by FLRMAT...
  (format-tyo
    {(only-for Maclisp)
       (+ integer (if (> integer 9.) #.(- #/A 10.) #/0))
       }
    {(except-for Maclisp)
       (char-n "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" integer)
       }
    )
  )

{(document-routine)
This takes what is presumed to be a single-digit integer, and outputs
that character to 3standard-output*.  For example, if 2integer*
is 5, the character "5" is output;  if 2integer* is 12 (decimal),
the character "C" is output.  2integer* may be from 0 to 35
(decimal), inclusive.
}

(define-system-routine (format-integer
			  (integer integer) use-commas? output-sign?)
    (bindq plusp 't)
    (cond ((minusp integer) (setq integer (minus integer) plusp ())))
    (and output-sign? (format-tyo (if plusp #/+ #/-)))
    (format-integer-1 integer use-commas?))

{(document-routine)
This prints 2integer* to 3standard-output* in the current
output radix.  If 2use-commas?* is not 3nil*, it is the
character code of the character to use for commas, and commas will be
output between each group of three digits.  If 2output-sign?* is
non-null, then the sign character is output (no matter what the sign
is), otherwise the sign is ignored.
}


(define-private-routine (format-integer-1 (integer integer) use-commas?)
    (auxs ((fixnum nn))
	  ((fixnum b2) (* base base))
	  ((fixnum b3) (* b2 base))
	  (fl ()))
    (cond ((not (lessp integer b3))
	     (format-integer-1 (quotient integer b3) use-commas?)
	     (setq nn (remainder integer b3) fl 't)
	     (and use-commas? (format-tyo use-commas?)))
	  ('t (setq nn integer)))
    (and (or fl (not (< nn b2))) (format-tyo-digit (\ (// nn b2) base)))
    (and (or fl (not (< nn base))) (format-tyo-digit (\ (// nn base) base)))
    (format-tyo-digit (\ nn base))
    )



(define-system-routine (format-integer-in-base-op arg params radix)
    (bindq *nopoint 't base radix)
    (if (or (not (fixp arg)) (not (fixp radix)))
	(format-justify
	   'right (car params) () () (cadr params) 'format-princ arg)
	(format-justify
	   'right (car params) () () (cadr params) 'format-integer arg
	   (and format:colon-flag
		(format-character (or (caddr params) #/,)))
	   (or format:atsign-flag (minusp arg)))))


{(document-routine)
This is the subroutine which does the appropriate things to implement
3~D* and 3~O*, given the argument, parameters, and radix.
}

(define-format-op D (params arg)
    (format-integer-in-base-op arg params 10.))

(define-format-op O (params arg)
    (format-integer-in-base-op arg params 8.))


{(divert-documentation-to ops)
.item ~D
Decimal integer output.
2arg* is printed as a decimal integer.
3~2n*,2m*,2o*D* uses a column width of
2n*, padding on the left with pad-character 2m* (default of
space), using the character 2o* (default comma) to separate
groups of three digits.  These commas are only inserted if the
3:* modifier is present.  Additionally, if the 3@* modifier
is present, then the sign character will be output unconditionally;
normally it is only output if the integer is negative.  If 2arg*
is not an integer, then it is output (using 3princ*)
right-justified in a field 2n* wide, using a pad-character of
2m*, with 3base* decimal and 37**nopoint* bound to
3t*.

.item ~O
Octal integer output.  Just like 3~D*.
}

{(divert-documentation-to chart)
.item ~D
Decimal integer printing
.item ~O
Octal integer printing.
}


;;;; Random operators


(define-format-op P ((unused params) . arglist)

    (and format:colon-flag (setq arglist (format-argmove -1 arglist)))

    (cond ((equal (car arglist) 1) (and format:atsign-flag (format-tyo #/y)))
	  (format:atsign-flag (format-princ "ies"))
	  ('t (format-tyo #/s)))

    (cdr arglist))


{(divert-documentation-to ops)
.item ~P
If 2arg* is not 31*, a lower-case "s" is printed.  ("P" is for
"plural".)  3~:P* does the same thing, after backing up an
argument (like "3~:**", below);  it prints a lower-case 3s* if
the 2last* argument was not 1.  3~@P* prints "y" if the
argument is 1, or "ies" if it is not.  3~:@P* does the same thing,
but backs up first.
.break
Example:
.lisp
(format nil "~D Kitt~:@P" 3)  =>  "3 Kitties"
.end_lisp
}

{(divert-documentation-to chart)
.item ~P
Pluralize. (Output "s" if 2arg* not 1)
}


(define-system-routine (format-argmove (fixnum n) arglist)
    (cond ((minusp n)
	     (setq n (+ (- (length *format-original-args) (length arglist)) n)
		   arglist *format-original-args)))
    (format-nthcdr n arglist))


(define-format-op /* (params . arglist)
    (bindq (fixnum n) (or (car params) 1))
    (and format:colon-flag (setq n (- n)))
    (format-argmove n arglist))

{(divert-documentation-to ops)
.item ~*
3~** ignores one 2arg*. 3~2n*** ignores the next 2n*
arguments.  2n* may be negative.  3~:** backs up one arg;
3~2n*:** backs up 2n* args.
}

{(divert-documentation-to chart)
.item ~2n**
Ignores 2n* (default 1) args.
.item ~2n*:*
Backs up 2n* (default 1) args.
}



(define-format-op G (params . arglist)
    arglist ; unused
    (format-nthcdr (or (car params) 0) *format-original-args))


{(divert-documentation-to ops)
.item ~2n*G
"Goes to" the 2n*th argument.  3~0G* goes back to the first
argument in 2args*.  Directives after a 3~2n*G* will take
sequential arguments after the one gone to.  Note that this command,
and 3~**, only affect the "local" 2args*, if "control" is
within something like 3~{*.
'c Matching }
}

{(divert-documentation-to chart)
.item ~2index*G
Go to the 2index*th arg, zero-origined.
}


(define-system-routine (format-nterpri count?)

    (loop repeat (or count? 1) do (format-terpri)))


{(document-routine)
This outputs 2count?* newlines to 3standard-output*.  If
2count?* is 3nil*, 31* is used.
}


(define-format-op /% (params)

    (format-nterpri (car params)))

{(divert-documentation-to ops)
.item ~%
Outputs a newline.  3~2n*%* outputs 2n* newlines.  No
argument is used.
}

{(divert-documentation-to chart)
.item ~%
Newline.  Takes repeat count parameter.
}


(define-format-op /& (params)

    (format-fresh-line)
    (and (car params) (format-nterpri (1- (car params)))))


{(divert-documentation-to ops)
.item ~&
The 3fresh-line* operation is performed on the output stream.
3~2n*&* outputs 32n*-1* newlines after the fresh-line.
The 3fresh-line* operation says to do a 3terpri* unless the
cursor is at the start of the line.  This operation will virtually
always succeed in Maclisp, since all Maclisp file arrays know their
3charpos*.  Implemented by 3format-fresh-line*,
(format-fresh-line-fun).
}


{(divert-documentation-to chart)
.item ~&
Fresh-line.  Takes repeat count parameter.
}


(define-format-op X #\sp)

{(divert-documentation-to ops)
.item ~X
Outputs a space.  3~2n*X* outputs 2n* spaces.  No
argument is used.
}

(define-format-op /~ #/~)

{(divert-documentation-to ops)
.item ~~
Outputs a tilde.  3~2n*~* outputs 2n* tildes.  No argument
is used.
}

{(divert-documentation-to chart)
.item ~X
output a space.  Takes repeat count parameter.
.item ~~
output a tilde.  Takes repeat count parameter.
}


(define-format-op #\newline ((unused params))
    (cond (format:atsign-flag (format-terpri)))
    (bindq (fixnum i) *format-string-index)
    {(only-for PDP-10)
       (and (< i *format-string-length)
	    (= (format-get-char i) #\linefeed)
	    (setq i (1+ i)))}
    (and (not format:colon-flag)
	 (loop while (< i *format-string-length)
	       as ch fixnum = (format-get-char i)
	       while (or (= ch #\tab) (= ch #\space))
	       do (setq i (1+ i))))
    (setq *format-string-index i))


{(divert-documentation-to ops)
.item ~2newline*
Tilde immediately followed by a carriage return ignores the carriage
return and any whitespace at the beginning of the next line.  With a
3:*, the whitespace is left in place.  With an 3@*, the
carriage return is left in place.  This directive is typically used
when a format control string is too long to fit nicely into one line
of the program:
.lisp
(format the-output-stream "~&This is a reasonably ~
			   long string~%")
.end_lisp
which is equivalent to 3format*ing the string
.lisp
"~&This is a reasonably long string~%"
.end_lisp
}

{(divert-documentation-to chart)
.item ~2newline*
Ignore following whitespace.  3@* says "but don't ignore the
2newline*", and 3:* says "but don't ignore the whitespace".
}


(define-format-op /| ((unused params))

    (format-formfeed))

{(divert-documentation-to ops)
.item ~|
Outputs a formfeed.  3~2n*|* outputs 2n* formfeeds.  No
argument is used.  This is implemented by 3format-formfeed*,
(format-formfeed-fun).
}

{(divert-documentation-to chart)
.item ~|
formfeed.  Takes repeat count parameter.
}


(define-format-op t (params)
  (format-tab-to
     (or (car params) 1) (cadr params) ; () -> 1
     {(except-for Maclisp) (if format:colon-flag ':pixels ':characters)}))

{(divert-documentation-to ops)
.item ~T
Spaces over to a given column.  The full form is
3~2destination*,2increment*T*, which will output
sufficient spaces to move the cursor to column 2destination*.  If
the cursor is already past column 2destination*, it will output
spaces to move it to column 2destination3+*increment7**k*,
for the smallest integer value 2k* possible.  2increment*
defaults to 31*.  This is implemented by the 3format-tab-to*
function, (format-tab-to-fun).
}

{(divert-documentation-to chart)
.item ~2n*T
Tab to column 2n*.
}

{-- 
(define-format-op q (params arg)
    (apply arg params))
}

(putprop (format-char-table #/Q)
	 {(only-for (and PDP-10 Format-Subr-Properties))
	    (or (get '*apply 'subr) 'apply)}
	 {(except-for (and PDP-10 Format-Subr-Properties))
	    #'apply}
	 'format-ctl-one-arg)

{(divert-documentation-to ops)
.item ~Q
3~Q* uses one argument, and applies it as a function to
2params*.  It could thus be used to, for example, get a specific
printing function interfaced to 3format* without defining a
specific operator for that operation, as in
.lisp
(format t "~&;  The frob ~vQ is not known.~%"
	frob 'frob-printer)
.end_lisp
The printing function should obey the conventions described in
(define-your-own-section-page).  Note that the function to 3~Q*
follows the arguments it will get, because they are passed in as
3format* parameters which get collected before the operator's
argument.
}


;;;; CASE - ~[ ... ~]

(define-private-variable *format-case-more?)

(define-format-op /[ (params . arglist)
    (bindq *format-case-more? 't arg nil)
    (cond ((not (null format:atsign-flag))
	     (cond (format:colon-flag (format-err "~:@[ is not defined"))
		   ('t (cond ((car (setq *format-args arglist))
			        (format-case-process))
			     ('t (format-case-skip)
				 (setq *format-args (cdr arglist))))
		       (and *format-case-more?
			    (format-err "~@[ should have no ~;")))))
	  ((progn (setq arg (if (null params) (pop arglist) (car params))
			*format-args arglist)
		  (not (null format:colon-flag)))
	     (and arg (format-case-skip))
	     (and *format-case-more? (format-case-process))
	     (loop while *format-case-more? do (format-case-skip)))
	  ((not (fixp arg)) (format-err1 "bad arg to ~[" arg))
	  ((and (format-tildep (format-get-char *format-string-index))
		(let ((*format-string-index (1+ *format-string-index)))
		  (and (format-skip-params) (eq (format-read-op) '/;))))
	     (loop with saved-pos = (1+ *format-string-index) and params
	       do (setq *format-string-index saved-pos)
		  (setq params (format-collect-params))
		  (setq params (format-get-list-buffer-pointer params))
		  (format-read-op)
		  (cond ((if format:colon-flag
			     (or (null params) (member arg params))
			     (loop unless (< arg (car params))
				     unless (> arg (cadr params))
				       return 't
				   while (setq params (cddr params))))
			   (and *format-case-more? (format-case-process))
			   (loop while *format-case-more?
				 do (format-case-skip))
			   (return ()))
			('t (setq saved-pos (format-case-skip))))))
	  ('t (loop repeat (if (minusp arg) 259259. arg)
		    do (format-case-skip)
		    while (eq *format-case-more? 't))
	      (and *format-case-more? (format-case-process))
	      (loop while *format-case-more? do (format-case-skip))))
    *format-args)


(define-private-routine (format-case-skip)
    (loop with level fixnum = 0 and (saved-pos op tem)
	  unless (format-skip-text) do (format-err "Unterminated ~[")
	  do (setq saved-pos *format-string-index)
	     (format-skip-params)
	     (setq op (format-read-op))
	     (cond ((eq op '/[) (setq level (1+ level)))
		   ((eq op '/])
		      (and (minusp (setq level (1- level)))
			   (return (setq *format-case-more? ()))))
		   ((setq tem (assq op '((/{ . /}) (/< . />) (/( . /)))))
		      (format-skip-bracket tem))
		   ((and (zerop level) (eq op '/;))
		      (and format:colon-flag (setq *format-case-more? '/;))
		      (return saved-pos)))))


(define-private-routine (format-skip-bracket pair)
    {-- Returns T if nothing occurs between the bracketed operators,
	NIL otherwise.}
    (loop with rb = (cdr pair) and (op tem) and emptyp = 't
	  as empty-pos fixnum = (1+ *format-string-index)
	  unless (format-skip-text)
	    do (format-err1 "Unbalanced brackets" pair)
	  when (not (= empty-pos *format-string-index)) do (setq emptyp ())
	  do (format-skip-params)
	     (setq op (format-read-op))
	  when (eq op rb) return emptyp
	  do (setq emptyp ())
	     (cond ((setq tem (assq op '((/< . />) (/[ . /])
					 (/{ . /}) (/( . /)))))
		      (format-skip-bracket tem)
		      (setq emptyp ()))
		   ((memq op ; Matched "{"
			     '(/] /) /> /}))
		      (format-err1 "Mismatched brackets" (cons op pair))))))


(define-private-routine (format-case-process)
    (loop with params
	  unless (format-process-text) do (format-err "Unterminated ~[")
	  as saved-pos-before = *format-string-index
	  do (format-skip-params)
	  as saved-pos-after = *format-string-index
	  as op = (format-read-op)
	  {-- as saved-final-pos = *format-string-index}
	  do (cond ((eq op '/;)
		      (return (setq *format-string-index saved-pos-before)))
		   ((eq op '/]) (return (setq *format-case-more? ())))
		   ('t (cond ((= saved-pos-before saved-pos-after)
			        (setq params ()))
			     ('t (setq *format-string-index saved-pos-before)
				 (setq params (format-collect-params))
				 {-- (setq *format-string-index
					   saved-final-pos)
				     }
				 (format-read-op)))
		       (format-call-op op
			  (and params
			       (format-get-list-buffer-pointer params)))
		       (and params (format-reclaim-list-buffer params))))))


{(divert-documentation-to ops)
.item ~[
3~[2str0*~;2str1*~;2...*~;2strn*~]* is a set of
alternative control strings.  The alternatives (called 2clauses*)
are separated by 3~;* and the construct is terminated by 3~]*.
For example, "3~[Siamese ~;Manx ~;Persian ~;Tortoise-Shell ~;Tiger
~;Yu-Hsiang ~]kitty*".  The 2arg*th
alternative is selected; 30* selects the first.
If a numeric parameter is given (i.e. 3~2n*[*),
then the parameter is used instead of an argument
(this is useful only if the parameter is "3#*").
If 2arg* is out of range no alternative is selected.
After the selected alternative has been processed, the control string
continues after the 3~]*.

~[2str0*~;2str1*~;2...*~;2strn*~:;2default*~] has a default case.
If the 2last* 3~;* used to separate clauses
is instead 3~:;*, then the last clause is an "else" clause,
which is performed if no other clause is selected.
For example, "3~[Siamese ~;Manx ~;Persian ~;Tortoise-Shell ~;Tiger
~;Yu-Hsiang ~:;Unknown ~] kitty*".

~[~2tag00*,2tag01*,2...*;2str0*~2tag10*,2...*;2str1...*~]
allows the clauses to have explicit tags.  The parameters to each 3~;*
are numeric tags for the clause which follows it.  That clause is processed
which has a tag matching the argument.  If 3~:2a1*,2a2*,2b1*,2b2*,2...*;*
is used, then the following clause is tagged not by single values but
by ranges of values 2a1* through 2a2* (inclusive), 2b1* through 2b2*, etc.
3~:;* with no parameters may be used at the end to denote a default clause.
For example, "3~[~'+,'-,'*,'//;operator ~'A,'Z,'a,'z;letter ~'0,'9;digit ~:;other ~]*".

3~:[2false*~;2true*~]* selects the 2false* control string
if 2arg* is 3nil*, and selects the 2true* control string otherwise.

3~@[2true*~]* tests the argument.  If it is not 3nil*,
then the argument is not used up, but is the next one to be processed,
and the one clause is processed.
If it is 3nil*, then the argument is used up, and the clause is not processed.
.lisp
(setq prinlevel nil prinlength 5)
(format nil "~@[ PRINLEVEL=~D~]~@[ PRINLENGTH=~D]"
	prinlevel prinlength)
   =>  " PRINLENGTH=5"
.end_lisp
}

{(divert-documentation-to chart)
.item ~[
3~[2text1*~;2text2*~;...~]*
3format*s only the 2arg*th text string.
.item ~;
Delimits text strings for 3~[* and 3~<*.
}

;;;; Format Roman Numeral

(define-hidden-hack (format-print-roman-char (fixnum i) (fixnum x)) num

   (format-tyo (format-nth (+ i x x) '(#/I #/V #/X #/L #/C #/D #/M))))


(define-hidden-hack (format-print-roman-1 (fixnum x) (fixnum n) oldp) num

    (cond ((> x 9.)
	     (format-print-roman-1 (// x 10.) (1+ n) oldp)
	     (setq x (\ x 10.))))
    (cond ((and (= x 9.) (not oldp))
	     (format-print-roman-char 0 n)
	     (format-print-roman-char 0 (1+ n)))
	  ((= x 5) (format-print-roman-char 1 n))
	  ((and (= x 4) (not oldp))
	     (format-print-roman-char 0 n)
	     (format-print-roman-char 1 n))
	  ('t (cond ((> x 5) (format-print-roman-char 1 n) (setq x (- x 5))))
	      (loop repeat x do (format-print-roman-char 0 n)))))


;;;; Number print in English

{(except-for Maclisp)

(define-private-variable *format-small-english-numbers)


(define-private-xmacro (format-small-english-numbers (fixnum i))
    {(only-for NIL)
       `(vref *format-small-english-numbers ,i)
       }
    {(except-for NIL)
       `(aref *format-small-english-numbers ,i)
       }
    )
}

{(only-for Maclisp)
  (divert-forms-to (compilation-environment sysdcl)
      (array* (notype (format-small-english-numbers 19.))))}


(divert-forms-to (num interpreter)
  ((lambda (list)
      {(only-for NIL)
         (setq *format-small-english-numbers (to-vector list))
	 }
      {(except-for NIL)
         (fillarray
	    {(only-for Maclisp)
	       (array format-small-english-numbers t 19.)
	       }
	    {(except-for Maclisp)
	       (setq *format-small-english-numbers (*array nil t 19.))
	       }
	    list)})
   '(("one" . "first") ("two" . "second") ("three" . "third")
     ("four" . "fourth") ("five" . "fifth") ("six" . "sixth")
     ("seven" . "seventh") ("eight" . "eighth") ("nine" . "ninth")
     ("ten" . "tenth") ("eleven" . "eleventh") ("twelve" . "twelfth")
     ("thirteen" . "thirteenth") ("fourteen" . "fourteenth")
     ("fifteen" . "fifteenth") ("sixteen" . "sixteenth")
     ("seventeen" . "seventeenth") ("eighteen" . "eighteenth")
     ("nineteen" . "nineteenth"))))


(define-system-hack (format-print-english n ordinalp) num

   (cond ((minusp n) (format-princ "minus ") (setq n (minus n))))

   (cond ((zerop n)
	    (format-princ "zero")
	    (and ordinalp (format-princ "th")))
	 ((and (lessp 1099. n 10000.) (plusp (\ (// n 100.) 10.)))
	    (format-print-english-1 (// n 100.) ())
	    (format-princ " hundred")
	    (cond ((plusp (setq n (\ n 100.)))
		     (and ordinalp (format-princ " and"))
		     (format-tyo #\sp)
		     (format-print-english-1 n ordinalp))
		  (ordinalp (format-princ "th"))))
	 ('t (format-print-english-1 n ordinalp))))

{(document-routine)
This is the primitive for printing integers in "english", as with
3~R* and 3~:R*.
}


(define-hidden-hack (format-print-english-1 (integer n) ordinalp) num

  (auxiliary-bindings
     (q ())
     (no-illion-flag 't)
     (l '((1000000. . "m") (1000000000. .  "b") (1000000000000. . "tr")
	  (1000000000000000. . "quadr") (1000000000000000000. . "quint")
	  (1000000000000000000000. . "sext")
	  (1000000000000000000000000. . "sept")
	  (1000000000000000000000000000. . "oct")
	{--
	  (1000000000000000000000000000000. . "non")
	  (1000000000000000000000000000000000. . "dec")
	  (1000000000000000000000000000000000000.  . "undec")
	  (1000000000000000000000000000000000000000. . "duodec")
	  (1000000000000000000000000000000000000000000. . "tredec")
	  (1000000000000000000000000000000000000000000000. . "quattuordec")
	  (1000000000000000000000000000000000000000000000000. . "quindec")
	  (1000000000000000000000000000000000000000000000000000. . "sexdec")
	  (1000000000000000000000000000000000000000000000000000000.
		. "septdec")
	  })))
  (cond ((zerop n))
	((not (lessp n 1000.))
	   (setq q '(1000. . "thousand"))
	   (do () ((or (null l) (lessp n (caar l))))
	     (setq q (car l) l (cdr l) no-illion-flag ()))
	   (format-print-english-1 (quotient n (car q)) ())
	   (format-tyo #\sp)
	   (format-princ (cdr q))
	   (or no-illion-flag (format-princ "illion"))
	   (cond ((plusp (setq n (remainder n (car q))))
		    (format-tyo #\sp)
		    (and ordinalp (lessp n 100.) (format-princ "and "))
		    (format-print-english-1 n ordinalp))
		 (ordinalp (format-princ "th"))))
	((< n 20.)
	   (setq q (format-small-english-numbers (1- n)))
	   (format-princ (if ordinalp (cdr q) (car q))))
	((< n 100.)
	   (format-princ (format-nth (- (// n 10.) 2)
				     '("twent" "thirt" "fort" "fift"
				       "sixt" "sevent" "eight" "ninet")))
	   (cond ((and (zerop (setq n (\ n 10.))) ordinalp)
		    (format-princ "ieth"))
		 ('t (format-tyo #/y)
		     (cond ((plusp n)
			      (format-tyo #/-)
			      (setq q (format-small-english-numbers (1- n)))
			      (format-princ
			         (if ordinalp (cdr q) (car q))))))))
	('t ;; (< n 1000.)
	   (format-print-english-1 (// n 100.) ())
	   (format-princ " hundred")
	   (cond ((plusp (setq n (\ n 100.)))
		    (format-tyo #\sp)
		    (and ordinalp (format-princ "and "))
		    (format-print-english-1 n ordinalp))
		 (ordinalp (format-princ "th"))))))


;;;; ~R - print number in various ways

(define-autoload-op R (params arg) num

    (cond ((not (null (car params)))
	     (format-integer-in-base-op arg (cdr params) (car params)))
	  ('t (setq arg (fix arg))
	      (if atsign-flag
		  (if (lessp 0 arg (if colon-flag 5000. 4000.))
		      (format-print-roman-1 arg 0 colon-flag)
		      (let ((base 10.) (*nopoint 't)) (format-princ arg)))
		  (format-print-english arg colon-flag)))))


{(divert-documentation-to ops)
.item ~R
'c I quote, once more:
If there is no parameter, then 2arg* is printed as a cardinal English number, e.g. four.
With the colon modifier, 2arg* is printed as an ordinal number, e.g. fourth.
With the atsign modifier, 2arg* is printed as a Roman numeral, e.g. IV.
With both atsign and colon, 2arg* is printed as an old Roman numeral, e.g. IIII.

If there is a parameter, then it is the radix in which to print the number.
The flags and any remaining parameters are used as for the 3~D* directive.
Indeed, 3~D* is the same as 3~10R*.  The full form here is therefore
3~2radix*,2mincol*,2padchar*,2commachar*R*.
}

{(divert-documentation-to chart)
.item ~R
cardinal number printing
.item ~:R
ordinal number printing
.item ~@R
roman numeral printing
.item ~@:R
old-roman numeral printing
.item ~2n*R
Like 3~D*, using radix 2n*
}


;;;; ~C - output a character in various forms

(define-public-variable format:*top-char-printer
    (default-init ()))


(define-format-op c ((unused params) arg)
   (auxs ((character-code ch) (format-character arg))
	 (chname (format-get-chname ch)))
   (cond ((not colon-flag)
	    (if (not atsign-flag) (format-tyo ch)
		(lbind (((fixnum bucky) (boole 1 (lsh ch -7.) 3)))
		  (format-tyo #/#)
		  (cond ((not chname)
			   ; super ascii-only crock. Should be fixed.
			   (or (zerop bucky)
			       (format-tyo (if (= bucky 3) 6 (1+ bucky))))
			   (setq ch (boole 1 ch 127.))
			   (setq chname (format-get-chname ch))))
		  (cond ((not (null chname))
			   (format-tyo #/\)
			   (format-lcprinc chname ()))
			('t (format-tyo #//) (format-tyo ch))))))
	 ('t (cond ((and (not chname) (plusp (boole 4 ch 127.)))
		    ; try once without the bits.  this is really for help.
		    (and (plusp (boole 1 ch #o200)) (format-princ "Control-"))
		    (and (plusp (boole 1 ch #o400)) (format-princ "Meta-"))
		    (and (plusp (boole 1 ch #o4000)) (format-princ "Top-"))
		    (setq chname (format-get-chname
				    (setq ch (boole 1 ch 127.))))))
	     (if (null chname) (format-tyo ch)
		 ; If we hit any 2-char (or less!) names, we probably
		 ; don't want them mixed-case, eg "Bs".
		 (if (> (flatc chname) 2)
		     (format-lcprinc chname 't)
		     ; Actually the following isn't strictly correct
		     ; for multics, where chname will really be in
		     ; lower-case, and we want it in upper...
		     (format-princ chname)))
	     (and atsign-flag
		  format:*top-char-printer
		  (funcall format:*top-char-printer ch chname)))))


(define-private-variable *format-chnames
    (default-init
      '({-- Provide defaults for all format-effectors}
	(backspace . #\backspace)
	(tab . #\tab)
	(space . #\space)
	(form . #\form)
	(linefeed . #\linefeed)
	(return . #\return)
	(form . #\form)
	{-- Rubout is fairly special}
	(rubout . #\rubout)
	{-- bell doesn't display too nicely}
	(bell . {(only-for Multics) 7} {(except-for Multics) #\bell})
	{-- a few random things}
	(help . #\help)
	{-- Altmode is fairly important as it occurs in control-char range}
	(altmode . #\altmode)
	)))

{(except-for PDP-10)
(define-private-variable format:*/#-var
    (default-init {(only-for Multics) '/#/\-alist}
		  {(except-for Multics) '/#-symbolic-characters-table}))
}


(define-private-routine (format-get-chname (character-code ch))
    {(except-for PDP-10)
       {(only-for Maclisp)
	  (or (and (boundp format:*/#-var)
		   (loop for pair in (symeval format:*/#-var)
			 when (= (cdr pair) ch) return (car pair)))
	      (loop for pair in *format-chnames
		    when (= (cdr pair) ch) return (car pair)))
	  }
       {(only-for Lispm)
	  (cdr (or (and (boundp format:*/#-var)
			(rassq ch (symeval format:*/#-var)))
		   (rassq ch *format-chnames)))
	  }
       {(only-for NIL)
	  (or (and (boundp format:*/#-var)
		   (loop with ch = (code-char ch)
			 for pair in (symeval format:*/#-var)
			 when (eq (cdr pair) ch) return (car pair)))
	      (loop for pair in *format-chnames
		    when (= (cdr pair) ch) return (car pair)))
	  }
       }
    {(only-for PDP-10)
	(dcls (assembly-language-definition))
	(move tt 0 a)
	(hrrz b (special /#-symbolic-characters-table))
	(caie b makunbound)
	  (jsp t lookup-one-frob)
	(move b (special *format-chnames))
	(jsp t lookup-one-frob)
	(setz a)
	(popj p)

    lookup-one-frob
	(jumpe b 0 t)
	(hlrz a 0 b)
	(hrrz c 0 a)
	(hrrz b 0 b)
	(came tt 0 c)
	  (jrst 0 lookup-one-frob)
	(hlrz a 0 a)
	(popj p)
	}
    )


{(divert-documentation-to ops)
.item ~C
2arg* is coerced to a character code.  With no modifiers, 3~C*
simply outputs this character.  3~@C* outputs the character so it
can be read in again using the 3#* reader macro:  if there is a
named character for it, that will be used, for example
"3#\Return*";  if not, it will be output like "3#/A*".
3~:C* outputs the character in human-readable form, as in
"Return", "Meta-A".  3~:@C* is like 3~:C*, and additionally
might (if warranted and if it is known how) parenthetically state how
the character may be typed on the user's keyboard.

To find the name of a character, 3~C* looks in two places.  The
first is the value of the symbol which is the value of
3format:*/#-var*,
'vindex format:*/#-var
which is initialized to be the variable which the 3#* reader macro
uses.  It is not necessary for the value of 3format:*/#-var* to be
bound.  The second place is 3*format-chnames*;  this is used
primarily to handle non-printing characters, in case the 3#*
reader macro is not loaded.  Both of these are a-lists, of the form
3((2name* . 2code*) (2name* . 2code*) ...)*.

The Maclisp/NIL 3format* has no mechanism for telling how a
particular character needs to be typed on a keyboard, but it does
provide a hook for one.  If the value of 3format:*top-char-printer*
'vindex format:*top-char-printer
is not 3nil*, then it will be called as a function on two arguments:  the character code, and the character name.  If there were bucky-bits present, then they will have been stripped off unless there was a defined name for the character with the bits present.  The function should do nothing in normal
cases, but if it does it should output two spaces, and then the
how-to-type-it-in description in parentheses.  See
(define-your-own-section-page) for information on how to do output
within 3format*.
}

{(divert-documentation-to chart)
.item ~C
Outputs the character 2arg*.
.item ~:C
Outputs the name of the character 2arg*.
}


;;;; ~< - justify things in a field


(define-autoload-op /< (params) brack

    (auxiliary-bindings
	((fixnum mincol)) ((fixnum colinc)) ((fixnum minpad))
	((fixnum padchar)) ((fixnum total-width) 0) ((fixnum frob-count) 0)
	((fixnum fullpad)) (op) (left-space? colon-flag)
	((fixnum total-space)) (right-space? atsign-flag) ((fixnum n))
	(prefix) (prefixp) ((fixnum prefix-size)) (frobs) (tem) (semi-params))

    (setq mincol (or (car params) 0)
	  colinc (or (car (setq params (cdr params))) 1)
	  minpad (or (car (setq params (cdr params))) 0)
	  padchar (format-character (or (cadr params) #\sp)))

    (format-catch format-/^-tag
       (loop with saved-pos fixnum = 0
	     until (eq op '>) do
	  (setq tem (format-collect-string-internal
		       (loop while (format-process-text)
			  do (setq params (format-collect-params)
				   op (format-read-op))
			     (if (memq op '(/; />)) (return ())
				 (format-call-op
				    op
				    (format-get-list-buffer-pointer params)))
			     (format-reclaim-list-buffer params)
			  finally
			     (format-err "Unterminated ~< in format string"))
		       (setq saved-pos *format-string-charpos)))
	  (cond ((or (eq op '/>) (not colon-flag) prefixp frobs)
		   (push tem frobs)
		   (setq total-width
			 (+ total-width (format-collected-string-length tem))))
		('t (setq semi-params (format-get-list-buffer-pointer params)
			  prefix-size saved-pos
			  prefix tem
			  prefixp 't)))))
    (or (eq op '/>)
	{-- If we terminated early due to a ~^, then we must flush the
	    remaining stuff.}
	(format-skip-bracket '(/< . />)))

    {-- We by default put in N-1 breaks for N segments:}
    (setq frob-count (1- (length (setq frobs (nreverse frobs)))))

    (and left-space? (setq frob-count (1+ frob-count)))
    (and right-space? (setq frob-count (1+ frob-count)))
    {-- But if there are no flags and only one segment, we right-justify:}
    (and (zerop frob-count) (setq left-space? 't frob-count 1))

    {-- Now, figure out just how many pad characters we need.}
    (setq total-space (+ total-width (* frob-count minpad)))
    (setq total-space
	  (if (< total-space mincol) mincol
	      (+ mincol (* colinc (// (+ (- total-space mincol) (1- colinc))
				      colinc)))))

    {-- Maybe output the prefix on a new line.}
    (cond ((not (null prefixp))
	     (lbind (((fixnum linel) (or (cadr semi-params) (format-linel)))
		     ((fixnum charpos) (format-charpos)))
	       (and (car semi-params)
		    (setq linel (- linel (car semi-params))))
	       (cond ((and (not (zerop linel))
			   (not (< total-space (- linel charpos)))
			   (> charpos
			      (+ (format-collected-string-length prefix)
				 prefix-size)))
			(format-string-out-collected-string prefix))))))

    (setq fullpad (- total-space total-width))

    (cond (left-space?
	     (setq n (// fullpad frob-count)
		   fullpad (- fullpad n)
		   frob-count (1- frob-count))
	     (format-repeat-char padchar n)))

    (loop while frobs
	  as pseudo-string = (car frobs)
	  do (setq frobs (cdr frobs))
	     (format-string-out-collected-string pseudo-string)
	     (format-reclaim-collected-string
	        (prog1 pseudo-string (setq pseudo-string nil)))
	  when (plusp frob-count)
	    do (setq n (// fullpad frob-count)
		     fullpad (- fullpad n)
		     frob-count (1- frob-count))
	       (format-repeat-char padchar n)))


{(divert-documentation-to ops)
.item ~<
3~2mincol*,2colinc*,2minpad*,2padchar*<2text*~>*
justifies 2text* within a field 2mincol* wide.  2text* may
be divided up into segments with 3~;*--the spacing is evenly
divided between the text segments.  With no modifiers, the leftmost
text segment is left justified in the field, and the rightmost text
segment right justified;  if there is only one, as a special case, it
is right justified.  The colon modifier causes spacing to be
introduced before the first text segment;  the atsign modifier causes
spacing to be added after the last.  2minpad*, default 30*, is
the minimum number of 2padchar* (default space) padding characters
to be output between each segment.  If the total width needed to
satisfy these constraints is greater than 2mincol*, then
2mincol* is adjusted upwards in 2colinc* increments.
2colinc* defaults to 31*.  For example,
.lisp
(format nil "~10<foo~;bar~>")    =>  "foo    bar"
(format nil "~10:<foo~;bar~>")   =>  "  foo  bar"
(format nil "~10:@<foo~;bar~>")  =>  "  foo bar "
(format nil "~10<foobar~>")      =>  "    foobar"
(format nil "~10:@<foobar~>")    =>  "  foobar  "
(format nil "$~10,,,'*<~3f~>" 2.59023)  =>  "$******2.59"
.end_lisp

If 3~^* is used within a 3~<* construct, then only the clauses
which were completely processed are used.  For example,
.lisp
(format nil "~15<~S~;~^~S~;~^~S~>" 'foo)
	=>  "            FOO"
(format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar)
	=>  "FOO         BAR"
(format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz)
	=>  "FOO   BAR   BAZ"
.end_lisp

If the first clause of a 3~<* is terminated with 3~:;* instead of
3~;*, then it is used in a special way.  All of the clauses are
processed (subject to 3~^*, of course), but the first one is omitted
in performing the spacing and padding.  When the padded result has
been determined, then if it will fit on the current line of output, it
is output, and the text for the first clause is discarded.  If,
however, the padded text will not fit on the current line, then the
text for the first clause is output before the padded text.  The first
clause ought to contain a carriage return.  The first clause is always
processed, and so any arguments it refers to will be used; the
decision is whether to use the resulting piece of text, not whether to
process the first clause.  If the 3~:;* has a numeric parameter
2n*, then the padded text must fit on the current line with 2n*
character positions to spare to avoid outputting the first clause's
text.  For example, the control string
.lisp
"~%;; ~{~<~%;; ~1:; ~S~>~^,~}.~%"
.end_lisp
can be used to print a list of items separated by commas, without
breaking items over line boundaries, and beginning each line with
"3;; *".  The argument 1 in 3~1:;* accounts for the width of the
comma which will follow the justified item if it is not the last
element in the list, or the period if it is.  If 3~:;* has a second
numeric parameter, then it is used as the width of the line,
thus overriding the natural line width of the output stream.  To make
the preceding example use a line width of 50, one would write
.lisp
"~%;; ~{~<~%;; ~1,50:; ~S~>~^,~}.~%"
.end_lisp

Note that the segments 3~<* breaks the output up into are computed
"out of context" (that is, they are first recursively 3format*ted
into strings).  Thus, it is not a good idea for any of the segments to
contain relative-positioning commands (such as 3~T* and 3~&*),
or any line breaks.  If 3~:;* is used to produce a prefix string,
it also should not use relative-positioning commands.
}

{(divert-documentation-to chart)
.item ~<
Spaces multiple text segments in a field.
}


;;;; ~{ ... ~} - iterate


(define-private-variable *format-iteration-hack)

(define-private-variable *format-iteration-args)


(define-autoload-op /{ (params . arglist) brack	; matching "}"

    (bindq (fixnum starting-position) *format-string-index
	   (fixnum ending-position) 0
	   (fixnum count) (or (car params) 259259.)
	   /: colon-flag /@ atsign-flag
	   *format-iteration-hack ())

    (setq *format-iteration-hack (if (format-skip-bracket '(/{ . /}))
				     (pop arglist)
				     starting-position)
	  ending-position *format-string-index)

    (cond ((not (null /:))
	     (if (not (null /@))
		 (setq arglist (format-multiple-iterations arglist count))
		 (format-multiple-iterations (pop arglist) count)))
	  ((not (null /@))
	     (setq *format-args arglist)
	     (format-many-iterations count)
	     (setq arglist *format-args))
	  ('t (let ((*format-args (car arglist))
		    (*format-original-args (car arglist)))
		 (format-many-iterations count)
		 (setq arglist (cdr arglist)))))
    (setq *format-string-index ending-position)
    arglist)



(define-hidden-hack (format-multiple-iterations arglist (fixnum count)) brack
    (bindq *format-iteration-args (or arglist (and colon-flag '(())))
	   *format-original-args ()
	   *format-args ())
    (format-catch format-/:/^-tag
	(loop repeat count
	      while *format-iteration-args
	      do (setq *format-original-args
		       (setq *format-args (car *format-iteration-args))
		       *format-iteration-args (cdr *format-iteration-args))
		 (format-catch format-/^-tag (format-one-iteration))))
    *format-iteration-args)


(define-hidden-hack (format-many-iterations (fixnum count)) brack
    (and (null *format-args) (not colon-flag) (setq count 0))
    (format-catch (format-/:/^-tag format-/^-tag)
       (loop with *format-iteration-args 
	     repeat count
	     do (format-one-iteration)
	     while *format-args)))


(define-hidden-hack (format-one-iteration) brack

    (if (fixp *format-iteration-hack)
	(loop with (op params)
	        and *format-string-index = *format-iteration-hack
	      unless (format-process-text)
		do (format-err "Unbalanced braces")
	      do (setq params (format-collect-params) op (format-read-op))
	      ; Matching "{"
	      when (eq op '/}) return ()
	      do (format-call-op op (format-get-list-buffer-pointer params))
		 (format-reclaim-list-buffer params))
	(format-interpret-arg *format-iteration-hack)))



{(divert-documentation-to chart)
.item ~{
'c Matching }
Repeatedly formats a string - one arg, things to iterate over
.item ~:{
'c Matching }
One arg - a list of lists to iterate over
.item ~@{
'c Matching }
Iterates over remaining arguments
.item ~:@{
'c Matching "}"
Iterates over each of the remaining args, which are lists
}


{(divert-documentation-to ops)
.item ~{2str*~}
.c The merging of the italic "r" and bold "~" loses on XGP, so a ^T is used.
This is an iteration construct.  The argument should be a list,
which is used as a set of arguments as if for a recursive call to
3format*.  The string 2str* is used repeatedly as the control
string.  Each iteration can absorb as many elements of the list as it
likes.  If before any iteration step the list is empty, then the
iteration is terminated.  Also, if a numeric parameter 2n* is
given, then there will be at most 2n* repetitions of processing of
2str*.

3~:{2str*~}* is similar, but the argument should be a list
of sublists.  At each repetition step one sublist is used as the set
of arguments for processing 2str*; on the next repetition a new
sublist is used, whether or not all of the last sublist had been
processed.

3~@{2str*~}* is similar to 3~{2str*~}*, but
instead of using one argument which is a list, all the remaining
arguments are used as the list of arguments for the iteration.

3~:@{2str*~}* combines the features of
3~:{2str*~}* and 3~@{2str*~}*.  All the
remaining arguments are used, and each one must be a list.  On each
iteration one argument is used as a list of arguments.

Terminating the repetition construct with
'c Matching {
3~:}*
instead of
'c Matching {
3~}*
forces 2str* to be processed at least once even if the initial
list of arguments is null (however, it will not override an explicit
numeric parameter of zero).

If 2str* is null, then an argument is used as 2str*.  It must be
a string, and precedes any arguments processed by the iteration.  As
an example, the following are equivalent:
.lisp
(apply (function format) (list* stream string args))
(format stream "~1{~:}" string args)
.end_lisp
This will use 3string* as a formatting string.  The 3~1{* says
it will be processed at most once, and the 3~:}* says it will be
processed at least once.  Therefore it is processed exactly once,
using 3args* as the arguments.
.c Matching {
.item ~}
Terminates a 3~{*.  It is undefined elsewhere.
.c Matching }
}


;;;; ~^ - (conditional) non-local exit


(define-format-op /^ (params . arglist)
    (and (if (car params)
	     (if (cadr params)
		 (if (caddr params)
		     (and (not (> (car params) (cadr params)))
			  (not (> (caddr params) (cadr params))))
		     (= (car params) (cadr params)))
		 (zerop (car params)))
	     (if format:colon-flag
		 (null *format-iteration-args)
		 (null arglist)))
	 {(except-for Multics)
	    (*throw (if format:colon-flag 'format-/:/^-tag 'format-/^-tag)
	      ())}
	 {(only-for Multics)
	    (if format:colon-flag
		(throw nil format-/:/^-tag)
		(throw nil format-/^-tag))})
    arglist)

{(divert-documentation-to ops)
.item ~^
'c     I quote, from the Lispm manual:
This is an escape construct.  If there are no more arguments remaining
to be processed, then the immediately enclosing 3~{*
'c matching "}"
or 3~<* construct is terminated.  (In the latter case, the 3~<*
formatting 2is* performed, but no more clauses are processed before
doing the justification.  The 3~^* should appear only at the
2beginning* of a 3~<* clause, because it aborts the entire
clause.  It may appear anywhere in a 3~{*
'c Matching "}"
construct.)  If there is no such enclosing construct, then the entire
formatting operation is terminated.

If a numeric parameter is given, then termination occurs if the parameter
is zero.  (Hence 3~^* is the same as 3~#^*.)  If two parameters are
given, termination occurs if they are equal.  If three are given, termination
occurs if the second is between the other two in ascending order.

If 3~^* is used within a 3~:{*
'c Matching "}"
construct, then it merely terminates
the current iteration step (because in the standard case it tests for
remaining arguments of the current step only); the next iteration step
commences immediately.  To terminate the entire iteration process,
use 3~:^*.
}

{(divert-documentation-to chart)
.item ~^
Terminate ~{ or 3format* if no args left
'c Matching }
}


;;;; Floating-point format stuff

(define-private-xmacro (define-floormat-maxmin
			   name type generic-fn specific-fn comparison-fn
			   (optional NIL-comparison-fn comparison-fn))
    type generic-fn specific-fn comparison-fn ; inhibit unused warnings
    `(define-private-open-codable-routine (,name (,type a) (,type b))
	(dcls (needed-for interpretation macros)
	      (value-type ,type)
	      ; Sorry, not yet supported well:
	      {(except-for Multics) (do-argument-type-checking)}
	      (do-argument-number-checking))
	{(only-for Maclisp)
	   (cond ((,comparison-fn a b) a) (t b))
	   }
	{(except-for Maclisp)
	   {(only-for NIL)
	      ;NIL is supposed to have the type-specific versions, but doesn't.
	      `(cond ((,NIL-specific-fn a b) a) (#t b))
	      }
	   {(except-for NIL)
	      (dcls (use-sublis-for-open-coding))
	      {(only-for Lispm)
		 (,generic-fn ,a ,b)
		 }
	      {(except-for Lispm)
		 (,specific-fn ,a ,b)
		 }
	      }
	   }
	)
  )


(define-floormat-maxmin floormat-max& fixnum max max& >)

(define-floormat-maxmin floormat-min& fixnum min min& <)

(define-floormat-maxmin floormat-max$ flonum max max$ > >$)

(define-floormat-maxmin floormat-min$ flonum min min$ < <$)


(define-system-xstructure (floormat
			     conc-name
			     {Maclisp tree ; don't make hunks!
				      }
			     default-pointer)
    mant expt sigdig tsigdig)


(define-system-hack (floormat-haulong (fixnum n)) float
    (dcls (value-type fixnum))
    (setq n (abs n))
    (bindq (fixnum count) 1) ; PDP10 complr bug
    (loop until (< n 10.) do (setq n (// n 10.) count (1+ count)))
    count)



(define-hidden-hack (floormat-resize
		       floormat (fixnum digits-wanted)
		       dont-move-decimal-point-offset?)
		     float
    (dcls (returnable))
    (bindq (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig)
	   (fixnum msign) 1)
    (and (= sigdig digits-wanted) (return floormat))
    (and (minusp mant) (setq mant (- mant) msign -1))
    (bindq (fixnum dif) (- digits-wanted sigdig))
    (if (plusp dif)
	(setq mant (* mant (^ 10. dif)) expt (- expt dif))
	(lbind* (((fixnum factor) (^ 10. (setq dif (- dif))))
		 ((fixnum r) (\ mant factor))
		 ((fixnum half) (// factor 2)))
	  (setq mant (// mant factor) expt (+ expt dif))
	  (cond ((or (> r half) (and (= r half) (oddp mant)))
		   {-- hmmm, does rounding want to do the same thing
		       if the mantissa is negative?}
		   (setq mant (1+ mant))
		   (cond ((not (= (floormat-haulong mant) digits-wanted))
			    ;changed number of digits rounding mantissa.
			    (if dont-move-decimal-point-offset?
				(setq digits-wanted (1+ digits-wanted))
				(setq mant (// mant 10.) expt (1+ expt)))))))))
    ;Note with zero we will return a "non-normalized" result.  The caller is
    ; going to have to handle zero specially himself, as in generally things
    ; will be quite messed up with it (partly because its "haulong" is 1).
    (setf (floormat-mant) (* mant msign))
    (setf (floormat-expt) expt)
    (setf (floormat-sigdig) digits-wanted)
    floormat)



;;;; Hack with numerical limitations


(define-private-xmacro (floormat-max-expt&)
    ''#.(loop for i from 5 when (bigp (expt 10. i)) return (1- i)))


(define-private-xmacro (floormat-flonum-digits-guess)
    ''#.(loop for i from 1
	      as test = (float (expt 10. i))
	      when (= test (1+$ test)) return i))


(define-private-xmacro (floormat-testable-rangep positive-flonum)
    (auxs ((flonum centered-flonum)
	     (float (^ 10. (floormat-flonum-digits-guess))))
	  ((flonum range-guess)
	     (float (^ 10. (1- (floormat-max-expt&))))))
    `(lessp ,(//$ centered-flonum range-guess)
	    ,positive-flonum
	    ,(*$ centered-flonum range-guess)))


(define-private-xmacro (floormat-zero-tsigdig)
    '(floormat-flonum-digits-guess))


(define-private-xmacro (floormat-max-expt$)
    ; Presumes float will give arithmetic overflow error which errset
    ; will trap.
    ''#.((lambda (size dummy)
	   (errset (loop for i from 15.
			 do (setq dummy (float (expt 10. i)) size i))
		   nil)
	   size)
	 0 ()))


;;;; Dissect a flonum

(define-hidden-hack (floormat-dissect original-x) float

    (dcls (returnable))

    (bindq (flonum original-x$) (float original-x))
    (bindq (flonum x) original-x$
	   (fixnum mantissa) 0
	   (fixnum expt) 0
	   (fixnum sigdig) 0
	   (fixnum tsigdig) 0
	   (fixnum msign) 1)

    {-- Once upon a time, some of this code came from LMIO;PRINT.}

    {-- What this code does is essentially to multiply or divide the
	flonum until we get it into a range such that doing a FIX on it
	will return a fixnum containing all the significant digits.
	There is various crockery having to do with keeping things
	in fixnum range, at least for the Maclisp implementation.
	We do this, returning that as the mantissa, the exponent being
	the number of multiplications or divisions we did.  The returned
	things are such that (*$ (float mantissa) (^$ 10.0 expt)) should
	equal (in theory) the original number.  The sigdig is the number
	of digits in the mantissa.  tsigdig is the number of "true"
	sigdig in the number, that is, the number of digit positions such
	that a single-digit change in the last position makes no numerical
	difference in the floating-point representation.
	None of this will work if flonums have more significant decimal
	digits than can be put into a fixnum, unless much if not all of
	the arithmetic here is generic;  in that case it will fixnum-cons
	its balls off.
	}

    (cond ((zerop x)
	     (return (make-floormat
		        mant 0 expt 0 sigdig 1
			tsigdig (floormat-flonum-digits-guess))))
	  ((minusp x)
	     (setq msign -1 x (-$ x))))

    (cond ((not (floormat-testable-rangep x))
	     ; Is the number in a range we can hack?  If not, we must
	     ; adjust it.
	     (setq expt (- (fix (//$ (log x) #.(log 10.0)))
			   (floormat-flonum-digits-guess)))
	     (setq x (cond ((not (> (abs expt) (floormat-max-expt&)))
			      (if (minusp expt)
				  (*$ x (float (^ 10. (- expt))))
				  (//$ x (float (^ 10. expt)))))
			   ((zerop expt) (break barf))
			   ((plusp expt) (//$ x (float (expt 10. expt))))
			   ((plusp (+ (floormat-max-expt$) expt))
			      (*$ x (float (expt 10. (- expt)))))
			   ('t (*$ x
				   #.(float (expt 10. (floormat-max-expt$)))
				   (float (expt 10. (- (+ (floormat-max-expt$)
							  expt))))))))))
    (if (= x (1+$ x))
	(loop as div fixnum = 10. then (* div 10.)
	      as y flonum = (//$ x (float div))
	      when (not (= y (1+$ y)))
		; Back off one
		do (or (= div 10.) (setq x (//$ x (float (// div 10.)))))
		and return ()
	      do (setq expt (1+ expt)))
	; Iterate until the digit just to the left of the decimal point
	; becomes insignificant.
	(loop as pwr fixnum = 10. then (* pwr 10.)
	      as y flonum = (*$ x (float pwr))
	      do (setq expt (1- expt))
	      when (= y (1+$ y)) do (setq x y) and return ()))
    (setq mantissa (// (+ (fix x) 5) 10.) expt (1+ expt))
    (setq tsigdig (setq sigdig (floormat-haulong mantissa)))
    (loop while (zerop (\ mantissa 10.))
	  do (setq mantissa (// mantissa 10.)
		   expt (1+ expt)
		   sigdig (1- sigdig)))
    (make-floormat mant (* mantissa msign)
		   expt expt
		   sigdig sigdig
		   tsigdig tsigdig))


;;;; Random output frobs


(define-hidden-hack (floormat-fixnum-quickly (fixnum n)) float
    (and (> n 9.) (floormat-fixnum-quickly (// n 10.)))
    (format-tyo-digit (\ n 10.)))


(define-private-xmacro (floormat-tyo-E)
    '(format-tyo {(only-for Multics) #/e} {(except-for Multics) #/E}))


(define-hidden-hack (floormat-fixnum
		       (fixnum n) (fixnum digits) truncate-trailing-zeros?)
		    float
    (loop as factor fixnum = (^ 10. digits) then next-factor
	  as next-factor fixnum = (// factor 10.)
	  as firstp = 't then ()
	  when truncate-trailing-zeros?
	    unless firstp
	      when (zerop (\ n factor))
	        return ()
	  while (plusp next-factor)
	  do (format-tyo-digit (\ (// n next-factor) 10.))))


;;;; ~F - "free" format

(define-autoload-op F (params arg) float

    (if (and (null params) (not colon-flag))
	(format-princ (float arg))
	(let ((floormat (floormat-dissect arg)))
	  (and (car params)
	       (floormat-resize
		  floormat
		  (floormat-min& (car params) (floormat-tsigdig))
		  ()))
	  (format-justify
	     'left (caddr params) () () (cadddr (cdr params))
	     'floormat-F floormat (cadr params) (cadddr params)
	     (lbind (((fixnum mant) (floormat-mant)))
	       (cond ((minusp mant) (setf (floormat-mant) (- mant)) #/-)
		     (atsign-flag #/+)))
	     colon-flag))))


(define-hidden-hack (floormat-F floormat dpos? lpad? signp show-significancep)
		    float
    (dcls (returnable))
    (bindq (character-code lpad) (if lpad? (format-character lpad?) #\sp)
	   (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig))
    (bindq (fixnum dpos) (if (null dpos?) 1
			     (floormat-min& (floormat-max& dpos? 1)
					    (1- sigdig))))
    (bindq (fixnum ldig) (+ sigdig expt) (fixnum rdig) (- expt))
    (if (zerop mant)
      ;Zero always fits.
      (setq ldig dpos rdig (if show-significancep (- sigdig dpos) 1)))
    (cond ((or (and dpos? (> ldig dpos)) ; can't fit it in the field!
	       (< (- ldig dpos) -2)
	       (not (< ldig sigdig)))
	     (return (floormat-FE floormat dpos lpad
				  signp show-significancep))))
    (format-repeat-char lpad (- (floormat-min& (- dpos ldig) (1- dpos))
				(if signp 1 0)))
    (and signp (format-tyo signp))
    (cond ((plusp ldig)
	     (floormat-fixnum
	        (// mant (^ 10. (floormat-max& rdig 0)))
		(floormat-min& ldig sigdig)
		())
	     (and (> ldig sigdig) (format-repeat-char #/0 (- ldig sigdig))))
	  ('t (format-tyo #/0)))
    (format-tyo #/.)
    (cond ((minusp rdig) (format-tyo #/0))
	  ('t (format-repeat-char #/0 (- rdig sigdig))
	      (floormat-fixnum
	         mant (floormat-min& rdig sigdig) (not show-significancep)))))


(define-hidden-hack (floormat-FE
		       floormat (fixnum dpos) (fixnum lpad)
		       signp show-significancep)
		    float
    (bindq (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig))
    (cond (signp
	     (format-tyo signp)
	     (and (> dpos 1) (setq dpos (1- dpos)))))
    (bindq (fixnum d) (- sigdig dpos))
    (bindq (fixnum factor) (^ 10. d))
    (floormat-fixnum (// mant factor) dpos ())
    (format-tyo #/.)
    (floormat-fixnum (\ mant factor) d (not show-significancep))
    (floormat-tyo-E)
    (format-tyo (cond ((minusp (setq expt (+ expt d)))
		         (setq expt (- expt)) #/-)
		      ('t #/+)))
    (floormat-fixnum-quickly expt))


{(divert-documentation-to ops)
.item ~F
outputs 2arg* in free-format floating-point.  3~2n*F*
outputs 2arg* showing at most 2n* digits.  3~2n*:F*
will show exactly 2n* digits.  No other variations are guaranteed
at this time;  neither is the 2exact* interpretation of 2n*.
It is reasonable to use this, however, when one desires to print a
flonum without showing lots of insignificant trailing digits;  for
example,
.lisp
(format nil "~6f" 259.258995) => "259.259"
.end_lisp
}


;;;; ~E - exponential format

(define-autoload-op E (params arg) float
    ; sigdig, ldig, dpos, exptdig, exptmodulus, padchar
    (bindq floormat (floormat-dissect arg))
    (and (car params) (floormat-resize floormat (car params) ()))
    (bindq (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig))
    (bindq (fixnum ldig) (or (car (setq params (cdr params))) 1)
	   (fixnum dpos) (or (car (setq params (cdr params))) 1)
	   (fixnum exptdig) (or (car (setq params (cdr params))) 1)
	   (fixnum exptmodulus) (or (car (setq params (cdr params))) 1)
	   padchar (or (car (setq params (cdr params))) #/0)
	   signp (cond ((minusp mant) (setq mant (- mant)) #/-)
		       (atsign-flag #/+)))
    (bindq (fixnum realldig)
	   (+ (\ (+ (\ (+ expt (- sigdig ldig)) exptmodulus) exptmodulus)
		 exptmodulus)
	      ldig))
    (bindq (fixnum realrdig) (- sigdig realldig))
    (bindq (fixnum realexpt) (+ expt realrdig))
    (cond ((not (null signp))
	     (setq dpos (1- dpos))
	     (cond (colon-flag (format-tyo signp) (setq signp ())))))
    (format-repeat-char padchar (- dpos realldig))
    (and signp (format-tyo signp))
    (bindq factor (^ 10. realrdig))
    (floormat-fixnum-quickly (// mant factor))
    (format-tyo #/.)
    (floormat-fixnum mant realrdig ())
    (floormat-tyo-E)
    (format-tyo (cond ((minusp realexpt) (setq realexpt (- realexpt)) #/-)
		      ('t #/+)))
    (format-repeat-char #/0 (- exptdig (floormat-haulong realexpt)))
    (floormat-fixnum-quickly realexpt)
    )

{(divert-documentation-to ops)
.item ~E
Outputs 2arg* in exponential notation;  e.g., 3"2.59259e+2"*.
3~2n*E* interprets 2n* the same as 3~F*.  No other
parameters or flags are guaranteed at this time.
}


;;;; ~$ - fixed decimal field

(define-autoload-op /$ (params arg) float
    (bindq (flonum newarg) (float arg) signp ())
    (cond (colon-flag
	     (cond ((minusp newarg)
		      (setq newarg (-$ newarg)) (format-tyo #/-))
		   (atsign-flag (format-tyo #/+))))
	  ((or atsign-flag (minusp newarg)) (setq signp 't)))
    (format-justify
       'right (caddr params) () () (cadddr params) #'floormat-money
       newarg (or (car params) 2) (or (cadr params) 1) signp))


(define-hidden-hack (floormat-money
		       arg (fixnum rdigits) (fixnum ldigits) signp)
		    float
    (bindq floormat (floormat-dissect arg))
    (cond ((< rdigits (- (floormat-expt)))
	     ; Truncate if necessary.
	     (lbind (((fixnum new)
		      (+ (floormat-sigdig) (floormat-expt) rdigits)))
	       (if (minusp new)
		   (setq floormat (floormat-dissect 0.0))
		   (floormat-resize floormat new 't)))))
    (bindq (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig))
    (bindq (fixnum real-ldig) (+ sigdig expt) (fixnum real-rdig) (- expt))
    (cond ((minusp mant) (setq mant (- mant)) (and signp (format-tyo #/-)))
	  (signp (format-tyo #/+)))
    (and (> ldigits real-ldig)
	 (format-repeat-char
	    #/0 (if (plusp real-ldig) (- ldigits real-ldig) ldigits)))
    (cond ((> real-ldig sigdig)
	     (floormat-fixnum mant sigdig ())
	     (format-repeat-char #/0 (- real-ldig sigdig)))
	  ('t (floormat-fixnum (// mant (^ 10. real-rdig)) real-ldig ())))
    (format-tyo #/.)
    (cond ((plusp real-rdig)
	     (cond ((> real-rdig sigdig)
		      (format-repeat-char #/0 (- real-rdig sigdig))
		      (floormat-fixnum mant sigdig ()))
		   ('t (floormat-fixnum mant real-rdig ())
		       (format-repeat-char #/0 (- rdigits real-rdig)))))
	  ('t (format-repeat-char #/0 rdigits)))
    ())

{(divert-documentation-to ops)
.item ~$
3~2rdig*,2ldig*,2field*,2padchar*$* prints
2arg*, a flonum, with exactly 2rdig* digits after the decimal
point.  The default for 2rdig* is 2, which is convenient for
printing amounts of money.  At least 2ldig* digits will be printed
preceding the decimal point; leading zeros will be printed if there would
be fewer than 2ldig*.  The default for 2ldig* is 1.  The number is
right justified in a field 2field*
columns long, padded out with 2padchar*.  The colon modifier means
that the sign character is to be at the beginning of the field, before
the padding, rather than just to the left of the number.  The atsign modifier
says that the sign character should always be output.

In some implementations, if 2arg* is unreasonably large, it will
be printed in 3~2field*,,,2padchar*@A* format; i.e. it
will be 3princ*'ed right-justified in the specified field width.
This will not happen in the Maclisp implementation, because the range
provided by flonums is not extremely large.
}


;;;; FERROR (Multix)

{(only-for Multics)

(declare (special args))

(define-public-routine (ferror condition-name format-string
			       (any-number-of format-args))
    (and (or (not condition-name)
	     (not (apply 'signal (list* condition-name nil nil '?
					format-string format-args))))
	 ((lambda (args)
	      (error (format-internal 'string format-string format-args)))
	  (list* 'ferror condition-name format-string format-args))))
}

;;;; Patch documentation files

{(divert-documentation-to ops)
.c Throw this in here for good measure
.item ~\
This is not really an operator.  If one desires to use a
multi-character 3format* operator, it may be placed within
backslashes, as in 3~\now\* for the 3now* operator.  See
(multi-character-operator-page).
.end_table
}

{(divert-documentation-to chart)
.item ~\2name*\
Call multi-character operator 2name*.
.end_table
}

(sstatus feature format)




		    lisp_gfile_.lisp                10/05/83  1315.9r   10/05/83  1240.2      174897



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************

;;;   ***********************************************************************
;;;   ***** Maclisp ****** S-expression formatter for files (grind) *********
;;;   ***********************************************************************
;;;   ** (c) Copyright 1974 Massachusetts Institute of Technology ***********
;;;   ****** this is a read-only file! (all writes reserved) ****************
;;;   ***********************************************************************

;;;This version of Grind works in both ITS Maclisp and Multics Maclisp
;;; copied from (mc gfile 384).

;;;gfile - fns for pretty-printing and grinding files
;;;about 700. instructions when ncomplr'd


(declare (array* (notype (gtab/| 128.)))
         (noargs t)
         (special merge readtable grindreadtable remsemi ~r
                  grindpredict grindproperties grindef predict
                  grindfn grindmacro programspace topwidth
                  grindlinct global-lincnt /; /;/; user-paging form prog? n m l h
                  arg linel pagewidth gap comspace fill nomerge comnt
                  /;/;? ^d macro unbnd-vrbl cnvrgrindflag)
         (*expr form topwidth programspace pagewidth comspace
                nomerge remsemi grchrct indent-to page panmax sprint1
	      turpri)
         (*fexpr trace slashify unslashify grindfn grindmacro
                 unreadmacro readmacro grindef)
         (*lexpr merge predict user-paging fill testl)
         (mapex t)
         (genprefix gr+)
         (fixnum nn
                 mm
                 (grchrct) (newlinel fixnum)
                 (prog-predict notype fixnum fixnum)
                 (block-predict notype fixnum fixnum)
                 (setq-predict notype fixnum fixnum)
                 (panmax notype fixnum fixnum)
                 (maxpan notype fixnum)
                 (gflatsize)))

(defun macex macro (x) (list 'defun (cadr x) 'macro (caddr x) (eval (cadddr x))))

(defun ifoio macro (x) 
       (cond ((not (status feature newio)) (cadr x)) ('(comment ifoio not taken))))

(defun ifnio macro (x)
       (cond ((status feature newio) (cadr x)) ('(comment ifnio not taken))))

(macex newlineseq (x)
    (cond ((status feature Multics)
	 ''(list (ascii 12)))
	(t ''(list (ascii 15)(ascii 12)))))

(macex version (x) 
        (subst (maknam 
                  (nconc (newlineseq)
                         (explodec '/;loading/ grind/ )
                         (explodec (cond ((status feature newio) (caddr (names infile)))
                                         ((cadr (status uread)))))
		     (newlineseq)))
                 'version 
                 ''(iog nil (princ 'version) (ascii 0))))

(ifnio (defun newlinel macro (x) (subst (cadr x) 'nn '(setq linel nn))))
(ifoio (defun grchrct macro (x) 'chrct))
(ifnio (defun macro set-linel (x) '(setq linel (linel (and outfiles (car outfiles))))))
(ifoio (defun macro set-linel (x) '(comment linel)))

(macex prin50com-chrct-fiddle (x) 
       (cond ((status feature newio) ''(comment))
	     (''(setq chrct (- chrct (- pagewidth linel))))))


(version)

;;*user-paging


(prog nil 	;some initializations

(and (not (boundp 'grind-use-original-readtable))       ;grind-use-original-readtable = nil =>
							;use current readtable: 
     (setq grind-use-original-readtable t))		;otherwise use original readtable (default).


(and (or (not (boundp 'grindreadtable)) (null grindreadtable))
     ((lambda (readtable) (setsyntax 12. 'single nil)                  ;^l made noticeable.
                          (sstatus terpri t)                           ;the grindreadtable is tailored for
                          (setsyntax '/;                               ;grind. no cr
                                     'splicing
                                     'semi-comment))                   ;are inserted by lisp when print exceeds
      (setq grindreadtable (*array nil 'readtable grind-use-original-readtable)))) 

(setq macro '/;  /; (copysymbol '/; nil) /;/; (copysymbol '/;/; nil))
(setq grindlinct 8. global-lincnt 59. comnt nil /;/;? nil)
(sstatus feature grind)) 



;;;Multics versions of grind and grind0
(ifnio (defun grind fexpr (file)                ;grinds and files file.
	  ((lambda (x)
	    (cond ((stringp (car file)))        ;already filed.
	          ((apply 'ufile x)))
	    file)
	   (apply 'grind0 file))))

(ifnio (defun grind0 fexpr (file)               ;grinds file and returns file
;	      (or (status feature grindef)
	      (or (get 'sprinter 'subr)	;do it this way for now due to bug? in status feature
                        ;load other part of grind if necessary and prior to any use of grind
                    (load (get 'sprinter 'autoload)))                             ;global variables like programspace.
       (prog (remsemi linel *nopoint readtable base l ^q ^r ^w ^d outfiles
              eof n /;/;? comnt) 
             (setq base 10. linel programspace)
             (setq readtable grindreadtable remsemi t)
             (cond ((stringp (car file))
                    (inpush (openi (car file)))
                    (setq outfiles
                         (list
                          (openo
                           (mergef
                            (cond ((null (cdr file))
                                   (princ '/
Filing/ as/ /!grind/.output/
 nil)
                                   '(* !grind output))
                                  ((cadr file)))
                            (cons (car (names nil)) '*)
                            (names infile))))))
                   (t (apply 'uread file)
                      (uwrite)))

             (setq eof (list nil) n topwidth)
             (setq ^q t ^r t ^w t grindlinct global-lincnt)
        read (and (= (tyipeek 47791616.) 59.)                           ;catch top-level splicing macro
                  (readch)
                  (cond ((eq (car (setq l (car (semi-comment)))) /;)
                         (rem/;)
                         (go read))
                        (t (go read1))))
             (and (null ^q) (setq l eof) (go read1))                    ;catch eof in tyipeek
             (and (eq (car (setq l (read eof))) /;)                    ;store /; strings of /; comments.
                  (rem/;)
                  (go read))
        read1(prinallcmnt)                                             ;print stored /; comments
             (or (eq eof l) (go process))
        exit (terpri)
             (ioc t)
             (and (stringp (car file)) (close (car outfiles)))         ;won't get ufile'd
             (return file)
        process
             (cond ((eq l (ascii 12.))                                 ;formfeed read in ppage mode
                    (or user-paging (go read))                         ;ignore ^l in user-paging mode.
                    (and (equal (tyipeek t) 3.) (go exit))             ;do not formfeed if at eof
                                                                       ;BUG:  can lose semicolon comments
                    (terpri)
                    (page)
                    (setq /;/;? t)
                    (go read))
                   ((eq (car l) /;/;)                                  ;toplevel ;;... comment
                    (newlinel topwidth)
                    (or /;/;? (= linel (grchrct)) (turpri) (turpri))                ;produces  blank line preceding new
                    (rem/;/;)                                          ;block of /;/; comments. (turpri is
                    (newlinel programspace)                            ;already in rem/;/;).  a total of 3
                    (go read)))                                        ;turpri's are necessary if initially
             (fillarray 'gtab/| '(nil))                                    ;chrct is not linel, ie we have just
             (cond (user-paging (turpri) (turpri))                     ;finished a line and have not yet cr.
                   ((< (turpri) (catch (\ (panmax l (grchrct) 0.) 60.)))   ;clear hash array
                    (page))
                   ((turpri)))
             (cond ((sprint1 l linel 0.) (prin1 l)))
             ;;(tyo 32.)                                                ;prevents toplevel atoms from being
             (go read))))                                               ;accidentally merged by being separated
                                                                       ;only by cr.



;;;ITS versions of grind and grind0

(ifoio (defun grind fexpr (file) (apply 'ufile (apply 'grind0 file))))

(ifoio (defun grind0 fexpr (file)
    ((lambda (crunit ~r)                             ;read in remainder of grind package if
       (or (status feature grindef)            ;necessary and prior to any use of grind
           (and (cond ((status feature dec10)        ;global variables like programspace.
                       (fasload gfn fsl sys))     ;read from sys: device on other pdp-10's.
                      (t (fasload gfn fasl com)))  ;read from com: device on ITS.
             (apply 'crunit crunit))))
       (crunit) nil)
       (prog (remsemi linel *nopoint readtable base l ^q ^r ^w ^d outfiles
              eof n /;/;? comnt) 
             (setq base 10. linel programspace)
             (setq readtable grindreadtable remsemi t)
             (apply 'uread file)
             (uwrite)
             (setq eof (list nil) n topwidth)
             (setq ^q t ^r t ^w t grindlinct global-lincnt)
        read (and (= (tyipeek 47791616.) 59.)                           ;catch top-level splicing macro
                  (readch)
                  (cond ((eq (car (setq l (car (semi-comment)))) /;)
                         (rem/;)
                         (go read))
                        (t (go read1))))
             (and (null ^q) (setq l eof) (go read1))                    ;catch eof in tyipeek
             (and (eq (car (setq l (read eof))) /;)                    ;store /; strings of /; comments.
                  (rem/;)
                  (go read))
        read1(prinallcmnt)                                             ;print stored /; comments
             (or (eq eof l) (go process))
        exit (terpri)
             (ioc t)
             (return file)
        process
             (cond ((eq l (ascii 12.))                                 ;formfeed read in ppage mode
                    (or user-paging (go read))                         ;ignore ^l in user-paging mode.
                    (and (equal (tyipeek t) 3.) (go exit))             ;do not formfeed if at eof
                    (terpri)
                    (page)
                    (setq /;/;? t)
                    (go read))
                   ((eq (car l) /;/;)                                  ;toplevel ;;... comment
                    (newlinel topwidth)
                    (or /;/;? (= linel (grchrct)) (turpri) (turpri))                ;produces  blank line preceding new
                    (rem/;/;)                                          ;block of /;/; comments. (turpri is
                    (newlinel programspace)                            ;already in rem/;/;).  a total of 3
                    (go read)))                                        ;turpri's are necessary if initially
             (fillarray 'gtab/| '(nil))                                    ;chrct is not linel, ie we have just
             (cond (user-paging (turpri) (turpri))                     ;finished a line and have not yet cr.
                   ((< (turpri) (catch (\ (panmax l (grchrct) 0.) 60.)))   ;clear hash array
                    (page))
                   ((turpri)))
             (cond ((sprint1 l linel 0.) (prin1 l)))
             (tyo 32.)                                                ;prevents toplevel atoms from being
             (go read))))                                               ;accidentally merged by being separated
                                                                       ;only by cr.

;;prediction

(putprop /; 0. 'grindpredict) 

(putprop /;/; 1. 'grindpredict) 


;;semi-colon comments

(defun rem/; nil 
       (prog (c retval) 
        a    (cond ((atom l) (return retval))
                   ((eq (car l) /;)
                    (setq c (cdr l))
                    (setq retval 'car)
                    (setq l nil))
                   ((and (null (atom (car l))) (eq (caar l) /;))
                    (setq c (cdar l))
                    (setq retval 'caar)
                    (setq l (cdr l)))
                   (t (cond ((and (eq retval 'caar)                    ;look ahead to separate comments.
                                  (cdr l)
                                  (null (atom (cdr l)))
                                  (null (atom (cadr l)))
                                  (eq (caadr l) /;))
                             (prinallcmnt)
                             (indent-to n)))
                      (return retval)))
        b    (cond ((null comnt) (setq comnt c))
                   ((< comspace (length comnt)) (turpri) (go b))
                   ((nconc comnt (cons '/  c))))
             (go a))) 


(defun rem/;/; nil 
       (prog (c retval) 
        a    (cond ((atom l)
                    (and (eq retval 'caar) (indent-to n))
                    (return retval))
                   ((eq (car l) /;/;)
                    (setq c (cdr l))
                    (setq retval 'car)
                    (setq l nil))
                   ((and (null (atom (car l))) (eq (caar l) /;/;))
                    (setq c (cdar l))
                    (setq retval 'caar)
                    (setq l (cdr l)))
                   (t (and (eq retval 'caar) (indent-to n))            ;restore indentation for upcoming code
                      (return retval)))
             (prinallcmnt)
             (and (null /;/;?) (turpri))
             (prog (comnt pagewidth comspace macro) 
                   (setq comnt c)
                   (and (or (memq (car c) '(/; *))
                            (null merge))                              ;nomerge.  update pagewidth, comspace
                        (setq /;/;? '/;/;/;)                           ;appropriate for a total line of
                        (setq pagewidth topwidth                       ;topwidth
                              comspace (+ n (- topwidth linel)))
                        (go prinall))
                   (setq pagewidth linel)
                   (cond ((eq /;/;? /;/;)                              ;preceding comnt.  merge.
                          (setq comnt (cons '/  comnt))
                          (setq macro (ascii 0.))
                          (setq comspace (grchrct))
                          (prin50com))
                         ((setq /;/;? /;/;)))
                   (setq comspace n)
              prinall
                   (setq macro /;/;)
                   (prinallcmnt))
             (tj6 c)
             (go a))) 

(defun tj6 (x)                                                         ;tj6 commands: ;;*--- or ;;*(...) (...)
       (and
        (eq (car x) '*)
        (setq x (cdr x))
        (turpri)
        (cond
         ((errset
           (cond ((atom (car (setq x
                                   (readlist (cons '/(
                                                   (nconc x
                                                          '(/))))))))
                  (eval x))
                 ((mapc 'eval x)))))
         ((error '/;/;*/ error x 11.))))) 



(defun prin50com nil                                                   ;prints one line of ; comment
       (do ((next) (linel linel)) ()              ;prog binding linel to linel instead of nil.
             (newlinel pagewidth)
             (prog (comnt) (indent-to comspace))
             (princ macro)
        pl   (cond ((null comnt) (return nil))
                   ((eq (car comnt) '/ )
                    (setq comnt (cdr comnt))
                    (setq next                                         ;number of characters till next space.
                          (do ((x comnt (cdr x)) (num 2. (1+ num)))
                              ((or (null x) (eq (car x) '/ ))
                               num)))
                    (cond ((and (or (eq macro /;) (eq /;/;? /;/;))
                                fill
                                (= next 2.)
                                (go pl)))
                          ((and (not (eq macro (ascii 0.)))
                                (> next comspace)))
                          ((< (grchrct) next)
                           (return nil)))
                    (tyo 32.)
                    (go pl))
                   ((> (grchrct) 0.)
                    (princ (car comnt))
                    (and (or (eq macro /;) (eq /;/;? /;/;))
                         fill
                         (eq (car comnt) '/.)
                         (eq (cadr comnt) '/ )
                         (tyo 32.)))
                   (t (return nil)))
             (setq comnt (cdr comnt))
             (go pl))
       (prin50com-chrct-fiddle)                   ;may restore chrct to be negative
          )

(defun prinallcmnt nil (cond (comnt (prin50com) (prinallcmnt))))       ;prints \ of ; comment

(defun semi-comment nil                                                ;converts ; and ;; comments to exploded
       (prog (com last char)                                           ;lists
             (setq com (cons /; nil) last com)
             (setq char (readch))                                      ;decide type of semi comment
             (cond ((eq char '/
) (return (list com)))
		   ((eq char '/;) (rplaca last /;/;))
                   ((rplacd last (cons char nil))
                    (setq last (cdr last))))
        a    (setq char (readch))
             (cond ((eq char '/
) (return (list com)))
		   ((rplacd last (cons char nil))
                    (setq last (cdr last))
                    (go a))))) 

;;conniver macros

(defun grindcolmac nil (list ': (read))) 

(defun grindcommac nil (list '/, (read))) 

(defun grindatmac nil (cons '@ (read))) 

(defun grindexmac nil 
       (prog (c f) 
             (setq c (grindnxtchr))
             (cond ((setq f (assq c '((/" !/") (@ !@) ($ !$))))
                    (tyi)
                    (return (cons (cadr f) (read))))
                   ((setq f (assq c
                                  '((? !?) (/' !/') (> !>) (/, !/,)
                                    (< !<) (/; !/;))))
                    (tyi)
                    (setq f (cadr f)))
                   (t (ioc v)
                      (print (list 'bad
                                   '!
                                   'macro
                                   c))
                      (ioc g)))
             (return (cond ((grindseparator (grindnxtchr))
                            (list f nil))
                           ((atom (setq c (read))) (list f c))
                           (t (cons f c)))))) 

(defun grindnxtchr nil (ascii (tyipeek))) 

(defun grindseparator (char) (memq char '(/  /   /)))) 




		    lisp_gfn_.lisp                  10/05/83  1315.9r   10/05/83  1240.2      424314



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************

;;;   **************************************************************
;;;   ***** Maclisp ****** S-expression formatter (grindef) ********
;;;   **************************************************************
;;;   ** (c) Copyright 1974 Massachusetts Institute of Technology **
;;;   ****** this is a read-only file! (all writes reserved) *******
;;;   **************************************************************

;;;This version of Grind works in both ITS Maclisp and Multics Maclisp
;;; copied from (mc gfn 386).

;;gfn - fns for pretty-printing functions and S-expressions in core.
;;when compiled, uses about  2300.instructions,  950. list cells, 
;;    320. fixnum cells, and 160. symbols.  remgrind applied therein 
;;    will reclaim about 300. list cells, the array space of 
;;    grindreadtble and gtab/|, and very little else.

(declare (array* (notype (gtab/| 128.)))
         (noargs t)
         (special merge readtable grindreadtable remsemi
                  grindpredict grindproperties grindef predict
                  grindfn grindmacro programspace topwidth
                  grindlinct global-lincnt /; /;/; user-paging 
                  arg linel pagewidth gap comspace fill nomerge comnt
                  /;/;? ^d macro unbnd-vrbl cnvrgrindflag form 
		  prog? n m l h grind-standard-quote sgploses)
         (*expr form topwidth programspace pagewidth comspace
                nomerge remsemi prin50com rem/; rem/;/;)
         (*fexpr trace slashify unslashify grindfn grindmacro
                 unreadmacro readmacro grindef)
         (*lexpr merge predict user-paging fill testl)
         (mapex t)
         (genprefix /|gr)
         (or (get 'maknum 'subr) (defun macro maknum (x) (cons '(lambda (x) (abs (sxhash x))) (cdr x))))	;temporary for Multics
         (fixnum nn mm (prog-predict notype fixnum fixnum)
                 (block-predict notype fixnum fixnum) (setq-predict notype fixnum fixnum)
                 (panmax notype fixnum fixnum) (maxpan notype fixnum) (gflatsize)))

(defun macex macro (x) (list 'defun (cadr x) 'macro (caddr x) (eval (cadddr x))))

(defun ifoio macro (x) 
       (cond ((not (status feature newio)) (cadr x)) ('(comment ifoio not taken))))

(defun ifnio macro (x)
       (cond ((status feature newio) (cadr x)) ('(comment ifnio not taken))))

(macex newlineseq (x)
    (cond ((status feature Multics)
	 ''(list (ascii 12)))
	(t ''(list (ascii 15)(ascii 12)))))

(macex version (x) 
        (subst (maknam 
                  (nconc (newlineseq)
                         (explodec '/;loading/ grindef/ )
                         (explodec (cond ((status feature newio) (caddr (names infile)))
                                         ((cadr (status uread)))))
		     (newlineseq)))
                 'version 
                 ''(iog nil (princ 'version) (ascii 0))))

(ifnio (defun newlinel macro (x) (subst (cadr x) 'nn '(setq linel nn))))

(ifoio (defun newlinel (nn)
              (setq chrct (+ chrct (- nn linel)))
              (setq linel nn)))

(ifoio (defun grchrct macro (x) 'chrct))
(ifnio (defun macro set-linel (x) '(setq linel (linel (and outfiles (car outfiles))))))
(ifoio (defun macro set-linel (x) '(comment linel)))


(version)

;;*user-paging

(prog nil 		;some initializations

(and (not (boundp 'grind-use-original-readtable)) 
     (setq grind-use-original-readtable t))
(and (or (not (boundp 'grindreadtable)) (null grindreadtable))
     ((lambda (readtable) (setsyntax 12. 'single nil)                  ;^l made noticeable.
                          (sstatus terpri t)                           ;the grindreadtable is tailored for
                          (setsyntax '/;                               ;grind. no cr
                                     'splicing
                                     'semi-comment))                   ;are inserted by lisp when
      (setq grindreadtable 
            (*array nil 'readtable grind-use-original-readtable))))    ;print exceeds linel.
(and (not (boundp 'grind-standard-quote))                              ;standard readmacroinveser for quote
     (setq sgploses (setq grind-standard-quote t)))
(setq remsemi nil m 0. grindlinct 8. grindef nil global-lincnt 59.)
(setq grindproperties '(expr fexpr value macro datum cexpr))
(and (status sstatus feature) (sstatus feature grindef))
(array gtab/| t 128.)) 


;;debugging break for grind.

(declare (read) (read))                                                ;gbreak restricted to interpretive
                                                                       ;version.

(defun gbreak fexpr (x) 
       (and gbreak                                                     ;break transparent to chrct
            (prog (chrct* ^r) 
                  (setq chrct* (grchrct))
                  (apply 'break
                         (cond ((null x) '(grind t))
                               ((list x t))))
                  (terpri)
             a    (cond ((eq chrct* (grchrct)))
                        ((princ '/ ) (go a)))
                  (return t)))) 

(setq gbreak t) 



;;rem function - note: to be complete, remgrind should remprop all grindfn, grindmacro and grindpredict
;;properties from any atom on the obarray.
;;*grindfn (expr fexpr lexpr macro value grindpredict) comment-form


(defun remsubr (x) (remprop x 'subr)) 

(defun remfsubr (x) (remprop x 'fsubr)) 

(defun remlsubr (x) (remprop x 'lsubr)) 

(defun remgrind fexpr nil 
       (lispgrind)
       (cond ((status sstatus nofeature) (sstatus nofeature grind) (sstatus nofeature grindef)))
       (cond ((null (get 'conniver 'array))
              (remsubr 'grindexmac)
              (remsubr 'grindatmac)
              (remsubr 'grindcolmac)
              (remsubr 'grindcommac)
              (remsubr 'grindseparator)
              (remsubr 'grindnxtchr)))
       (remfsubr 'grind)
       (remfsubr 'grind0)
       (remfsubr 'grindef)
       (remsubr 'turpri)
       (remlsubr 'fill)
       (remlsubr 'user-paging)
       (remlsubr 'merge)
       (remlsubr 'testl)
       (remlsubr 'predict)
       (remfsubr 'slashify)
       (remfsubr 'unslashify)
       (remfsubr 'unformat)
       (remfsubr 'grindmacro)
       (remfsubr 'grindfn)
       (remfsubr 'readmacro)
       (remfsubr 'unreadmacro)
       (remfsubr 'readmacroinverse)
       (remsubr 'slashify1)
       (remsubr 'unslashify1)
       (remsubr 'programspace)
       (remsubr 'grindmacrocheck)
       (remsubr '?grindmacro)
       (remsubr 'comment-form)
       (remsubr 'pagewidth)
       (remsubr 'comspace)
       (remsubr 'lispgrind)
       (remsubr 'cnvrgrind)
       (remsubr 'page)
       (remsubr 'topwidth)
       (remsubr 'rem/;)
       (ifnio (remsubr 'newlinel))
       (ifnio (remsubr 'grchrct))
       (remsubr 'rem/;/;)
       (remsubr 'tj6)
       (remsubr 'prin50com)
       (remsubr 'prinallcmnt)
       (remsubr 'semi-comment)
       (remsubr 'putgrind)
       (remsubr 'lambda-form)
       (remsubr 'prog-form)
       (remsubr 'if-form)
       (remsubr 'def-form)
       (remsubr 'coment-form)
       (remsubr 'block-form)
       (remsubr 'mem-form)
       (remsubr 'setq-form)
       (remsubr 'setq-predict)
       (remsubr 'remsem1)
       (remsubr 'remsemi)
       (remsubr 'popl)
       (remsubr 'semi?)
       (remsubr 'semisemi?)
       (remsubr 'indent)
       (remsubr 'indent-to)
       (remsubr 'pprin)
       (remsubr 'form)
       (remsubr 'sprint)
       (remsubr 'grind-unbnd-vrbl)
       (remsubr 'sprinter)
       (remsubr 'sprint1)
       (remsubr 'grindargs)
       (remsubr 'done?)
       (remsubr 'gblock)
       (remsubr 'gprin1)
       (remsubr 'maxpan)
       (remsubr 'panmax)
       (remsubr 'prog-predict)
       (remsubr 'block-predict)
       (remsubr 'gflatsize)
       (remsubr 'flatdata)
       (remsubr 'grindslew)
       (remsubr 'remlsubr)
       (remfsubr 'remgrind)
       (remsubr 'remfsubr)
       (remsubr 'remsubr)
       ((lambda (nn)
		(do mm 0 (1+ mm) (= mm nn)
		   (mapc 
		    '(lambda (x) 
			(cond ((getl x '(grindfn grindpredict grindmacro))
				(remprop x 'grindfn)
				(remprop x 'grindpredict)
				(remprop x 'grindmacro))))
		     ((lambda (x)
			(cond ((and x (atom x)) (ncons x))
			      (x)))
		        (obarray mm)) )))
	  (cadr (arraydims 'obarray)))
       (makunbound 'merge)
       (makunbound 'grindpredict )
       (makunbound 'predict)
       (makunbound 'grindfn)
       (makunbound 'grindmacro)
       (makunbound 'programspace)
       (makunbound 'topwidth)
       (makunbound '/;)
       (makunbound '/;/;)
       (makunbound 'user-paging)
       (makunbound 'pagewidth)
       (makunbound 'comspace)
       (makunbound 'prog?)
       (makunbound 'comnt)
       (makunbound '/;/;?)
       (makunbound 'cnvrgrindflag)
       (makunbound 'remsemi) 
       (makunbound 'grindlinct) 
       (makunbound 'global-lincnt) 
       (makunbound 'grindproperties) 
       (makunbound 'grindef)
       (makunbound 'grindreadtable)
       (makunbound 'grind-standard-quote)
       (makunbound 'grind-use-original-readtable)
       (*rearray 'gtab/|)
       (gctwa)) 


(defun grindef fexpr (atoms)                                           ;(grindef <atoms>) grinds the properties
       (prog (traced fn props)                         ;of the atoms listed on
             (set-linel)
             (cond ((get 'conniver 'array)                             ;"grindproperties". (grindef
                    (or cnvrgrindflag (cnvrgrind))))
             (cond (atoms (setq grindef atoms))                        ;(additional properties) <atoms>) grinds
                   ((setq atoms grindef)))                             ;the additional properties as well.
             (setq props grindproperties)
        a    (cond ((null atoms) (return (ascii 0.))))
             (setq fn (car atoms) atoms (cdr atoms))
             (cond ((atom fn))
                   ((setq props (append fn props)) (go a)))
             (cond ((setq traced (and (cond ((status sstatus feature) (status feature trace))
					    ((get 'trace 'fexpr)))
                                      (memq fn (trace))))              ;flag for fn being traced
                    (terpri)
                    (terpri)
                    (princ '/;traced)))
             (do ((plist (cdr fn) (cddr plist))
                  (ind 'value (car plist))
                  (prop (and (boundp fn) (symeval fn)) (cadr plist))
                  (valueless (not (boundp fn)) t))                        ;needed in case there are value properties
                 (nil)
             (cond ((and traced (memq ind '(expr fexpr macro)))        ;ignore first fn property if traced
                    (setq traced nil)
                    (go b))
                   ((not (memq ind props)) (go b))                     ;grindef only desired properties.
                   ((eq ind 'value)
                    (cond ((not valueless)
                           (terpri)
                           (terpri)
                           (sprint (list 'setq
                                         fn
                                         (list 'quote
                                               prop))
                                   linel
                                   0.)))
                    (go b)))
             (terpri)
             (terpri)                                                  ;terpri's placed here to avoid
             (cond ((eq ind 'theorem)                                  ;terpri'ing when no properties.
                    (sprint (cons (car prop) (cons fn (cdr prop)))
                            linel
                            0.))
                   ((and (memq ind '(expr fexpr macro))                ;lambda -> defun
                         (eq (car prop) 'lambda))
                    (sprint (cons 'defun
                                  (cons fn
                                        (cond ((eq ind 'expr)
                                               (cdr prop))
                                              ((cons ind
                                                     (cdr prop))))))
                            linel
                            0.))
                   ((eq ind 'cexpr)
                    (sprint (cons 'cdefun (cons fn prop))
                            linel
                            0.))
                   ((sprint (list 'defprop fn prop ind)
                            linel
                            0.)))
        b    (or plist (return nil)))   ;exit from do when no more properties
         (go a)               ;look for more atoms to do.
          ))

;;;assigning special formats

(defun unformat fexpr (x)                                              ;(unformat fn1 fn2 ...) or (unformat
       (or (atom (car x)) (setq x (car x)))                            ;(fn1 fn2 ...))
       (mapc '(lambda (x) (remprop x 'grindfn)
                          (remprop x 'grindmacro)
                          (remprop x 'grindpredict))
             x)) 

(defun grindmacro fexpr (y)                                            ;eg (grindmacro quote /')
       (putgrind (car y) (cdr y) 'grindmacro)) 

(defun grindfn fexpr (y)                                               ;eg (grindfn (prog thprog) prog-form)
       (putgrind (car y) (cdr y) 'grindfn)) 

(defun putgrind expr (fn prop ind)                                     ;like putprop
       (cond
        ((atom fn)
         (setq prop
               (cond ((atom (car prop))
                      (and (get (car prop) 'grindpredict)
                           (putprop fn
                                    (get (car prop)
                                         'grindpredict)
                                    'grindpredict))
                      (car prop))
                     (t (and (eq (caar prop) 'readmacroinverse)
                             (putprop fn
                                      (get 'readmacroinverse
                                           'grindpredict)
                                      'grindpredict))
                        (cons 'lambda (cons nil prop)))))
         (putprop fn prop ind))
        ((mapc '(lambda (x) (putgrind x prop ind)) fn)))) 

;;;read macros

(defun readmacro fexpr (y)                                             ;eg (readmacro quote /' [optional])
       (putgrind (car y)                                               ;where optional means macro cons not
                 (list (cons 'readmacroinverse                         ;list
                             (cons (cadr y) (cddr y))))
                 'grindmacro)) 

(defun unreadmacro fexpr (y) (remprop y 'grindmacro)) 

(defun ?grindmacro (x) 
       (prog (y) 
             (cond ((and cnvrgrindflag
                         (setq y (get x 'grindmacro)))
                    (return (list (cddr (caddr y)))))
                   (t (return nil))))) 

(defun grindmacrocheck (x l) 
       (cond ((and (equal x '((t))) (cdr l)))
             ((and (equal x '(nil)) (= (length l) 2.)))
             ((and (equal x '((cnvr-optional))) (cdr l))))) 

(defun readmacroinverse fexpr (x)                                      ;(fn l)--><macro char><pretty-print l>. 
       (prog (sprarg) 
             (cond ((grindmacrocheck (list (cdr x)) l)                 ;macro-char = atom or list of ascii
                    (cond ((atom (car x)) (princ (car x)))             ;values. macro must have arg to execute
                          ((mapc 'tyo (car x))))                       ;inverse
                    (setq sprarg (cond ((null (cdr x)) (cadr l))
                                       ((eq (cadr x) t) (cdr l))
                                       ((= (length (cdr l)) 1.)
                                        (cond ((null (cadr l))
                                               (tyo 32.)
                                               (return t))
                                              (t (cadr l))))
                                       (t (cdr l))))
                    (cond ((sprint1 sprarg (grchrct) m) (prin1 sprarg)))
                    (return t))
                   (t (return nil))))) 

;;predefined formats

(defun lambda-form nil 
       (form 'line)                                                    ;format for lambda's 
       (and (< (grchrct) (gflatsize (testl)))                          ;prohibits form3 if args do not fit on
            (setq form 'form2))                                        ;line.
       (form 'block)) 

(defun prog-form nil 
       (form 'line)                                                    ;format for thprog's and prog's
       (setq prog? t)
       (setq form (cond ((and predict (< (grchrct) (gflatsize (testl))))   ;prohibits form3 if args do not fit on
                         'form2)                                       ;line.
                        (arg)))
       (form 'block)) 

(defun if-form nil
       (setq prog? t)
       (form 'line)
       (cond ((atom (testl)) (form 'line)))
       (setq form (cond ((and predict (< (grchrct) (gflatsize (testl))))
                         'form2)
                        (arg)))
       (form 'list))

(defun def-form nil 
       (prog nil 
             (cond ((eq (car l) 'cdefun) (setq prog? t)))
             (form 'line)
             (form 'line)
        go   (cond ((memq (testl)
                          '(expr fexpr macro thnoassert cexpr))
                    (form 'line)
                    (go go)))
             (setq form
                   (cond ((and predict (< (grchrct) (gflatsize (testl))))  ;prohibits form3 if args do not fit on
                          'form2)                                      ;line.
                         (arg)))
             (return (form 'block)))) 

(defun comment-form nil (gblock (- (grchrct) 1. (gflatsize (car l)))))     ;grinds l with args outputed as list.

(defun block-form nil (gblock (grchrct))) 


(defun mem-form nil 
       (prog (p gm) 
             (form 'line)                                              ;quoted second arg ground as block
             (remsemi)
             (catch (and (setq p (panmax (car l) (grchrct) 0.))
                         (cond ((< (panmax (car l) n 0.) p))
                               ((setq n (grchrct))))))
             (cond ((sprint1 (car l) n 0.) (prin1 (car l))))
        a    (cond ((null (cdr l))
		    (setq l (error 'mem-form l 'fail-act))
		    (go a)))
	     (popl)
        go   (indent-to n)
             (setq m (1+ m))
             (cond ((eq (caar l) 'quote)
                    (princ '/')
                    (cond ((pprin (cadar l) 'block)) ((prin1 (cadar l)))))
                   ((setq gm (sprint1 (car l) n m))
                    (cond ((and cnvrgrindflag (grindmacrocheck gm l))
                           (princ '/./ )
                           (sprint1 l (- n 2.) m)
                           (setq l nil)
                           (return nil))
                          (t (prin1 (car l))))))
             (popl)
             (cond (l (go go)) ((return nil))))) 

(defun setq-form nil 
       (cond ((catch (prog (mm) 
                           (setq mm (maxpan (cdr l) arg))              ;standard form
                           (setq n arg)                                ;committed to at least standard form
                           (defprop setq
                                    (setq-predict l n m)
                                    grindpredict)                      ;prediction in special form computed to
                           (and (< mm                                  ;compare to p.
                                   (panmax l
                                           (prog2 nil
                                                  (1+ n)
                                                  (setq n arg))
                                           m))                         ;setq form
                                (return t))
                           (form 'line)
                      d    (or l (return nil))
                           (indent-to n)
                           (form 'line)
                           (form 'code)
                           (remsemi)
                           (go d)))
              (defprop setq nil grindpredict)                          ;setq-predict causes throw when variable
              (form 'line)                                             ;name is very long.  therefore, it is
              (setq form n))))                                         ;not used all the time but only inside
                                                                       ;setq-form.


(defun setq-predict (l n m)                                            ;returns number of lines to print args
       (prog (mm nn)                                                   ;as name-value pairs.
             (setq n (- n 2. (gflatsize (car l))))                     ;n = space for name<space>value.  2 =
             (setq mm 0.)                                              ;space for ( and <space preceding
        a    (and (null (setq l (cdr l))) (return mm))                 ;variable>.
             (and (semi? (car l)) (go a))
             (setq nn (- n 2. (gflatsize (car l))))                    ;nn = space for value. 2 = space for )
        b    (cond ((null (cdr l))	                               ;and <space preceding value>.
                    (setq l (error 'setq-predict l 'wrng-no-args))
		    (go b)))
	     (setq l (cdr l))
             (and (semi? (car l)) (go b))
             (setq mm (+ mm (panmax (car l) nn 0.)))
             (go a))) 


;;;format control

(defun predict args (setq predict (cond ((= args 0.)) ((arg 1.)))))    ;(predict) <=> (predict t) =>
                                                                       ;super-careful sprint considering all
                                                                       ;formats.  (predict nil) => less careful
                                                                       ;but quicker.


;;;the following format fns are used only in grinding files.  however,
;;;they may appear in a grind (init) file which is loaded by gfn.
;;;hence, they are defined in gfn to avoid undf error.

(defun slashify fexpr (chars) (mapc 'slashify1 chars))                 ;(eg (slashify $).  preserve slashes
                                                                       ;preceding user read macros.

(defun unslashify fexpr (chars) (mapc 'unslashify1 chars)) 

(defun slashify1 (char)                                                ;make char '-like readmacro.
       ((lambda (readtable) 
         (or
          (null (getchar char 2.))                                     ;will be null only if char is single
          (setq char (error 'slashify char 'wrng-type-arg)))
         (setsyntax char
                    'macro
                    (subst char
                           'char
                           '(lambda nil (list 'char (read)))))
         (apply 'readmacro (list char char)))
        grindreadtable)) 


;(declare (noargs nil))                                                        ;args prop for user-level tj6 fns.

(defun unslashify1 (char) 
       ((lambda (readtable) 
         (or
          (null (getchar char 2.))
          (setq char (error 'unslashify char 'wrng-type-arg)))
         (setsyntax char 'macro nil)
         (apply 'unreadmacro (list char)))
        grindreadtable)) 

(defun programspace (x) 
       (setq programspace (newlinel x))
       (setq comspace (- pagewidth gap programspace))) 

(defun pagewidth (w x y z) 
       (setq pagewidth w)
       (setq gap y)
       (setq programspace x)
       (setq comspace z)) 

(defun comspace (x) 
       (setq comspace x)
       (setq programspace (- pagewidth gap comspace))) 

(defun page nil (tyo 12.) (setq grindlinct global-lincnt)) 

(defun fill args (setq fill (cond ((= args 0.)) ((arg 1.)))))          ;(fill) <=> (fill t) => spaces gobbled
                                                                       ;in ; comments.  (fill nil) => spaces
                                                                       ;not gobbled.  triple semi comments are
                                                                       ;never filled but are retyped exactly
                                                                       ;inuser's original form.

(defun merge args (setq merge (cond ((= args 0.)) ((arg 1.)))))        ;(merge) <=> (merge t) => adjoining ;
                                                                       ;and ;; comments are merged. (merge nil)
                                                                       ;=> adjoining comments not merged. 
                                                                       ;;;;... are never merged.

(defun user-paging args                                                ;(user-paging) <=> (user-paging t) 
       (setq user-paging (cond ((= args 0.)) ((arg 1.)))))             ;grind does not insert any formfeeds,
                                                                       ;but preserves paging of user's file.
                                                                       ;(user-paging nil) => grind inserts
                                                                       ;formfeed every 59 lines.  attempts to
                                                                       ;avoid s-expr pretty-printed over page
                                                                       ;boundary.  ignores users paging. paging
                                                                       ;of user's file.

(defun topwidth (x) (setq topwidth x)) 

;(declare (noargs t))                                                  ;args prop for user-level tj6 fns.

;;user defined formats
(defun remsemi nil
 (prog (retval)
        loop (cond ((remsem1) (setq retval t)) ((return retval)))
             (go loop)))


(defun remsem1 nil                                                     ;remsemi switch t for grinding files,
       (and remsemi (cond ((rem/;) (rem/;/;) t) ((rem/;/;)))))         ;nil for grindef.  speeds up grindef. 
                                                                       ;also, prevents possible illegal memory
                                                                       ;reference by rem/; caar on pnames.

(defun popl nil (setq l (cdr l)) (remsemi) l) 

(defun semisemi? (k) 
 (cond ((null remsemi) nil)                             ;check for any ;;'s
        ((eq k /;/;))
          ((atom k) nil)
           ((or (semisemi? (car k)) (semisemi? (cdr k))))))             ;at any depth

(defun semi? (k) (and remsemi (or (eq (car k) /;) (eq (car k) /;/;)))) 

(defun indent (nn)                                                     ;indents additonal nn spaces.
	(cond ((minusp (setq nn (- (grchrct) nn)))
		(error 'indent/ beyond/ linel? nn 'fail-act)
		(terpri))
	      ((indent-to nn)))) 

(defun stat-tab macro (x) (list 'quote (status tabsize)))              ;replaced by compiler by tab (8 its, 10. ;Multics)

(defun indent-to (nn)                                                  ;chrct set to nn
       ((lambda (nct tab) 
                (declare (fixnum nct tab))
                (cond ((or (< nct 0.) (> nn nct))                      ;chrct may become negative from
                       (turpri)                                        ;prin50com.
                       (setq nct linel)))
                (cond ((< nn nct)                                      ;some indentation is necessary
                       (setq tab (+ nct 
				    (- (stat-tab))
                                    (\ (- linel nct) (stat-tab))))     ;position as a result of first tab.
                       (cond ((< tab nn) (grindslew (- nct nn) 32.))    ;tabs do not move 8, but
                             ((tyo 9.)					;to nearest multiple of 8
                              (setq nct tab)
                              (cond ((< nn nct) 
				     (grindslew (// (setq nct (- nct nn)) (stat-tab)) 9.)
                                     (grindslew (\ nct (stat-tab)) 32.))))))))
        (grchrct)
        0.)) 

(defun grindslew (nn x) (do mm nn (1- mm) (zerop mm) (tyo x)))


(defun pprin (l tp) 
       (cond ((and cnvrgrindflag (atom l) (?grindmacro l)) nil)
             ((atom l) (prin1 l) t)                                    ;l is ground as line if tp = 'line, as a
             ((eq tp 'line)
              (cond ((gprin1 l n)(prin1 l))) t )                               ;block if tp = 'block or as a function
             ((eq tp 'block)                                           ;followed by a list
              (or (and (atom (car l))
                       ((lambda (x) (and x (apply x nil)))
                         (get (car l) 'grindmacro)))
                  (progn (princ '/()                                           ;of arguments if l = 'list, or normally
                       (gblock (grchrct))                                              ;if tp = 'code.
                       (princ '/)))))
             ((eq tp 'list)
              (or (and (atom (car l))
                       ((lambda (x) (and x (apply x nil)))
                         (get (car l) 'grindmacro)))
                  (progn (princ '/()
                       (gblock (- (grchrct) 1. (gflatsize (car l))))
                       (princ '/)))))
             ((eq tp 'code) (sprint1 l (grchrct) m) t))) 

(defun turpri nil 
       (and remsemi comnt (prin50com))                                 ;cr with line of outstanding single semi
       (terpri)                                                        ;comment printed, if any.  grindlinct =
       (setq grindlinct (cond ((= grindlinct 0.) global-lincnt)                ;lines remaining on page.
                              ((1- grindlinct))))) 

(ifnio (defun grchrct nil (- linel (charpos (and outfiles (car outfiles))))))


(defun testl args 
       (prog (k nargs) 
             (setq k l nargs (cond ((= 0. args) 0.) ((arg 1.))))
        a    (cond ((null k) (return nil))
                   ((semi? (car k)) (setq k (cdr k)) (go a))
                   ((= 0. nargs)
                    (return (cond ((= 2. args) k) (t (car k)))))
                   ((setq nargs (1- nargs))
                    (setq k (cdr k))
                    (go a))))) 

(defun form (x)                                                        ;pprin the car of l, then pops l.
       (cond ((remsemi) (form x))                                      ;no-op if l is already nil. process
             (l (cond ((pprin (car l) x)                                       ;initial semi-colon comment, if any,
	               (and (cdr l) (tyo 32.))                                ;then try again. pretty-print c(car l)
	               (setq l (cdr l)))
                      ((and cnvrgrindflag (grindmacrocheck (?grindmacro (car l)) l))
                       (princ '/./ )
                       (gprin1 l (- n 2.))
                       (setq l nil form nil))
                      (t (prin1 (car l))
                         (and (cdr l) (tyo 32.))
                         (setq l (cdr l)))))))                                  ;in desired format. if l is not yet nil,
                                                                       ;output a space. return popped l. 



;;local functions

(defun sprinter (l)                                                    ;pretty print over whole width
       (prog nil 
             (set-linel)
             (turpri)
             (turpri)
             (sprint l linel 0.)
             (turpri)
             (return '*))) 

(defun sprint (l n m) (fillarray 'gtab/| '(nil)) (sprint1 l n m)) 

;;;sprint formats
;;;form1 = (s1    form2 = (s1 s2    form3 = (s1 s2 (sprint1 last))
;;;         s2                s3)
;;;         s3)

(defun sprint1 (l n m)                                                 ;expression l to be sprinted in space n
       (prog (form arg fn args p prog? grindfn form3? gm)              ;with m unbalanced "/)" hanging. p is
             (and (remsemi) (null l) (return nil))                     ;number lines to sprint1 as form2
             (setq /;/;? nil)
             (indent-to n)
             (and (atom l) 
		  (cond (cnvrgrindflag)
			((setq gm (?grindmacro l)) (return gm))
                        (t (prin1 l) (return nil))))
             (cond ((and grind-standard-quote 			      ;This is an explicit check for QUOTE.
			 (eq (car l) 'quote)			      ;The alternative is to use the standard grindmacro
			 (cdr l) 				      ;To use your own personal readmacro for quote,
			 (null (cddr l)))			      ;setq grind-standard-quote to nil.
		    (princ '/') 
		    (and (setq gm (sprint1 (cadr l) (grchrct) m))
			 cnvrgrindflag 
			 (cond ((grindmacrocheck gm (cdr l))
				(princ '/./ )
				(sprint1 (cdr l) (- (grchrct) 2) m))
			       (t (prin1 (car l)))))
		    (return nil)))
	     (and (atom (car l))
                  (setq fn (car l))
                  ((lambda (x) (and x (apply x nil)))
                   (get (car l) 'grindmacro))
                  (return nil))
             (cond ((semisemi? l))                      ;if a ;; comnt, force multi-line
                   ((< (+ m -1. (gflatsize l)) (grchrct))
                    (return (gprin1 l n))))
             (princ '/()
             (setq n (grchrct))
             (setq arg (- n (gflatsize (car l)) 1.))
             (and
              (atom (setq args
                          (cond ((setq grindfn (get fn
                                                    'grindfn))
                                 (apply grindfn nil)
                                 (and (numberp form)
                                      (setq n form)
                                      (go b))
                                 (and (null l)
                                      (princ '/))
                                      (return nil))
                                 l)
                                ((cdr l)))))
              (go b))
             (catch                                                    ;catch exited if space insufficient.
              (and
               (setq p (maxpan args arg))                              ;p = # of lines to sprint l in standard
               (cond (predict (not (< (maxpan args n) p)))             ;format. exit if miser more efficient
                     (fn))                                             ;than standard in no-predict mode, use
               (setq n arg)                                            ;miser format on all non-fn-lists.
               (cond                                                   ;committed to standard format.
                (grindfn (or (eq form 'form2)
                          (> (maxpan args (grchrct)) p) (setq n (grchrct))))
                ((prog nil 
                       (or predict (go a))                             ;skip form3 is predict=nil.
                       (catch
                        (setq 
                         form3?                                        ;l cannot be fit in chrct is it more
                         (and (not (eq (car (last l)) /;))             ;efficient to grind l form3 or form2
                              (< (maxpan (last l)
                                         (- (grchrct)
                                            (- (gflatsize l)
                                               (gflatsize (last l)))))
                                 p))))
                  a    (cond ((setq gm (gprin1 (car l) n))
                              (cond ((grindmacrocheck gm l)
                                     (princ '/./ )
                                     (gprin1 l (- n 2.))
                                     (setq l nil)
                                     (go b1))
                                    (t (prin1 (car l))))))
                       (tyo 32.)
                       (and (cdr (setq l (cdr l))) form3? (go a))
                  b1   (setq n (grchrct)))))))
        b    (grindargs l n m))) 

(defun grindargs (l nn mm)                                             ;elements of l are ground one under the
       (prog (gm sprarg1 sprarg2)                                      ;next
        a    (and (done? nn) (return nil))                             ;prints closing paren if done.
             (setq sprarg1 (cond ((and cnvrgrindflag (eq (car l) '/"aux/")) (+ nn 6.))
                                 ((and prog?
                                       (car l)
                                       (or (atom (car l))
                                           (and cnvrgrindflag (eq (caar l) ':))))
                                  (+ nn 5.))                           ;exception of tags which are unindented
                                 (nn)))                                ;5
             (setq sprarg2 (cond ((null (cdr l)) (1+ mm))
                                 ((atom (cdr l))
                                  (+ 4. mm (gflatsize (cdr l))))
                                 (0.)))
             (cond ((setq gm (sprint1 (car l) sprarg1 sprarg2))
                    (cond ((grindmacrocheck gm l)
                           (princ '/./ )
                           (sprint1 l (- sprarg1 2.) sprarg2)
                           (setq l nil)
                           (go a))
                          (t (prin1 (car l))))))
             (setq l (cdr l))
             (go a)))
 

(defun done? (nn) 
       (cond ((atom l)
              (and /;/;? (indent-to nn))                               ;if previous line a ;; comment, then do
              (cond (l (princ '/ /./ ) (prin1 l)))                     ;not print closing paren on same line as
              (princ '/))                                              ;comment.
              t)))                                                     ;prints closing "/)" if done


(defun gblock (n)                                                      ;l printed as text with indent n.
       (prog (gm) 
             (and (remsemi) (or l (return nil)))
        a    (cond ((setq gm (gprin1 (car l) n))
                    (cond ((grindmacrocheck gm l)
                           (princ '/./ )
                           (gprin1 l (- n 2.))
                           (return (setq l nil)))
                          (t (prin1 (car l))))))
             (or (popl) (return nil))
             (cond ((< (gflatsize (car l)) (- (grchrct) 2. m))
                    (tyo 32.)
                    (go a))
                   ((and (not (atom (car l)))                          ;non-atomic elements occuring in block
                         (< (- n m) (gflatsize (car l))))              ;too large for the line are sprinted. 
                    (cond ((setq gm (sprint1 (car l) n m))             ;this occurs in the variable list of a
                           (cond ((grindmacrocheck gm l)               ;thprog.
                                  (princ '/./ )
                                  (sprint1 l (- n 2.) m)
                                  (return (setq l nil)))
                                 (t (prin1 (car l))))))
                    (or (popl) (return nil))))
             (indent-to n)                                             ;new line
             (go a)))
 


(defun gprin1 (l nn)                                                   ;prin1 with grindmacro feature.
       (cond ((and cnvrgrindflag (atom l) (?grindmacro l)))
             ((atom l) (prin1 l) nil)
             ((prog (gm) 
                    (remsemi)
                    (and (atom (car l))
                         ((lambda (x) (and x (apply x nil)))
                          (get (car l) 'grindmacro))
                         (return nil))
                    (princ '/()
               a    (cond ((setq gm (gprin1 (car l) nn))
                           (cond ((grindmacrocheck gm l)
                                  (princ '/./ )
                                  (gprin1 l (- nn 2.))
                                  (setq l nil)
                                  (go a1))
                                 (t (prin1 (car l))))))
                    (popl)
               a1   (and (done? nn) (return nil))
                    (tyo 32.)
                    (go a))))) 

;;prediction functions

(defun maxpan (l n) 
       (prog (g)                                                       ;estimates number of lines to sprint1
             (setq g 0.)                                               ;list of s expression one under the next
        a    (setq g                                                   ;in space n
                   (+ g
                      (panmax (car l)
                              n
                              (cond ((null (setq l (cdr l))) (1+ m))
                                    ((atom l) (+ m 4. (gflatsize l)))
                                    (0.)))))
             (and (atom l) (return g))
             (go a))) 

(defun panmax (l n m) 
       (cond ((< (+ m -1. (gflatsize l)) n) 1.)                        ;estimates number of lines to sprint1 an
             ((or (< n 3.) (atom l)) (throw 40.))                      ;s expression in space n.  less costly
             ((or (not (atom (car l))) (atom (cdr l)))                 ;than sprint
              (maxpan l (sub1 n)))
             ((eval (get (car l) 'grindpredict)))                      ;as it always chooses form2.  if
             ((maxpan (cdr l) (- n 2. (gflatsize (car l)))))))         ;insufficient space, throws.

(defun prog-predict (l n m) 
       ((lambda (nn) (+ (block-predict (cadr l) nn 1.)
                        (maxpan (cddr l) nn)))
        (- n 2. (gflatsize (car l))))) 

(defprop lambda-form (prog-predict l n m) grindpredict) 

(defprop prog-form (prog-predict l n m) grindpredict) 

(defun block-predict (l n indent)                                      ;indent=spaces indented to margin of
       (cond ((> 1. (setq n (- n indent))) (throw 50.))                ;block. throw if insuff remaining space.
             ((1+ (// (- (gflatsize l) indent) n)))))                  ;number of lines approx by dividing size
                                                                       ;of l by block width.

(defprop comment-form
         (block-predict l n (+ (gflatsize (car l)) 2.))
         grindpredict) 

(defprop block-form (block-predict l n 1.) grindpredict) 

(defprop readmacroinverse (panmax (cadr l) (1- n) m) grindpredict) 

(defun gflatsize (data)
    ((lambda (nn bucket)
             (setq bucket (gtab/| nn))
             (cdr (cond ((and bucket (assq data bucket)))
                        (t (car (store (gtab/| nn)
                                       (cons (setq data (cons data (flatsize data)))
                                             bucket)))))))
        (\ (maknum data) 127.) nil)) 

;;conniver macros

(setq cnvrgrindflag nil) 

(defun cnvrgrind nil 
       ((lambda (readtable) 
                (setsyntax ':
                           'macro
                           'grindcolmac)
                (setsyntax '@ 'macro 'grindatmac)
                (setsyntax '/,
                           'macro
                           'grindcommac)
                (setsyntax '! 'macro 'grindexmac)
                (readmacro : :)
                (readmacro /, /,)
                (readmacro @ @ t)
                (readmacro !$ (33. 36.) t)
                (readmacro !/" (33. 34.) t)
                (readmacro !@ (33. 64.) t)
                (readmacro !? (33. 63.) cnvr-optional)
                (readmacro !/, (33. 44.) cnvr-optional)
                (readmacro !< (33. 60.) cnvr-optional)
                (readmacro !> (33. 62.) cnvr-optional)
                (readmacro !/; (33. 59.) cnvr-optional)
                (readmacro !/' (33. 39.) cnvr-optional)
                (setq cnvrgrindflag t sgploses grind-standard-quote grind-standard-quote nil)
                'conniver-macros-learned)
        grindreadtable)) 

(defun lispgrind nil 
       ((lambda (readtable) 
                (setsyntax ': 'macro nil)
                (setsyntax '@ 'macro nil)
                (setsyntax '/, 'macro nil)
                (setsyntax '! 'macro nil)
                (mapc 'unreadmacro
                      '(: /, @ !$ !/" !@ !? !/' !/, !< !> !/;))
                (setq cnvrgrindflag nil grind-standard-quote sgploses)
                'conniver-macros-forgotten)
        grindreadtable)) 


;;default formats

						;"quote" is explicitly checked, and the inverse
                                                ;macro function ignored if this flag is non-nil.
                                                ;To have your own macro for quote take effect, 
                                                ;set grind-standard-quote to nil.
(readmacro quote /')                           ;Still ned to define the standard macro

(grindfn (grindfn grindmacro) (form 'line)
                              (form 'block)) 

(grindfn lambda lambda-form) 

(grindfn (if-added if-needed if-removed) if-form)

(grindfn (defun cdefun) def-form) 

(grindfn prog prog-form) 

(grindfn (comment remob **array *fexpr *expr *lexpr special
          unspecial) comment-form) 

(grindfn (member memq map maplist mapcar mapcon mapcan mapc assq
          assoc sassq sassoc getl) mem-form) 

(grindfn setq setq-form) 

(grindfn csetq setq-form) 

(predict nil) 


;;;the following default formats are relevant only to grinding files.
;;;however, they appear here since the format fns are not defined
;;;in gfile and gfn is not loaded until after gfile.
;;default formats

(pagewidth 120. 70. 1. 49.) 

(topwidth 110.) 

(merge t) 

(fill t) 

(user-paging nil) 

;;;read the user's start_up.grind [Multics] or grind (init) [ITS] file.

(cond ((status feature its)
       (prog (form ^w h l)		;loader for grind (init) file
             (setq h (list nil) l (crunit))
             (apply 'crunit (list 'dsk (status udir)))
             (cond ((cond ((get 'uprobe 'fsubr)
			    (cond ((uprobe grind /(init/)) 
				   (uread grind /(init/))
					   t)
				  (t (go dn1)))) 
			  ((errset (uread grind /(init/)) nil)))
                    (terpri)
                    (princ '/;loading/ grind/ /(init/)/ dsk/ )
                    (princ (cadr (crunit)))
                    (setq ^q t))
                   (t (go done)))
       init (cond ((and ^q (not (eq h (setq form (read h))))) (eval form) (go init)))
       done (apply 'crunit l)
       dn1  (gctwa)
            (return '*)) )
      (t (errset (load (list (status udir)       ;loader for start_up.grind file
                             'start_up
                             'grind))
                 nil)))




		    lisp_loop_.lisp                 07/06/83  0938.4r w 06/29/83  1543.0      723564



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************
;;;   LOOP  -*- Mode:LISP; Package:System-Internals; Base:8; Lowercase:T -*-
;;;   **********************************************************************
;;;   ****** Universal ******** LOOP Iteration Macro ***********************
;;;   **********************************************************************
;;;   **** (C) COPYRIGHT 1980, 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ******** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *************
;;;   **********************************************************************

;;;; LOOP Iteration Macro

;The master copy of this file is on ML:LSB1;LOOP >
;The current Lisp machine copy is on AI:LISPM2;LOOP >
;The FASL and QFASL should also be accessible from LIBLSP; on all machines.
;(Is this necessary anymore? LOOP is now in the Lisp Machine system and
; is accessible on LISP; and distributed with PDP10 Maclisp.)
;Duplicate source is usually also maintained on MC:LSB1;LOOP >
;Printed documentation is available as MIT-LCS Technical Memo 169,
; "LOOP Iteration Macro", from:
;	Publications
;	MIT Laboratory for Computer Science
;	545 Technology Square
;	Cambridge, MA 02139
; the text of which appears in only slightly modified form in the Lisp
; Machine manual.

; Bugs/complaints/suggestions/solicitations-for-documentation to BUG-LOOP
; at any ITS site (MIT-ML preferred).


; **********************************************************************
; *************************** NOTE WELL ********************************
; **********************************************************************
;Incremental compiling of things in this file will generate wrong code
; unless you first evaluate the 'feature' stuff on the next page
; ("readtime environment setup").  (This mainly of Lispm interest.)
;This source sincerely believes that it can run compatibly, WITHOUT ANY
; TEXTUAL MODIFICATIONS AT ALL, in PDP-10 Maclisp, Multics Maclisp, Lisp
; Machine Lisp (Zetalisp), VAX NIL, and Franz Lisp.  PLEASE do not make
; changes to this file (the master copy) if you are in any way unsure
; of the implications in a dialect you are not very familiar with;  let
; a LOOP maintainer take the responsibility for breaking the master copy
; and maintaining some semblance of sanity among the disparities.  Note
; in particular that LOOP also runs in the PDP10 Maclisp -> Vax NIL
; cross-compiler;  that environment requires LOOP to produce code which
; can at the same time be interpreted in Maclisp, and compiled for NIL.


; Bootstrap up our basic primitive environment.
; This includes backquote, sharpsign, defmacro, let.

(eval-when (eval compile)
  (cond ((status feature Multics)
	   (defun include-for-multics macro (x)
	     (cons '%include (cdr x))))
	('t (macro include-for-multics (x) ()))))

(include-for-multics sharpsign)
(include-for-multics defmacro)
(include-for-multics other_other)
(include-for-multics defun)

;;;; Readtime Environment Setup

;Now set up the readtime conditionalization environment.   This won't work
; in any compiler that reads the whole file before compiling anything.
; It is a good idea to pretend that case matters in ALL contexts.
; This is in fact true in Franz at the present.  Case matters to Multics
; in symbols, except for <frob> in (status feature <frob>).
(eval-when (eval compile)
  #+NIL (progn
	   (defmacro loop-featurep (f)
	     `(featurep ',f target-features))
	   (defmacro loop-nofeaturep (f)
	     `(nofeaturep ',f target-features))
	   (defmacro loop-set-feature (f)
	     `(set-feature ',f target-features))
	   (defmacro loop-set-nofeature (f)
	     `(set-nofeature ',f target-features))
	   )
  #-NIL (progn
	   (defmacro loop-featurep (f)
	     `(status feature ,f))
	   (defmacro loop-nofeaturep (f)
	     ; Multics doesn't have (status nofeature)...
	     `(not (status feature ,f)))
	   (defmacro loop-set-feature (f)
	     `(sstatus feature ,f))
	   (defmacro loop-set-nofeature (f)
	     ; Does this work on Multics???  I think not but we don't use.
	     `(sstatus nofeature ,f))
	   )
  ;Note:  NEVER in this file is "PDP-10" a valid feature or substring of
  ; a feature.  It is NEVER hyphenated.  Keep it that way.  (This because
  ; of continuous lossage with not setting up one or the other of the
  ; hyphenated/non-hyphenated one.)
  (cond ((and (loop-featurep PDP10)
	      (loop-featurep NILAID))
	   ;Compiling a PDP10 -> NIL cross-compiling LOOP.
	   ; We check the PDP10 feature first sort of gratuitously so that
	   ; other implementations don't think we are asking about an undefined
	   ; feature name.  (Vax-NIL specifically.)
	   (loop-set-feature For-NIL)
	   (loop-set-nofeature For-Maclisp)
	   (loop-set-nofeature For-PDP10)
	   (loop-set-feature Run-in-Maclisp)
	   (loop-set-feature Run-on-PDP10)
	   (loop-set-nofeature Franz))
	((and (loop-featurep Maclisp) (loop-nofeaturep For-NIL))
	   ; Standard in-Maclisp for-Maclisp.
	   (loop-set-feature For-Maclisp)
	   (loop-set-feature Run-In-Maclisp)
	   (cond ((loop-nofeaturep Multics)
		    (loop-set-feature For-PDP10)
		    (loop-set-feature PDP10)
		    (loop-set-feature Run-on-PDP10))))
	((loop-featurep NIL)
	   ; Real NIL
	   (loop-set-nofeature PDP10)
	   (loop-set-nofeature Multics)
	   (loop-set-nofeature Run-on-PDP10)
	   (loop-set-nofeature For-PDP10)
	   (loop-set-nofeature Run-In-Maclisp)
	   (loop-set-nofeature For-Maclisp))
	((loop-featurep Lispm))
	((loop-featurep franz)
	   ;The "natural" case of features in franz is all lower.
	   ; Since that is unlike the others used in here, we synonymize
	   ; the obvious other choice.
	   (loop-set-feature Franz))
	('t (break loop-implementation-unknown)))
  (cond ((or (loop-featurep Lispm) (loop-featurep For-PDP10))
	   (loop-set-feature Hairy-Collection))
	('t (loop-set-nofeature Hairy-Collection)))
  (cond ((or (loop-featurep For-NIL) (loop-featurep For-PDP10))
	   (loop-set-feature System-Destructuring))
	('t (loop-set-nofeature System-Destructuring)))
  (cond ((or (loop-featurep For-NIL) (loop-featurep Lispm))
	   (loop-set-feature Named-PROGs))
	('t (loop-set-nofeature Named-PROGs)))
  ;In the following two features, "Local" means the Lisp LOOP will be
  ; running in, not the one it is being compiled in.  "Targeted" means
  ; the Lisp it will be producing code for.  (All from the point of view
  ; of the running LOOP, you see.)
  (cond ((or (loop-featurep For-NIL) (loop-featurep Lispm))
	   (loop-set-feature Targeted-Lisp-has-Packages))
	('t (loop-set-nofeature Targeted-Lisp-has-Packages)))
  (cond ((or (loop-featurep Franz) (loop-featurep Run-in-Maclisp))
	   (loop-set-nofeature Local-Lisp-has-Packages))
	('t (loop-set-feature Local-Lisp-has-Packages)))
  (cond ((loop-featurep For-NIL) (loop-set-feature Vector-Destructuring))
	('t (loop-set-nofeature Vector-Destructuring)))
  ;Meaningful-Type-Declarations means that the declarations are (1)
  ; implemented by the compiler and (2) used for something.
  ; Assume minimally maclisp-like FIXNUM and FLONUM dcls, for local
  ; variables or function results.
  (cond ((loop-featurep Run-in-Maclisp)
	   (loop-set-feature Meaningful-Type-Declarations))
	('t (loop-set-nofeature Meaningful-Type-Declarations)))
  ;Hair for 3600 cross-compilation?
  (cond ((and (loop-featurep Lispm) (not (loop-featurep 3600.)))
	   (loop-set-feature Loop-Small-Floatp))
	('t (loop-set-nofeature Loop-Small-Floatp)))
  ; -> insert more conditionals here <-
  ())

#+Franz
(eval-when (eval compile)
  (setsyntax #// 143.) ; Make slash be slash
  (setsyntax #/\ 2.) ; make backslash alphabetic
  )


#+Run-on-PDP10
(eval-when (compile)
  ;Note this hack used when compiled only.
  ;Its purpose in life is to save a bit of space in the load-time environment,
  ; since loop doesn't actually need the PDP10 Maclisp doublequoted crocks
  ; to remember their origin as "strings".
  (setsyntax #/" 'macro
	     '(lambda ()
		(do ((ch (tyi) (tyi)) (l () (cons ch l)))
		    ((= ch #/")
		     (list squid (list 'quote (implode (nreverse l)))))
		  (and (= ch #//) (setq ch (tyi)))))))


;;;; Other basic header stuff


; Following isn't needed on Lispm, as loop is installed there (ie, these
; symbols are already in GLOBAL).
#+(and Targeted-Lisp-has-Packages (not Lispm))
(mapc 'globalize
      '("LOOP"					; Major macro
	"LOOP-FINISH"				; Handy macro
	"DEFINE-LOOP-MACRO"
	"DEFINE-LOOP-PATH"			; for users to define paths
	"DEFINE-LOOP-SEQUENCE-PATH"		; this too
	))

#+(or For-NIL For-PDP10)
(herald LOOP)


;;;; Macro Environment Setup

;Wrapper for putting around DEFMACRO etc. forms to determine whether
; they are defined in the compiled output file or not.  (It is assumed
; that DEFMACRO forms will be.)  Making loop-macro-progn output for loading
; is convenient if loop will have incremental-recompilation done on it.
; (Note, of course, that the readtime environment is NOT set up.)

#+Lispm
(defmacro loop-macro-progn (&rest forms)
    `(progn 'compile ,@forms))
#-Lispm
(eval-when (eval compile)
    (defmacro loop-macro-progn (&rest forms)
	`(eval-when (eval compile) ,@forms)))


; Hack up the stuff for data-types.  DATA-TYPE? will always be a macro
; so that it will not require the data-type package at run time if
; all uses of the other routines are conditionalized upon that value.
(eval-when (eval compile)
  ; Crock for DATA-TYPE? derives from DTDCL.  We just copy it rather
  ; than load it in, which requires knowing where it comes from (sigh).
  ; 
  #-Local-Lisp-has-Packages
    (defmacro data-type? (x) `(get ,x ':data-type))
  #+Local-Lisp-has-Packages
    (defmacro data-type? (frob)
      (let ((foo (gensym)))
	`((lambda (,foo)
	    ; NIL croaks if () given to GET...
	    (and #+NIL (symbolp ,foo) #-NIL 't
		 (or (get ,foo ':data-type)
		     (and (setq ,foo (intern-soft (get-pname ,foo) ""))
			  (get ,foo ':data-type)))))
	  ,frob))))

(declare (*lexpr variable-declarations)
	 ; Multics defaults to free-functional-variable since it is declared
	 ; special & used as function before it is defined:
	 (*expr loop-when-it-variable)
	 (*expr initial-value primitive-type)
       #+(or Maclisp Franz) (macros t) ; Defmacro dependency
       #+(and Run-in-Maclisp (not Multics))
	 (muzzled t)	; I know what i'm doing
	 )

#+Run-on-PDP10
(declare (mapex ())
	 (genprefix loop/|-)
	 (special squid)
       #+(and Run-in-Maclisp For-NIL) ; patch it up
         (*expr stringp vectorp vref vector-length)
         )

#-Run-on-PDP10
(declare
  #+Lispm (setq open-code-map-switch t)
  #+Run-in-Maclisp (mapex t)
  #+Run-in-Maclisp (genprefix loop-iteration/|-))

#+Run-on-PDP10
(mapc '(lambda (x)
	   (or (getl x '(subr lsubr fsubr macro fexpr expr autoload))
	       ; This dtdcl will sort of work for NIL code generation,
	       ; if declarations will ignored.
	       (putprop x '((lisp) dtdcl fasl) 'autoload)))
      '(data-type? variable-declarations initial-value primitive-type))

(loop-macro-progn
 (defmacro loop-copylist* (l)
    #+Lispm `(copylist* ,l)
    #-Lispm `(append ,l ())))


;;;; Random Macros

; Error macro.  Note that in the PDP10 version we call LOOP-DIE rather
; than ERROR -- there are so many occurences of it in this source that
; it is worth breaking off that function, since calling the lsubr ERROR
; takes more inline code.
(loop-macro-progn
 (defmacro loop-simple-error (unquoted-message &optional (datum () datump))
    #+(and Run-In-Maclisp (not Multics))
      (progn (cond ((symbolp unquoted-message))
		   ((and (not (atom unquoted-message))
			 compiler-state
			 (eq (car unquoted-message) squid)
			 (not (atom (setq unquoted-message
					  (cadr unquoted-message))))
			 (eq (car unquoted-message) 'quote)
			 (symbolp (cadr unquoted-message)))
		      (setq unquoted-message (cadr unquoted-message)))
		   ('t (error '|Uloze -- LOOP-SIMPLE-ERROR|
			      (list 'loop-simple-error
				    unquoted-message datum))))
	     (cond (datump `(loop-die ',unquoted-message ,datum))
		   ('t `(error ',unquoted-message))))
    #+(or Franz Multics)
      (progn (or (memq (typep unquoted-message) '(string symbol))
		 (error '|Uloze -- | (list 'loop-simple-error
					   unquoted-message datum)))
	     `(error ,(let ((l (list "lisp:  " unquoted-message
				     (if datump " -- " ""))))
			#+Franz (get_pname (apply 'uconcat l))
			#-Franz (apply 'catenate l))
		     . ,(and datump (list datum))))
    #-(or Run-In-Maclisp Franz)
      `(ferror () ,(if datump (string-append "~S " unquoted-message)
		       unquoted-message)
	       . ,(and datump (list datum)))))


#+(and Run-in-Maclisp (not Multics))
(defun loop-die (arg1 arg2)
    (error arg1 arg2))


; This is a KLUDGE.  But it apparently saves an average of two inline
; instructions per call in the PDP10 version...  The ACS prop is
; fairly gratuitous.

#+Run-on-PDP10
(progn 'compile
   (lap-a-list 
     '((lap loop-pop-source subr)
       (args loop-pop-source (() . 0))
	   (hlrz a @ (special loop-source-code))
	   (hrrz b @ (special loop-source-code))
	   (movem b (special loop-source-code))
	   (popj p)
       nil))
   (eval-when (compile)
       (defprop loop-pop-source 2 acs)
       ))

#-Run-on-PDP10
(loop-macro-progn
 (defmacro loop-pop-source () '(pop loop-source-code)))

(loop-macro-progn
 (defmacro object-that-cares-p (x)
   #+Lispm `(listp ,x)
   #+(or NIL PDP10) `(pairp ,x)
   #-(or Lispm NIL PDP10) `(eq (typep ,x) 'list)))


;;;; Variable defining macros

;There is some confusion among lisps as to whether or not a file containing
; a DEFVAR will declare the variable when the compiled file is loaded
; into a compiler.  LOOP assumes that DEFVAR does so (this is needed for
; various user-accessible variables).  DEFIVAR is for "private" variables.
; Note that this is moot for Lispm due to incremental-recompilation support
; anyway.
;Multics lcp has some bug whereby DECLARE and (EVAL-WHEN (COMPILE) ...)
; don't get hacked properly inside of more than one level of
; (PROGN 'COMPILE ...).  Thus we hack around DEFVAR and DEFIVAR to bypass
; this lossage.
;Franz DEFVAR does not make the declaration on loading, so we redefine it.

#+(or Multics Franz)
(loop-macro-progn
 (defmacro defvar (name &optional (init nil initp) documentation
		   &aux (dclform `(and #+Franz (getd 'special)
				       #-Franz (status feature compiler)
				       (special ,name))))
    ; For some obscure reason, (DECLARE ...) doesn't take effect within 2
    ; (PROGN 'COMPILE ...)s, but (EVAL-WHEN (COMPILE) ...) does, on Multics.
    (eval dclform) ; sigh
    (cond ((not initp) dclform)
	  (t `(progn 'compile
		     ,dclform
		     (or (boundp ',name) (setq ,name ,init)))))))

(loop-macro-progn
 ; A DEFVAR alternative - "DEFine Internal VARiable".
 (defmacro defivar (name &optional (init () initp))
    ; The Lispm choice here is based on likelihood of incremental compilation.
    #+Lispm `(defvar ,name ,@(and initp `(,init)))
    #+Multics (progn (apply 'special (list name))
		     (if initp `(or (boundp ',name) (setq ,name ,init))
			 `(progn 'compile)))
    #-(or Lispm Multics)
      `(progn 'compile
	      (declare (special ,name))
	      . ,(and initp `((or (boundp ',name) (setq ,name ,init)))))))

#+Franz
;Defconst is like defvar but always initializes.
; It happens in this case that we really don't care about the global
; declaration on loading, so actually treat it more like DEFIVAR.
; (This is now in Multics and PDP10 Maclisp, thanks to Maclisp Extensions
; Manual.)
(loop-macro-progn
  (defmacro defconst (name init &optional documentation)
    `(progn 'compile (declare (special ,name)) (setq ,name ,init))))



;;;; Setq Hackery

; Note:  LOOP-MAKE-PSETQ is NOT flushable depending on the existence
; of PSETQ, unless PSETQ handles destructuring.  Even then it is
; preferable for the code LOOP produces to not contain intermediate
; macros, especially in the PDP10 version.

(defun loop-make-psetq (frobs)
    (and frobs
	 (loop-make-setq
	    (list (car frobs)
		  (if (null (cddr frobs)) (cadr frobs)
		      `(prog1 ,(cadr frobs)
			      ,(loop-make-psetq (cddr frobs))))))))

#-System-Destructuring
(progn 'compile

(defvar si:loop-use-system-destructuring?
    ())

(defivar loop-desetq-temporary)

; Do we want this???  It is, admittedly, useful...
;(defmacro loop-desetq (&rest x)
;  (let ((loop-desetq-temporary ()))
;     (let ((setq-form (loop-make-desetq x)))
;	(if loop-desetq-temporary
;	    `((lambda (,loop-desetq-temporary) ,setq-form) ())
;	    setq-form))))


(defun loop-make-desetq (x)
   (if si:loop-use-system-destructuring?
       (cons (do ((l x (cddr l))) ((null l) 'setq)
	       (or (and (not (null (car l))) (symbolp (car l)))
		   (return 'desetq)))
	     x)
       (do ((x x (cddr x)) (r ()) (var) (val))
	   ((null x) (and r (cons 'setq r)))
	 (setq var (car x) val (cadr x))
	 (cond ((and (not (atom var))
		     (not (atom val))
		     (not (and (memq (car val)
				     '(car cdr cadr cddr caar cdar))
			       (atom (cadr val)))))
		  (setq x (list* (or loop-desetq-temporary
				     (setq loop-desetq-temporary (gensym)))
				 val var loop-desetq-temporary (cddr x)))))
	 (setq r (nconc r (loop-desetq-internal (car x) (cadr x)))))))

(defun loop-desetq-internal (var val)
  (cond ((null var) ())
	((atom var) (list var val))
	('t (nconc (loop-desetq-internal (car var) `(car ,val))
		   (loop-desetq-internal (cdr var) `(cdr ,val))))))
); End desetq hackery for #-System-Destructuring


(defun loop-make-setq (pairs)
    (and pairs
	 #-System-Destructuring
	   (loop-make-desetq pairs)
	 #+System-Destructuring
	   (cons (do ((l pairs (cddr l))) ((null l) 'setq)
		   (or (and (car l) (symbolp (car l))) (return 'desetq)))
		 pairs)))


(defconst loop-keyword-alist			;clause introducers
     '(
      #+Named-PROGs
	(named loop-do-named)
	(initially loop-do-initially)
	(finally loop-do-finally)
	(nodeclare loop-nodeclare)
	(do loop-do-do)
	(doing loop-do-do)
	(return loop-do-return)
	(collect loop-do-collect list)
	(collecting loop-do-collect list)
	(append loop-do-collect append)
	(appending loop-do-collect append)
	(nconc loop-do-collect nconc)
	(nconcing loop-do-collect nconc)
	(count loop-do-collect count)
	(counting loop-do-collect count)
	(sum loop-do-collect sum)
	(summing loop-do-collect sum)
	(maximize loop-do-collect max)
	(minimize loop-do-collect min)
	(always loop-do-always or)
	(never loop-do-always and)
	(thereis loop-do-thereis)
	(while loop-do-while or while)
	(until loop-do-while and until)
	(when loop-do-when ())
	(if loop-do-when ())
 	(unless loop-do-when t)
	(with loop-do-with)))


(defconst loop-iteration-keyword-alist
    `((for loop-do-for)
      (as loop-do-for)
      (repeat loop-do-repeat)))


(defconst loop-for-keyword-alist			;Types of FOR
     '( (= loop-for-equals)
        (first loop-for-first)
	(in loop-list-stepper car)
	(on loop-list-stepper ())
	(from loop-for-arithmetic from)
	(downfrom loop-for-arithmetic downfrom)
	(upfrom loop-for-arithmetic upfrom)
	(below loop-for-arithmetic below)
	(to loop-for-arithmetic to)
	(being loop-for-being)))

#+Named-PROGs
(defivar loop-prog-names)

(defvar loop-path-keyword-alist ())		; PATH functions
(defivar loop-named-variables)			; see SI:LOOP-NAMED-VARIABLE
(defivar loop-collection-crocks)		; see LOOP-DO-COLLECT etc
(defivar loop-variables)			;Variables local to the loop
(defivar loop-declarations)			; Local dcls for above
(defivar loop-nodeclare)			; but don't declare these
(defivar loop-variable-stack)
(defivar loop-declaration-stack)
#-System-Destructuring
(defivar loop-desetq-crocks)			; see loop-make-variable
#-System-Destructuring
(defivar loop-desetq-stack)			; and loop-translate-1
(defivar loop-prologue)				;List of forms in reverse order
(defivar loop-before-loop)
(defivar loop-body)				;..
(defivar loop-after-body)			;.. for FOR steppers
(defivar loop-epilogue)				;..
(defivar loop-after-epilogue)			;So COLLECT's RETURN comes after FINALLY
(defivar loop-conditionals)			;If non-NIL, condition for next form in body
  ;The above is actually a list of entries of the form
  ;(cond (condition forms...))
  ;When it is output, each successive condition will get
  ;nested inside the previous one, but it is not built up
  ;that way because you wouldn't be able to tell a WHEN-generated
  ;COND from a user-generated COND.
  ;When ELSE is used, each cond can get a second clause

(defivar loop-when-it-variable)			;See LOOP-DO-WHEN
(defivar loop-never-stepped-variable)		; see LOOP-FOR-FIRST
(defivar loop-emitted-body?)			; see LOOP-EMIT-BODY,
						; and LOOP-DO-FOR
(defivar loop-iteration-variables)		; LOOP-MAKE-ITERATION-VARIABLE
(defivar loop-iteration-variablep)		; ditto
(defivar loop-collect-cruft)			; for multiple COLLECTs (etc)
(defivar loop-source-code)
(defvar loop-duplicate-code ())  ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC


;;;; Token Hackery

;Compare two "tokens".  The first is the frob out of LOOP-SOURCE-CODE,
;the second a symbol to check against.

; Consider having case-independent comparison on Multics.
#+(or Multics Franz)
(progn 'compile
    (defmacro si:loop-tequal (x1 x2)
	`(eq ,x1 ,x2))
    (defmacro si:loop-tmember (x l)
	`(memq ,x ,l))
    (defmacro si:loop-tassoc (x l)
	`(assq ,x ,l)))


#+Lispm
(progn 'compile
   (defun si:loop-tequal (x1 x2)
	(and (symbolp x1) (string-equal x1 x2)))
   (defun si:loop-tassoc (kwd alist)
	(and (symbolp kwd) (ass #'string-equal kwd alist)))
   (defun si:loop-tmember (kwd list)
	(and (symbolp kwd) (mem #'string-equal kwd list))))


#+Run-on-PDP10
(progn 'compile
   #+For-NIL
     (defun si:loop-tequal (x1 x2)
	 (eq x1 x2))
   #-For-NIL
     (progn 'compile
	(eval-when (load compile)
	   (cond ((status feature complr)
		    ; Gross me out!
		    (setq macrolist
			  (cons '(si:loop-tequal
				    . (lambda (x) (cons 'eq (cdr x))))
				(delq (assq 'si:loop-tequal macrolist)
				      macrolist)))
		    (*expr si:loop-tmember si:loop-tassoc))))
	(defun si:loop-tequal (x1 x2)
	   (eq x1 x2)))
     (defun si:loop-tmember (kwd list)
	 (memq kwd list))
     (defun si:loop-tassoc (kwd alist)
	 (assq kwd alist))
     )

#+(and For-NIL (not Run-in-Maclisp))
(progn 'compile
  ; STRING-EQUAL only accepts strings.  GET-PNAME can be open-coded
  ; however.
  (defun si:loop-tequal (kwd1 kwd2)
      (and (symbolp kwd1) (string-equal (get-pname kwd1) (get-pname kwd2))))
  (defun si:loop-tassoc (kwd alist)
    (cond ((symbolp kwd)
	     (setq kwd (get-pname kwd))
	     (do ((l alist (cdr l))) ((null l) ())
	       (and (string-equal kwd (get-pname (caar l)))
		    (return (car l)))))))
  (defun si:loop-tmember (token list)
     (cond ((symbolp token)
	      (setq token (get-pname token))
	      (do ((l list (cdr l))) ((null l))
		(and (string-equal token (get-pname (car l)))
		     (return l)))))))


#+(or For-PDP10 For-NIL)
(eval-when (eval compile) (setq defmacro-displace-call ()))

(defmacro define-loop-macro (keyword)
    (or (eq keyword 'loop)
	(si:loop-tassoc keyword loop-keyword-alist)
	(si:loop-tassoc keyword loop-iteration-keyword-alist)
	(loop-simple-error "not a loop keyword - define-loop-macro" keyword))
    (subst keyword 'keyword
	   '(eval-when (compile load eval)
	      #+(or For-NIL Run-on-PDP10)
	        (progn (flush-macromemos 'keyword ())
		       (flush-macromemos 'loop ()))
	      #-Run-in-Maclisp
	        (progn
		  #+Franz
		    (putd 'keyword
			  '(macro (macroarg) (loop-translate macroarg)))
		  #-Franz
		    (fset-carefully 'keyword '(macro . loop-translate)))
	      #+Run-in-Maclisp
	        (progn (defprop keyword loop-translate macro))
	      )))

#+(or For-PDP10 For-NIL)
(eval-when (eval compile) (setq defmacro-displace-call 't))

(define-loop-macro loop)

#+Run-in-Maclisp
(defun (loop-finish macro) (form)
    ;This definition solves two problems:
    ; (1) wasted address space
    ; (2) displacing of a form which might tend to be pure.
    ; There is little point in macro-memoizing a constant anyway.
    (and (cdr form) (loop-simple-error "Wrong number of args" form))
    '(go end-loop))

#-Run-in-Maclisp
(defmacro loop-finish () 
    '(go end-loop))


(defun loop-translate (x)
    #-(or For-NIL Run-on-PDP10) (displace x (loop-translate-1 x))
    #+(or For-NIL Run-on-PDP10)
      (or (macrofetch x) (macromemo x (loop-translate-1 x) 'loop)))


(defun loop-end-testify (list-of-forms)
    (if (null list-of-forms) ()
	`(and ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
		   (car list-of-forms)
		   (cons 'or list-of-forms))
	      (go end-loop))))

(defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b
					       lastdiff)
    (do ((l1 (nreverse loop-before-loop) (cdr l1))
	 (l2 (nreverse loop-after-body) (cdr l2)))
	((equal l1 l2)
	   (setq loop-body (nconc (delq '() l1) (nreverse loop-body))))
      (push (car l1) before) (push (car l2) after))
    (cond ((not (null loop-duplicate-code))
	     (setq loop-before-loop (nreverse (delq () before))
		   loop-after-body (nreverse (delq () after))))
	  ('t (setq loop-before-loop () loop-after-body ()
		    before (nreverse before) after (nreverse after))
	      (do ((bb before (cdr bb)) (aa after (cdr aa)))
		  ((null aa))
		(cond ((not (equal (car aa) (car bb))) (setq lastdiff aa))
		      ((not (si:loop-simplep (car aa)))	;Mustn't duplicate
		       (return ()))))
	      (cond (lastdiff  ;Down through lastdiff should be duplicated
		     (do () (())
		       (and (car before) (push (car before) loop-before-loop))
		       (and (car after) (push (car after) loop-after-body))
		       (setq before (cdr before) after (cdr after))
		       (and (eq after (cdr lastdiff)) (return ())))
		     (setq loop-before-loop (nreverse loop-before-loop)
			   loop-after-body (nreverse loop-after-body))))
	      (do ((bb (nreverse before) (cdr bb))
		   (aa (nreverse after) (cdr aa)))
		  ((null aa))
		(setq a (car aa) b (car bb))
		(cond ((and (null a) (null b)))
		      ((equal a b)
		         (loop-output-group groupb groupa)
			 (push a loop-body)
			 (setq groupb () groupa ()))
		      ('t (and a (push a groupa)) (and b (push b groupb)))))
	      (loop-output-group groupb groupa)))
    (and loop-never-stepped-variable
	 (push `(setq ,loop-never-stepped-variable ()) loop-after-body))
    ())


(defun loop-output-group (before after)
    (and (or after before)
	 (let ((v (or loop-never-stepped-variable
		      (setq loop-never-stepped-variable
			    (loop-make-variable (gensym) ''t ())))))
	    (push (cond ((not before) `(or ,v (progn . ,after)))
			((not after) `(and ,v (progn . ,before)))
			('t `(cond (,v . ,before) ('t . ,after))))
		  loop-body))))


(defun loop-translate-1 (loop-source-code)
  (and (eq (car loop-source-code) 'loop)
       (setq loop-source-code (cdr loop-source-code)))
  (do ((loop-iteration-variables ())
       (loop-iteration-variablep ())
       (loop-variables ())
       (loop-nodeclare ())
       (loop-named-variables ())
       (loop-declarations ())
     #-System-Destructuring
       (loop-desetq-crocks ())
       (loop-variable-stack ())
       (loop-declaration-stack ())
     #-System-destructuring
       (loop-desetq-stack ())
       (loop-prologue ())
       (loop-before-loop ())
       (loop-body ())
       (loop-emitted-body? ())
       (loop-after-body ())
       (loop-epilogue ())
       (loop-after-epilogue ())
       (loop-conditionals ())
       (loop-when-it-variable ())
       (loop-never-stepped-variable ())
     #-System-Destructuring
       (loop-desetq-temporary ())
     #+Named-PROGs
       (loop-prog-names ())
       (loop-collect-cruft ())
       (loop-collection-crocks ())
       (keyword)
       (tem)
       (progvars))
      ((null loop-source-code)
       (and loop-conditionals
	    (loop-simple-error "Hanging conditional in loop macro"
			       (caadar loop-conditionals)))
       (loop-optimize-duplicated-code-etc)
       (loop-bind-block)
       (setq progvars loop-collection-crocks)
     #-System-Destructuring
       (and loop-desetq-temporary (push loop-desetq-temporary progvars))
       (setq tem `(prog #+Named-PROGs ,.loop-prog-names
			,progvars
		      #+Hairy-Collection
		        ,.(do ((l loop-collection-crocks (cddr l))
			       (v () (cons `(loop-collect-init
					        ,(cadr l) ,(car l))
					    v)))
			      ((null l) v))
		      ,.(nreverse loop-prologue)
		      ,.loop-before-loop
		   next-loop
		      ,.loop-body
		      ,.loop-after-body
		      (go next-loop)
		      ; Multics complr notices when end-loop is not gone
		      ; to.  So we put in a dummy go.  This does not generate
		      ; extra code, at least in the simple example i tried,
		      ; but it does keep it from complaining about unused
		      ; go tag.
	    #+Multics (go end-loop)
		   end-loop
		      ,.(nreverse loop-epilogue)
		      ,.(nreverse loop-after-epilogue)))
       (do ((vars) (dcls) #-System-Destructuring (crocks))
	   ((null loop-variable-stack))
	 (setq vars (car loop-variable-stack)
	       loop-variable-stack (cdr loop-variable-stack)
	       dcls (car loop-declaration-stack)
	       loop-declaration-stack (cdr loop-declaration-stack)
	       tem (ncons tem))
	 #-System-Destructuring
	   (and (setq crocks (pop loop-desetq-stack))
		(push (loop-make-desetq crocks) tem))
	 (and dcls (push (cons 'declare dcls) tem))
	 (cond ((do ((l vars (cdr l))) ((null l) ())
		  (and (not (atom (car l)))
		       (or (null (caar l)) (not (symbolp (caar l))))
		       (return 't)))
		  (setq tem `(let ,(nreverse vars) ,.tem)))
	       ('t (let ((lambda-vars ()) (lambda-vals ()))
		     (do ((l vars (cdr l)) (v)) ((null l))
		       (cond ((atom (setq v (car l)))
				(push v lambda-vars)
				(push () lambda-vals))
			     ('t (push (car v) lambda-vars)
				 (push (cadr v) lambda-vals))))
		     (setq tem `((lambda ,lambda-vars ,.tem)
				 ,.lambda-vals))))))
       tem)
    (if (symbolp (setq keyword (loop-pop-source)))
	(if (setq tem (si:loop-tassoc keyword loop-keyword-alist))
	    (apply (cadr tem) (cddr tem))
	    (if (setq tem (si:loop-tassoc
			     keyword loop-iteration-keyword-alist))
		(loop-hack-iteration tem)
		(if (si:loop-tmember keyword '(and else))
		    ; Alternative is to ignore it, ie let it go around to the
		    ; next keyword...
		    (loop-simple-error
		       "secondary clause misplaced at top level in LOOP macro"
		       (list keyword (car loop-source-code)
			     (cadr loop-source-code)))
		    (loop-simple-error
		       "unknown keyword in LOOP macro" keyword))))
	(loop-simple-error
	   "found where keyword expected in LOOP macro" keyword))))


(defun loop-bind-block ()
   (cond ((not (null loop-variables))
	    (push loop-variables loop-variable-stack)
	    (push loop-declarations loop-declaration-stack)
	    (setq loop-variables () loop-declarations ())
	    #-System-Destructuring
	      (progn (push loop-desetq-crocks loop-desetq-stack)
		     (setq loop-desetq-crocks ())))))


;Get FORM argument to a keyword.  Read up to atom.  PROGNify if necessary.
(defun loop-get-form ()
  (do ((forms (ncons (loop-pop-source)) (cons (loop-pop-source) forms))
       (nextform (car loop-source-code) (car loop-source-code)))
      ((atom nextform)
       (if (null (cdr forms)) (car forms)
	   (cons 'progn (nreverse forms))))))


;Note that this function is not absolutely general.  For instance, in Maclisp,
; the functions < and > can only take 2 args, whereas greaterp and lessp
; may take any number.  Also, certain of the generic functions behave
; differently from the type-specific ones in "degenerate" cases, like
; QUOTIENT or DIFFERENCE of one arg.
;And of course one always must be careful doing textual substitution.
(defun loop-typed-arith (substitutable-expression data-type)
  #-(or Lispm Franz)
    (if (setq data-type (car (si:loop-tmember (if (data-type? data-type)
						  (primitive-type data-type)
						  data-type)
					      '(fixnum flonum))))
	(sublis (cond ((eq data-type 'fixnum)
		         #+For-NIL
			   '((plus . +) (add1 . 1+)
			     (difference . -) (sub1 . 1-)
			     (quotient . //) (remainder . \) (times . *)
			     (zerop . 0p) (plusp . +p) (minusp . -p)
			     (greaterp . >) (lessp . <)
			     (min . min&) (max . max&))
			 #-For-NIL
			   '((plus . +) (add1 . 1+)
			     (difference . -) (sub1 . 1-)
			     (quotient . //) (remainder . \) (times . *)
			     (greaterp . >) (lessp . <)))
		      ('t #+For-NIL
			    '((plus . +$) (difference . -$)
			      (add1 . 1+$) (sub1 . 1-$)
			      (quotient . //$) (times . *$)
			      (greaterp . >$) (lessp . <$)
			      (max . max$) (min . min$))
			  #-For-NIL
			    '((plus . +$) (difference . -$)
			      (add1 . 1+$) (sub1 . 1-$)
			      (quotient . //$) (times . *$)
			      (greaterp . >) (lessp . <))))
		substitutable-expression)
	substitutable-expression)
  #+Lispm
    (progn data-type substitutable-expression)
  #+Franz
    (if (si:loop-tequal data-type 'fixnum)
	(sublis '((add1 . 1+) (sub1 . 1-) (plus . +) (difference . -)
		  (times . *) (quotient . //) (remainder . \))
		substitutable-expression)
	substitutable-expression)
  )


(defun loop-typed-init (data-type)
    (cond ((data-type? data-type) (initial-value data-type))
	  ((setq data-type (car (si:loop-tmember
				   data-type '(fixnum flonum integer number
					       #+Loop-Small-Floatp
					         small-flonum))))
	     (cond ((eq data-type 'flonum) 0.0)
		 #+Loop-Small-Floatp
		   ((eq data-type 'small-flonum)
		      #.(and (loop-featurep Loop-Small-Floatp)
			     (small-float 0)))
		   ('t 0)))))


(defun loop-make-variable (name initialization dtype)
  (cond ((null name)
	   (cond ((not (null initialization))
		    (push (list #+Lispm 'ignore
				#+Multics (setq name (gensym))
				#-(or Lispm Multics) ()
				initialization)
			  loop-variables)
		    #+Multics (push `(progn ,name) loop-prologue))))
	(#-Vector-Destructuring (atom name)
	 #+Vector-Destructuring (symbolp name)
	   (cond (loop-iteration-variablep
		    (if (memq name loop-iteration-variables)
			(loop-simple-error
			   "Duplicated iteration variable somewhere in LOOP"
			   name)
			(push name loop-iteration-variables)))
		 ((assq name loop-variables)
		    (loop-simple-error
		       "Duplicated var in LOOP bind block" name)))
	 #-Vector-Destructuring
	   (or (symbolp name)
	       (loop-simple-error "Bad variable somewhere in LOOP" name))
	   (loop-declare-variable name dtype)
	   ; We use ASSQ on this list to check for duplications (above),
	   ; so don't optimize out this list:
	   (push (list name (or initialization (loop-typed-init dtype)))
		 loop-variables))
	(initialization
	   #+System-Destructuring
	     (progn (loop-declare-variable name dtype)
		    (push (list name initialization) loop-variables))
	   #-System-Destructuring
	     (cond (si:loop-use-system-destructuring?
		      (loop-declare-variable name dtype)
		      (push (list name initialization) loop-variables))
		   ('t (let ((newvar (gensym)))
			  (push (list newvar initialization) loop-variables)
			  ; LOOP-DESETQ-CROCKS gathered in reverse order.
			  (setq loop-desetq-crocks
				(list* name newvar loop-desetq-crocks))
			  (loop-make-variable name () dtype)))))
	('t
	  #-Vector-Destructuring
	    (let ((tcar) (tcdr))
	      (if (atom dtype) (setq tcar (setq tcdr dtype))
		  (setq tcar (car dtype) tcdr (cdr dtype)))
	      (loop-make-variable (car name) () tcar)
	      (loop-make-variable (cdr name) () tcdr))
	  #+Vector-Destructuring
	    (cond ((object-that-cares-p name)
		     (let ((tcar) (tcdr))
			(if (object-that-cares-p dtype)
			    (setq tcar (car dtype) tcdr (cdr dtype))
			    (setq tcar (setq tcdr dtype)))
			(loop-make-variable (car name) () tcar)
			(loop-make-variable (cdr name) () tcdr)))
		  ((vectorp name)
		     (do ((i 0 (1+ i))
			  (n (vector-length name))
			  (dti 0 (1+ dti))
			  (dtn (and (vectorp dtype) (vector-length dtype))))
			 ((= i n))
		       #+Run-in-Maclisp (declare (fixnum i n dti))
		       (loop-make-variable
			  (vref name i) ()
			  (if (null dtn) dtype
			      (and (< dti dtn) (vref dtype dti))))))
		  ('t (loop-simple-error
		         "bad variable somewhere in LOOP" name)))
	  ))
  name)


(defun loop-make-iteration-variable (name initialization dtype)
    (let ((loop-iteration-variablep 't))
       (loop-make-variable name initialization dtype)))


(defun loop-declare-variable (name dtype)
    (cond ((or (null name) (null dtype)) ())
	  ((symbolp name)
	     (cond ((memq name loop-nodeclare))
		 #+Multics
		   ; local type dcls of specials lose.  This doesn't work
		   ; for locally-declared specials.
		   ((get name 'special))
		   ((data-type? dtype)
		      (setq loop-declarations
			    (append (variable-declarations dtype name)
				    loop-declarations)))
		#+Meaningful-Type-Declarations
		   ((si:loop-tmember dtype '(fixnum flonum))
		      (push `(,dtype ,name) loop-declarations))))
	  ((object-that-cares-p name)
	      (cond ((object-that-cares-p dtype)
		       (loop-declare-variable (car name) (car dtype))
		       (loop-declare-variable (cdr name) (cdr dtype)))
		    ('t (loop-declare-variable (car name) dtype)
			(loop-declare-variable (cdr name) dtype))))
	#+Vector-Destructuring
	  ((vectorp name)
	     (do ((i 0 (1+ i))
		  (n (vector-length name))
		  (dtn (and (vectorp dtype) (vector-length dtype)))
		  (dti 0 (1+ dti)))
		 ((= i n))
	       #+Meaningful-Type-Declarations (declare (fixnum i n dti))
	       (loop-declare-variable
		  (vref name i)
		  (if (null dtn) dtype (and (< dti dtn) (vref dtype dti))))))
	  ('t (loop-simple-error "can't hack this"
				 (list 'loop-declare-variable name dtype)))))


#+For-PDP10
(declare (special squid))

(defun loop-constantp (form)
    (or (numberp form)
	#+For-NIL (or (null form) (vectorp form))
	#-For-NIL (memq form '(t ()))
	#-For-PDP10 (stringp form)
	(and (not (atom form))
	     #-Run-on-PDP10 (eq (car form) 'quote)
	     #+Run-on-PDP10 (or (eq (car form) 'quote)
				; SQUID implies quoting.
				(and compiler-state (eq (car form) squid))))
	))

(defun loop-maybe-bind-form (form data-type?)
    ; Consider implementations which will not keep EQ quoted constants
    ; EQ after compilation & loading.
    ; Note FUNCTION is not hacked, multiple occurences might cause the
    ; compiler to break the function off multiple times!
    ; Hacking it probably isn't too important here anyway.  The ones that
    ; matter are the ones that use it as a stepper (or whatever), which
    ; handle it specially.
    (if (loop-constantp form) form
	(loop-make-variable (gensym) form data-type?)))


(defun loop-optional-type ()
    (let ((token (car loop-source-code)))
	(and (not (null token))
	     (or (not (atom token))
		 (data-type? token)
		 (si:loop-tmember token '(fixnum flonum integer number notype
					  #+Loop-Small-Floatp small-flonum)))
	     (loop-pop-source))))


;Incorporates conditional if necessary
(defun loop-make-conditionalization (form)
  (cond ((not (null loop-conditionals))
	   (rplacd (last (car (last (car (last loop-conditionals)))))
		   (ncons form))
	   (cond ((si:loop-tequal (car loop-source-code) 'and)
		    (loop-pop-source)
		    ())
		 ((si:loop-tequal (car loop-source-code) 'else)
		    (loop-pop-source)
		    ;; If we are already inside an else clause, close it off
		    ;; and nest it inside the containing when clause
		    (let ((innermost (car (last loop-conditionals))))
		      (cond ((null (cddr innermost)))	;Now in a WHEN clause, OK
			    ((null (cdr loop-conditionals))
			     (loop-simple-error "More ELSEs than WHENs"
						(list 'else (car loop-source-code)
						      (cadr loop-source-code))))
			    ('t (setq loop-conditionals (cdr (nreverse loop-conditionals)))
				(rplacd (last (car (last (car loop-conditionals))))
					(ncons innermost))
				(setq loop-conditionals (nreverse loop-conditionals)))))
		    ;; Start a new else clause
		    (rplacd (last (car (last loop-conditionals)))
			    (ncons (ncons ''t)))
		    ())
		 ('t ;Nest up the conditionals and output them
		     (do ((prev (car loop-conditionals) (car l))
			  (l (cdr loop-conditionals) (cdr l)))
			 ((null l))
		       (rplacd (last (car (last prev))) (ncons (car l))))
		     (prog1 (car loop-conditionals)
			    (setq loop-conditionals ())))))
	('t form)))

(defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form)))
   (cond ((not (null z))
	    (cond (loop-emitted-body? (push z loop-body))
		  ('t (push z loop-before-loop) (push z loop-after-body))))))

(defun loop-emit-body (form)
  (setq loop-emitted-body? 't)
  (loop-pseudo-body form))


#+Named-PROGs
(defun loop-do-named ()
    (let ((name (loop-pop-source)))
       (or (and name (symbolp name))
	   (loop-simple-error "Bad name for your loop construct" name))
       (and (cdr (setq loop-prog-names (cons name loop-prog-names)))
	    (loop-simple-error "Too many names for your loop construct"
			       loop-prog-names))))

(defun loop-do-initially ()
  (push (loop-get-form) loop-prologue))

(defun loop-nodeclare (&aux (varlist (loop-pop-source)))
    (or (and varlist (eq (typep varlist) 'list))
	(loop-simple-error "Bad varlist to nodeclare loop clause" varlist))
    (setq loop-nodeclare (append varlist loop-nodeclare)))

(defun loop-do-finally ()
  (push (loop-get-form) loop-epilogue))

(defun loop-do-do ()
  (loop-emit-body (loop-get-form)))

(defun loop-do-return ()
   (loop-pseudo-body `(return ,(loop-get-form))))


;;;; List Collection

; The way we collect (list-collect) things is to bind two variables.
; One is the final result, and is accessible for value during the
; loop compuation.  The second is the "tail".  In implementations where
; we can do so, the tail var is initialized to a locative of the first,
; such that it can be updated with RPLACD.  In other implementations,
; the update must be conditionalized (on whether or not the tail is NIL).

; For PDP10 Maclisp:
; The "value cell" of a special variable is a (pseudo) list cell, the CDR
; of which is the value.  Hence the abovementioned tail variable gets
; initialized to this.  (It happens to be the CDAR of the symbol.)
; For local variables in compiled code, the Maclisp compiler implements
; a (undocumented private) form of the
; "(setq tail (variable-location var))" construct;  specifically, it
; is of the form  (#.gofoo var tail).  This construct must appear in
; the binding environment those variables are bound in, currently.
; Note that this hack only currently works for local variables, so loop
; has to check to see if the variable is special.  It is anticipated,
; however, that the compiler will be able to do this all by itself
; at some point.

#+For-PDP10
  (progn 'compile
     (cond ((status feature complr)
	      (setq loop-specvar-hack ((lambda (obarray)
					   (implode '(s p e c v a r s)))
				       sobarray))
	      (defun loop-collect-init-compiler (form)
		(cond ((memq compiler-state '(toplevel maklap))
		         ; We are being "toplevel" macro expanded.
			 ; We MUST expand into something which can be
			 ; evaluated without loop, in the interpreter.
			 `(setq ,(caddr form) (munkam (value-cell-location
						         ',(cadr form)))))
		      ((or specials
			   (get (cadr form) 'special)
			   (assq (cadr form) (symeval loop-specvar-hack)))
		         `(setq ,(caddr form) (cdar ',(cadr form))))
		      (t (cons gofoo (cdr form)))))
	      (push '(loop-collect-init . loop-collect-init-compiler)
		    macrolist)))
     (defun loop-collect-init fexpr (x)
	(set (cadr x) (cdar (car x)))))

#+(and Hairy-Collection (not For-PDP10))
(defmacro loop-collect-init (var1 var2)
   #+Lispm ;*****  Remove kludgey fboundp when everyone up-to-date *****
	   `(setq ,var2 ,(if (fboundp 'variable-location)
			     `(variable-location ,var1)
			     `(value-cell-location ',var1)))
   #-Lispm `(setq ,var2 (munkam (value-cell-location ',var1))))


(defun loop-do-collect (type)
  (let ((var) (form) (tem) (tail) (dtype) (cruft) (rvar)
	(ctype (cond ((memq type '(max min)) 'maxmin)
		     ((memq type '(nconc list append)) 'list)
		     ((memq type '(count sum)) 'sum)
		     ('t (loop-simple-error
			    "unrecognized LOOP collecting keyword" type)))))
    (setq form (loop-get-form) dtype (loop-optional-type))
    (cond ((si:loop-tequal (car loop-source-code) 'into)
	     (loop-pop-source)
	     (setq rvar (setq var (loop-pop-source)))))
    ; CRUFT will be (varname ctype dtype var tail (optional tem))
    (cond ((setq cruft (assq var loop-collect-cruft))
	     (cond ((not (eq ctype (car (setq cruft (cdr cruft)))))
		      (loop-simple-error
		         "incompatible LOOP collection types"
			 (list ctype (car cruft))))
		   ((and dtype (not (eq dtype (cadr cruft))))
		      ;Conditional should be on data-type reality
		      #+Run-in-Maclisp
		        (loop-simple-error
			   "Unequal data types in multiple collections"
			   (list dtype (cadr cruft) (car cruft)))
		      #-Run-in-Maclisp
		        (ferror () "~A and ~A Unequal data types into ~A"
				dtype (cadr cruft) (car cruft))))
	     (setq dtype (car (setq cruft (cdr cruft)))
		   var (car (setq cruft (cdr cruft)))
		   tail (car (setq cruft (cdr cruft)))
		   tem (cadr cruft))
	     (and (eq ctype 'maxmin)
		  (not (atom form)) (null tem)
		  (rplaca (cdr cruft) (setq tem (loop-make-variable
						   (gensym) () dtype)))))
	  ('t (and (null dtype)
		   (setq dtype (cond ((eq type 'count) 'fixnum)
				     ((memq type '(min max sum)) 'number))))
	     (or var (push `(return ,(setq var (gensym)))
			   loop-after-epilogue))
	     (or (eq ctype 'list) (loop-make-iteration-variable var () dtype))
	     (setq tail 
		   (cond ((eq ctype 'list)
			    #-Hairy-Collection
			      (setq tem (loop-make-variable (gensym) () ()))
			    (car (setq loop-collection-crocks
				       (list* (gensym) var
					      loop-collection-crocks))))
			 ((eq ctype 'maxmin)
			    (or (atom form)
				(setq tem (loop-make-variable
					     (gensym) () dtype)))
			    (loop-make-variable (gensym) ''t ()))))
	     (push (list rvar ctype dtype var tail tem)
		   loop-collect-cruft)))
    (loop-emit-body
	(caseq type
	  (count (setq tem `(setq ,var (,(loop-typed-arith 'add1 dtype)
					,var)))
		 (if (member form '(t 't)) tem `(and ,form ,tem)))
	  (sum `(setq ,var (,(loop-typed-arith 'plus dtype) ,form ,var)))
	  ((max min)
	     (let ((forms ()) (arglist ()))
		; TEM is temporary, properly typed.
		(and tem (setq forms `((setq ,tem ,form)) form tem))
		(setq arglist (list var form))
		(push (if (si:loop-tmember dtype '(fixnum flonum
						   #+Loop-Small-Floatp
						     small-flonum))
			  ; no contagious arithmetic
			  `(and (or ,tail
				    (,(loop-typed-arith
				         (if (eq type 'max) 'lessp 'greaterp)
					 dtype)
				     . ,arglist))
				(setq ,tail () . ,arglist))
			  ; potentially contagious arithmetic -- must use
			  ; MAX or MIN so that var will be contaminated
			  `(setq ,var (cond (,tail (setq ,tail ()) ,form)
					    ((,type . ,arglist)))))
		      forms)
		(if (cdr forms) (cons 'progn (nreverse forms)) (car forms))))
	  (t (caseq type
		(list (setq form (list 'list form)))
		(append (or (and (not (atom form)) (eq (car form) 'list))
			    (setq form #+Lispm `(copylist* ,form)
				       #-Lispm `(append ,form ())))))
	   #+Hairy-Collection
	     (let ((q `(rplacd ,tail ,form)))
		(cond ((and (not (atom form)) (eq (car form) 'list)
			    (not (null (cdr form))))
		         ; RPLACD of cdr-coded list:
			 #+Lispm
			   (rplaca (cddr q)
				   (if (cddr form) `(list* ,@(cdr form) ())
				       `(ncons ,(cadr form))))
			 `(setq ,tail ,(loop-cdrify (cdr form) q)))
		      ('t `(and (cdr ,q)
				(setq ,tail (last (cdr ,tail)))))))
	   #-Hairy-Collection
	     (let ((q `(cond (,tail (cdr (rplacd ,tail ,tem)))
			     ((setq ,var ,tem)))))
		(if (and (not (atom form)) (eq (car form) 'list) (cdr form))
		    `(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q))
		    `(and (setq ,tem ,form) (setq ,tail (last ,q))))))))))


(defun loop-cdrify (arglist form)
    (do ((size (length arglist) (- size 4)))
	((< size 4)
	 (if (zerop size) form
	     (list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) ('t 'cdddr))
		   form)))
      #+Meaningful-Type-Declarations (declare (fixnum size))
      (setq form (list 'cddddr form))))


(defun loop-do-while (cond kwd &aux (form (loop-get-form)))
    (and loop-conditionals (loop-simple-error
			      "not allowed inside LOOP conditional"
			      (list kwd form)))
    (loop-pseudo-body `(,cond ,form (go end-loop))))


(defun loop-do-when (negate?)
  (let ((form (loop-get-form)) (cond))
    (cond ((si:loop-tequal (cadr loop-source-code) 'it)
	     ;WHEN foo RETURN IT and the like
	     (setq cond `(setq ,(loop-when-it-variable) ,form))
	     (setq loop-source-code		;Plug in variable for IT
		   (list* (car loop-source-code)
			  loop-when-it-variable
			  (cddr loop-source-code))))
	  ('t (setq cond form)))
    (and negate? (setq cond `(not ,cond)))
    (setq loop-conditionals (nconc loop-conditionals `((cond (,cond)))))))

(defun loop-do-with ()
  (do ((var) (equals) (val) (dtype)) (())
    (setq var (loop-pop-source) equals (car loop-source-code))
    (cond ((si:loop-tequal equals '=)
	     (loop-pop-source)
	     (setq val (loop-get-form) dtype ()))
	  ((or (si:loop-tequal equals 'and)
	       (si:loop-tassoc equals loop-keyword-alist)
	       (si:loop-tassoc equals loop-iteration-keyword-alist))
	     (setq val () dtype ()))
	  ('t (setq dtype (loop-pop-source) equals (car loop-source-code))
	      (cond ((si:loop-tequal equals '=)
		       (loop-pop-source)
		       (setq val (loop-get-form)))
		    ((and (not (null loop-source-code))
			  (not (si:loop-tassoc equals loop-keyword-alist))
			  (not (si:loop-tassoc
				  equals loop-iteration-keyword-alist))
			  (not (si:loop-tequal equals 'and)))
		       (loop-simple-error "Garbage where = expected" equals))
		    ('t (setq val ())))))
    (loop-make-variable var val dtype)
    (if (not (si:loop-tequal (car loop-source-code) 'and)) (return ())
	(loop-pop-source)))
  (loop-bind-block))

(defun loop-do-always (pred)
  (let ((form (loop-get-form)))
    (loop-emit-body `(,pred ,form (return ())))
    (push '(return 't) loop-after-epilogue)))

;THEREIS expression
;If expression evaluates non-nil, return that value.
(defun loop-do-thereis ()
   (loop-emit-body `(and (setq ,(loop-when-it-variable) ,(loop-get-form))
			 (return ,loop-when-it-variable))))


; Hacks

#+Meaningful-Type-Declarations
  (declare (fixnum (loop-simplep-1 notype)))

(defun si:loop-simplep (expr)
    (if (null expr) 0
	(*catch 'si:loop-simplep
	    (let ((ans (si:loop-simplep-1 expr)))
	       #+Meaningful-Type-Declarations (declare (fixnum ans))
	       (and (< ans 20.) ans)))))

(defvar si:loop-simplep
  (append '(> < greaterp lessp plusp minusp typep zerop
	    plus difference + - add1 sub1 1+ 1-
	    +$ -$ 1+$ 1-$ boole rot ash ldb equal atom
	    setq prog1 prog2 and or =)
	  #+Lispm '(aref ar-1 ar-2 ar-3)
	  #+Lispm '#.(and (loop-featurep Lispm)
			  (mapcar 'ascii '(#/ #/ #/)))
	  #+For-NIL '(vref vector-length)
	  ))

(defun si:loop-simplep-1 (x)
  (let ((z 0))
    #+Meaningful-Type-Declarations (declare (fixnum z))
    (cond ((loop-constantp x) 0)
	  ((atom x) 1)
	  ((eq (car x) 'cond)
	     (do ((cl (cdr x) (cdr cl))) ((null cl))
	       (do ((f (car cl) (cdr f))) ((null f))
		 (setq z (+ (si:loop-simplep-1 (car f)) z 1))))
	     z)
	  ((symbolp (car x))
	     (let ((fn (car x)) (tem ()))
	       (cond ((setq tem (get fn 'si:loop-simplep))
		        (if (fixp tem) (setq z tem)
			    (setq z (funcall tem x) x ())))
		     ((memq fn '(null not eq go return progn)))
		     (#+Run-on-PDP10
		        (or (not (minusp (+internal-carcdrp fn)))
				      (eq fn 'cxr))
		      #-Run-on-PDP10 (memq fn '(car cdr))
		        (setq z 1))
		   #-Run-on-PDP10
		     ((memq fn '(caar cadr cdar cddr)) (setq z 2))
		   #-Run-on-PDP10
		     ((memq fn '(caaar caadr cadar caddr
				 cdaar cdadr cddar cdddr))
		        (setq z 3))
		   #-Run-on-PDP10
		     ((memq fn '(caaaar caaadr caadar caaddr
				 cadaar cadadr caddar cadddr
				 cdaaar cdaadr cdadar cdaddr
				 cddaar cddadr cdddar cddddr))
		        (setq z 4))
		     ((memq fn si:loop-simplep)
		        (setq z 2))
		     (#+(or Lispm For-PDP10 For-NIL)
		        (not (eq (setq tem (macroexpand-1 x)) x))
		      #+Franz (not (eq (setq tem (macroexpand x)) x))
		      #+Multics
		        (setq tem (get (car x) 'macro))
		      #+Multics (setq tem (funcall tem x))
		      (setq z (si:loop-simplep-1 tem) x ()))
		     ('t (*throw 'si:loop-simplep ())))
	       (do ((l (cdr x) (cdr l))) ((null l))
		 (setq z (+ (si:loop-simplep-1 (car l)) 1 z)))
	       z))
	  ('t (*throw 'si:loop-simplep ())))))


; The iteration driver
(defun loop-hack-iteration (entry)
  (do ((last-entry entry)
       (source loop-source-code loop-source-code)
       (pre-step-tests ())
       (steps ())
       (post-step-tests ())
       (pseudo-steps ())
       (pre-loop-pre-step-tests ())
       (pre-loop-steps ())
       (pre-loop-post-step-tests ())
       (pre-loop-pseudo-steps ())
       (tem) (data) (foo) (bar))
      (())
    ; Note we collect endtests in reverse order, but steps in correct
    ; order.  LOOP-END-TESTIFY does the nreverse for us.
    (setq tem (setq data (apply (cadr entry) (cddr entry))))
    (and (car tem) (push (car tem) pre-step-tests))
    (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))
    (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
    (setq pseudo-steps
	  (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
    (setq tem (cdr tem))
    (and (or loop-conditionals loop-emitted-body?)
	 (or tem pre-step-tests post-step-tests pseudo-steps)
	 (let ((cruft (list (car entry) (car source)
			    (cadr source) (caddr source))))
	    (if loop-emitted-body?
		(loop-simple-error
		   "Iteration is not allowed to follow body code" cruft)
		(loop-simple-error
		   "Iteration starting inside of conditional in LOOP"
		   cruft))))
    (or tem (setq tem data))
    (and (car tem) (push (car tem) pre-loop-pre-step-tests))
    (setq pre-loop-steps
	  (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
    (and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
    (setq pre-loop-pseudo-steps
	  (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
    (cond ((or (not (si:loop-tequal (car loop-source-code) 'and))
	       (and loop-conditionals
		    (not (si:loop-tassoc (cadr loop-source-code)
					 loop-iteration-keyword-alist))))
	     (setq foo (list (loop-end-testify pre-loop-pre-step-tests)
			     (loop-make-psetq pre-loop-steps)
			     (loop-end-testify pre-loop-post-step-tests)
			     (loop-make-setq pre-loop-pseudo-steps))
		   bar (list (loop-end-testify pre-step-tests)
			     (loop-make-psetq steps)
			     (loop-end-testify post-step-tests)
			     (loop-make-setq pseudo-steps)))
	     (cond ((not loop-conditionals)
		      (setq loop-before-loop (nreconc foo loop-before-loop)
			    loop-after-body (nreconc bar loop-after-body)))
		   ('t ((lambda (loop-conditionals)
			   (push (loop-make-conditionalization
				    (cons 'progn (delq () foo)))
				 loop-before-loop))
			(mapcar '(lambda (x)	;Copy parts that will get rplacd'ed
				   (cons (car x)
					 (mapcar '(lambda (x) (loop-copylist* x)) (cdr x))))
				loop-conditionals))
		       (push (loop-make-conditionalization
			        (cons 'progn (delq () bar)))
			     loop-after-body)))
	     (loop-bind-block)
	     (return ())))
    (loop-pop-source) ; flush the "AND"
    (setq entry (cond ((setq tem (si:loop-tassoc
				    (car loop-source-code)
				    loop-iteration-keyword-alist))
		         (loop-pop-source)
			 (setq last-entry tem))
		      ('t last-entry)))))


;FOR variable keyword ..args..
(defun loop-do-for ()
  (let ((var (loop-pop-source))
	(data-type? (loop-optional-type))
	(keyword (loop-pop-source))
	(first-arg (loop-get-form))
	(tem ()))
    (or (setq tem (si:loop-tassoc keyword loop-for-keyword-alist))
	(loop-simple-error
	   "Unknown keyword in FOR or AS clause in LOOP"
	   (list 'for var keyword)))
    (lexpr-funcall (cadr tem) var first-arg data-type? (cddr tem))))


(defun loop-do-repeat ()
    (let ((var (loop-make-variable (gensym) (loop-get-form) 'fixnum)))
       `((not (> ,var 0)) () () (,var (1- ,var)))))


; Kludge the First
(defun loop-when-it-variable ()
    (or loop-when-it-variable
	(setq loop-when-it-variable
	      (loop-make-variable (gensym) () ()))))



(defun loop-for-equals (var val data-type?)
  (cond ((si:loop-tequal (car loop-source-code) 'then)
	   ;FOR var = first THEN next
	   (loop-pop-source)
	   (loop-make-iteration-variable var val data-type?)
	   `(() (,var ,(loop-get-form)) () ()
	     () () () ()))
	('t (loop-make-iteration-variable var () data-type?)
	    (let ((varval (list var val)))
	      (cond (loop-emitted-body?
		     (loop-emit-body (loop-make-setq varval))
		     '(() () () ()))
		    (`(() ,varval () ())))))))

(defun loop-for-first (var val data-type?)
    (or (si:loop-tequal (car loop-source-code) 'then)
	(loop-simple-error "found where THEN expected in FOR ... FIRST"
			   (car loop-source-code)))
    (loop-pop-source)
    (loop-make-iteration-variable var () data-type?)
    `(() (,var ,(loop-get-form)) () () () (,var ,val) () ()))


(defun loop-list-stepper (var val data-type? fn)
    (let ((stepper (cond ((si:loop-tequal (car loop-source-code) 'by)
			    (loop-pop-source) (loop-get-form))
			 ('t '(function cdr))))
	  (var1 ()) (stepvar ()) (step ()) (et ()) (pseudo ()))
       (setq step (if (or (atom stepper)
			  (not (memq (car stepper) '(quote function))))
		      `(funcall ,(setq stepvar (gensym)))
		      (list (cadr stepper))))
       (cond ((and (atom var)
		   ;; (eq (car step) 'cdr)
		   (not fn))
	        (setq var1 (loop-make-iteration-variable var val data-type?)))
	     ('t (loop-make-iteration-variable var () data-type?)
		 (setq var1 (loop-make-variable (gensym) val ()))
		 (setq pseudo (list var (if fn (list fn var1) var1)))))
       (rplacd (last step) (list var1))
       (and stepvar (loop-make-variable stepvar stepper ()))
       (setq stepper (list var1 step) et `(null ,var1))
       (if (not pseudo) `(() ,stepper ,et () () () ,et ())
	   (if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper)
	       `((null (setq . ,stepper)) () () ,pseudo ,et () () ,pseudo)))))


(defun loop-for-arithmetic (var val data-type? kwd)
  ; Args to loop-sequencer:
  ; indexv indexv-type variable? vtype? sequencev? sequence-type
  ; stephack? default-top? crap prep-phrases
  (si:loop-sequencer
     var (or data-type? 'fixnum) () () () () () () `(for ,var ,kwd ,val)
     (cons (list kwd val)
	   (loop-gather-preps
	      '(from upfrom downfrom to upto downto above below by)
	      ()))))


(defun si:loop-named-variable (name)
    (let ((tem (si:loop-tassoc name loop-named-variables)))
       (cond ((null tem) (gensym))
	     ('t (setq loop-named-variables (delq tem loop-named-variables))
		 (cdr tem)))))

#+Run-in-Maclisp ;Gross me out
(and (status feature #+Multics Compiler #-Multics complr)
     (*expr si:loop-named-variable))


; Note:  path functions are allowed to use loop-make-variable, hack
; the prologue, etc.
(defun loop-for-being (var val data-type?)
   ; FOR var BEING something ... - var = VAR, something = VAL.
   ; If what passes syntactically for a pathname isn't, then
   ; we trap to the DEFAULT-LOOP-PATH path;  the expression which looked like
   ; a path is given as an argument to the IN preposition.  Thus,
   ; by default, FOR var BEING EACH expr OF expr-2
   ; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2.
   (let ((tem) (inclusive?) (ipps) (each?) (attachment))
     (if (or (si:loop-tequal val 'each) (si:loop-tequal val 'the))
	 (setq each? 't val (car loop-source-code))
	 (push val loop-source-code))
     (cond ((and (setq tem (si:loop-tassoc val loop-path-keyword-alist))
		 (or each? (not (si:loop-tequal (cadr loop-source-code)
						'and))))
	      ;; FOR var BEING {each} path {prep expr}..., but NOT
	      ;; FOR var BEING var-which-looks-like-path AND {ITS} ...
	      (loop-pop-source))
	   ('t (setq val (loop-get-form))
	       (cond ((si:loop-tequal (car loop-source-code) 'and)
			;; FOR var BEING value AND ITS path-or-ar
			(or (null each?)
			    (loop-simple-error
			       "Malformed BEING EACH clause in LOOP" var))
			(setq ipps `((of ,val)) inclusive? 't)
			(loop-pop-source)
			(or (si:loop-tmember (setq tem (loop-pop-source))
					     '(its his her their each))
			    (loop-simple-error
			       "found where ITS or EACH expected in LOOP path"
			       tem))
			(if (setq tem (si:loop-tassoc
					 (car loop-source-code)
					 loop-path-keyword-alist))
			    (loop-pop-source)
			    (push (setq attachment `(in ,(loop-get-form)))
				  ipps)))
		     ((not (setq tem (si:loop-tassoc
					(car loop-source-code)
					loop-path-keyword-alist)))
			; FOR var BEING {each} a-r ...
			(setq ipps (list (setq attachment (list 'in val)))))
		     ('t ; FOR var BEING {each} pathname ...
			 ; Here, VAL should be just PATHNAME.
			 (loop-pop-source)))))
     (cond ((not (null tem)))
	   ((not (setq tem (si:loop-tassoc 'default-loop-path
					   loop-path-keyword-alist)))
	      (loop-simple-error "Undefined LOOP iteration path"
				 (cadr attachment))))
     (setq tem (funcall (cadr tem) (car tem) var data-type?
			(nreconc ipps (loop-gather-preps (caddr tem) 't))
			inclusive? (caddr tem) (cdddr tem)))
     (and loop-named-variables
	  (loop-simple-error "unused USING variables" loop-named-variables))
     ; For error continuability (if there is any):
     (setq loop-named-variables ())
     ;; TEM is now (bindings prologue-forms . stuff-to-pass-back)
     (do ((l (car tem) (cdr l)) (x)) ((null l))
       (if (atom (setq x (car l)))
	   (loop-make-iteration-variable x () ())
	   (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
     (setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue))
     (cddr tem)))


(defun loop-gather-preps (preps-allowed crockp)
   (do ((token (car loop-source-code) (car loop-source-code)) (preps ()))
       (())
     (cond ((si:loop-tmember token preps-allowed)
	      (push (list (loop-pop-source) (loop-get-form)) preps))
	   ((si:loop-tequal token 'using)
	      (loop-pop-source)
	      (or crockp (loop-simple-error
			    "USING used in illegal context"
			    (list 'using (car loop-source-code))))
	      (do ((z (car loop-source-code) (car loop-source-code)) (tem))
		  ((atom z))
		(and (or (atom (cdr z))
			 (not (null (cddr z)))
			 (not (symbolp (car z)))
			 (and (cadr z) (not (symbolp (cadr z)))))
		     (loop-simple-error
		        "bad variable pair in path USING phrase" z))
		(cond ((not (null (cadr z)))
		         (and (setq tem (si:loop-tassoc
					   (car z) loop-named-variables))
			      (loop-simple-error
			         "Duplicated var substitition in USING phrase"
				 (list tem z)))
			 (push (cons (car z) (cadr z)) loop-named-variables)))
		(loop-pop-source)))
	   ('t (return (nreverse preps))))))

(defun loop-add-path (name data)
    (setq loop-path-keyword-alist
	  (cons (cons name data)
		; Don't change this to use DELASSQ in PDP10, the lsubr
		; calling sequence makes that lose.
		(delq (si:loop-tassoc name loop-path-keyword-alist)
		      loop-path-keyword-alist)))
    ())

#+Run-on-PDP10
(declare ; Suck my obarray...
	 (own-symbol define-loop-path define-loop-sequence-path))

(defmacro define-loop-path (names &rest cruft)
  (setq names (if (atom names) (list names) names))
  #-For-Maclisp
    (let ((forms (mapcar #'(lambda (name) `(loop-add-path ',name ',cruft))
			 names)))
       `(eval-when (eval load compile)
	    #+For-NIL (flush-macromemos 'loop ())
	    ,@forms))
  #+For-Maclisp
    (subst (do ((l)) ((null names) l)
	     (setq l (cons `(setq loop-path-keyword-alist
				  (cons '(,(car names) . ,cruft)
					(delq (assq ',(car names)
						    loop-path-keyword-alist)
					      loop-path-keyword-alist)))
			   l)
		   names (cdr names)))
	   'progn
	   '(eval-when (eval load compile)
	     #-For-PDP10 (or (boundp 'loop-path-keyword-alist)
			      (setq loop-path-keyword-alist ()))
	     #+For-PDP10 (and (or (boundp 'loop-path-keyword-alist)
				   (setq loop-path-keyword-alist ()))
			       (flush-macromemos 'loop ()))
	       . progn)))


(defun si:loop-sequencer (indexv indexv-type
			  variable? vtype?
			  sequencev? sequence-type?
			  stephack? default-top?
			  crap prep-phrases)
   (let ((endform) (sequencep) (test)
	 (step ; Gross me out!
	       (add1 (or (loop-typed-init indexv-type) 0)))
	 (dir) (inclusive-iteration?) (start-given?) (limit-given?))
     (and variable? (loop-make-iteration-variable variable? () vtype?))
     (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
       (setq prep (caar l) form (cadar l))
       (cond ((si:loop-tmember prep '(of in))
		(and sequencep (loop-simple-error
				  "Sequence duplicated in LOOP path"
				  (list variable? (car l))))
		(setq sequencep 't)
		(loop-make-variable sequencev? form sequence-type?))
	     ((si:loop-tmember prep '(from downfrom upfrom))
	        (and start-given?
		     (loop-simple-error
		        "Iteration start redundantly specified in LOOP sequencing"
			(append crap l)))
		(setq start-given? 't)
		(cond ((si:loop-tequal prep 'downfrom) (setq dir 'down))
		      ((si:loop-tequal prep 'upfrom) (setq dir 'up)))
		(loop-make-iteration-variable indexv form indexv-type))
	     ((cond ((si:loop-tequal prep 'upto)
		       (setq inclusive-iteration? (setq dir 'up)))
		    ((si:loop-tequal prep 'to)
		       (setq inclusive-iteration? 't))
		    ((si:loop-tequal prep 'downto)
		       (setq inclusive-iteration? (setq dir 'down)))
		    ((si:loop-tequal prep 'above) (setq dir 'down))
		    ((si:loop-tequal prep 'below) (setq dir 'up)))
		(and limit-given?
		     (loop-simple-error
		       "Endtest redundantly specified in LOOP sequencing path"
		       (append crap l)))
		(setq limit-given? 't)
		(setq endform (loop-maybe-bind-form form indexv-type)))
	     ((si:loop-tequal prep 'by)
		(setq step (if (loop-constantp form) form
			       (loop-make-variable (gensym) form 'fixnum))))
	     ('t ; This is a fatal internal error...
		 (loop-simple-error "Illegal prep in sequence path"
				    (append crap l))))
       (and odir dir (not (eq dir odir))
	    (loop-simple-error
	       "Conflicting stepping directions in LOOP sequencing path"
	       (append crap l)))
       (setq odir dir))
     (and sequencev? (not sequencep)
	  (loop-simple-error "Missing OF phrase in sequence path" crap))
     ; Now fill in the defaults.
     (setq step (list indexv step))
     (cond ((memq dir '(() up))
	      (or start-given?
		  (loop-make-iteration-variable indexv 0 indexv-type))
	      (and (or limit-given?
		       (cond (default-top?
			        (loop-make-variable
				   (setq endform (gensym)) () indexv-type)
				(push `(setq ,endform ,default-top?)
				      loop-prologue))))
		   (setq test (if inclusive-iteration? '(greaterp . args)
				  '(not (lessp . args)))))
	      (push 'plus step))
	   ('t (cond ((not start-given?)
		        (or default-top?
			    (loop-simple-error
			       "Don't know where to start stepping"
			       (append crap prep-phrases)))
			(loop-make-iteration-variable indexv 0 indexv-type)
			(push `(setq ,indexv
				     (,(loop-typed-arith 'sub1 indexv-type)
				      ,default-top?))
			      loop-prologue)))
	       (cond ((and default-top? (not endform))
		        (setq endform (loop-typed-init indexv-type)
			      inclusive-iteration? 't)))
	       (and (not (null endform))
		    (setq test (if inclusive-iteration? '(lessp . args)
				   '(not (greaterp . args)))))
	       (push 'difference step)))
     (and (member (caddr step)
		  #+Loop-Small-Floatp
		    '(1 1.0 #.(and (loop-featurep Loop-Small-Floatp)
				   (small-float 1)))
		  #-Loop-Small-Floatp '(1 1.0))
	  (rplacd (cdr (rplaca step (if (eq (car step) 'plus) 'add1 'sub1)))
		  ()))
     (rplaca step (loop-typed-arith (car step) indexv-type))
     (setq step (list indexv step))
     (setq test (loop-typed-arith test indexv-type))
     (setq test (subst (list indexv endform) 'args test))
     (and stephack? (setq stephack? `(,variable? ,stephack?)))
     `(() ,step ,test ,stephack?
       () () ,test ,stephack?)))


; Although this function is no longer documented, the "SI:" is needed
; because compiled files may reference it that way (via
; DEFINE-LOOP-SEQUENCE-PATH).
(defun si:loop-sequence-elements-path (path variable data-type
				       prep-phrases inclusive?
				       allowed-preps data)
    allowed-preps ; unused
    (let ((indexv (si:loop-named-variable 'index))
	  (sequencev (si:loop-named-variable 'sequence))
	  (fetchfun ()) (sizefun ()) (type ()) (default-var-type ())
	  (crap `(for ,variable being the ,path)))
       (cond ((not (null inclusive?))
	        (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path))
		(loop-simple-error "Can't step sequence inclusively" crap)))
       (setq fetchfun (car data)
	     sizefun (car (setq data (cdr data)))
	     type (car (setq data (cdr data)))
	     default-var-type (cadr data))
       (list* () () ; dummy bindings and prologue
	      (si:loop-sequencer
	         indexv 'fixnum
		 variable (or data-type default-var-type)
		 sequencev type
		 `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev)
		 crap prep-phrases))))


#+Run-on-PDP10
(defun (define-loop-sequence-path macro) (x)
    `(define-loop-path ,(cadr x) si:loop-sequence-elements-path
	(of in from downfrom to downto below above by)
	. ,(cddr x)))

#-Run-on-PDP10
(defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun
				     &optional sequence-type element-type)
    `(define-loop-path ,path-name-or-names
	si:loop-sequence-elements-path
	(of in from downfrom to downto below above by)
	,fetchfun ,sizefun ,sequence-type ,element-type))


;;;; NIL interned-symbols path

#+For-NIL
(progn 'compile
(defun loop-interned-symbols-path (path variable data-type prep-phrases
				   inclusive? allowed-preps data
				   &aux statev1 statev2 statev3
					(localp (car data)))
   allowed-preps	; unused
   (and inclusive? (loop-simple-error
		      "INTERNED-SYMBOLS path doesn't work inclusively"
		      variable))
   (and (not (null prep-phrases))
	(or (cdr prep-phrases)
	    (not (si:loop-tmember (caar prep-phrases) '(in of))))
	(ferror () "Illegal prep phrase(s) in ~A path of ~A - ~A"
		path variable prep-phrases))
   (loop-make-variable variable () data-type)
   (loop-make-variable
      (setq statev1 (gensym))
      `(loop-find-package
	  ,@(and prep-phrases `(,(cadar prep-phrases))))
      ())
   (loop-make-variable (setq statev2 (gensym)) () ())
   (loop-make-variable (setq statev3 (gensym)) () ())
   (push `(multiple-value (,statev1 ,statev2 ,statev3)
	       (loop-initialize-mapatoms-state ,statev1 ',localp))
	 loop-prologue)
   `(() () (multiple-value (() ,statev1 ,statev2 ,statev3)
	      (,(if localp 'loop-test-and-step-mapatoms-local
		    'loop-test-and-step-mapatoms)
	       ,statev1 ,statev2 ,statev3))
     (,variable (loop-get-mapatoms-symbol ,statev1 ,statev2 ,statev3)) () ()))

(defun loop-find-package (&optional (pkg () pkgp))
  #+Run-in-Maclisp
    (if pkgp pkg obarray)
  #-Run-in-Maclisp
    (if pkgp (pkg-find-package pkg) package))

(defun loop-find-package-translate (form)
  ; Note that we can only be compiling for nil-nil, so we only need
  ; to consider that.  The run-in-maclisp conditionals in the functions
  ; are for the benefit of running interpreted code.
  (values (if (null (cdr form)) 'package `(pkg-find-package ,(cadr form))) 't))

(putprop 'loop-find-package
	 '(loop-find-package-translate)
	 'source-trans)

#-Run-in-Maclisp
(defun loop-initialize-mapatoms-state (pkg localp)
    (let* ((symtab (si:package-symbol-table pkg))
	   (len (vector-length symtab)))
       (values pkg len (if localp symtab (cons (ncons pkg) ())))))

#+Run-in-Maclisp
(defun loop-initialize-mapatoms-state (ob ())
    (values ob (ncons nil) 511.))

#-Run-in-Maclisp
(defun loop-test-and-step-mapatoms (pkg index location &aux val)
    (prog (symtab)
	 (setq symtab (si:package-symbol-table pkg))
      lp (cond ((minusp (setq index (1- index)))
		  (do ((l (si:package-super-packages pkg) (cdr l)))
		      ((null l) (cdr location))
		    (or (memq (car l) (car location))
			(memq (car l) (cdr location))
			(rplacd location (cons (car l) (cdr location)))))
		  (or (cdr location) (return (setq val 't)))
		  (rplacd location
			  (prog1 (cddr location)
				 (rplaca location
					 (rplacd (cdr location)
						 (car location)))))
		  (setq pkg (caar location))
		  (setq symtab (si:package-symbol-table pkg))
		  (setq index (vector-length symtab))
		  (go lp))
	       ((symbolp (vref symtab index)) (return ()))
	       ('t (go lp))))
    (values val pkg index location))

#+Run-in-Maclisp
(defun loop-test-and-step-mapatoms (ob list index)
    (loop-test-and-step-mapatoms-local ob list index))

#-Run-in-Maclisp
(defun loop-test-and-step-mapatoms-local (pkg index symtab &aux val)
    (prog ()
      lp (cond ((minusp (setq index (1- index))) (return (setq val 't)))
	       ((symbolp (vref symtab index)) (return ()))
	       ('t (go lp))))
    (values val pkg index symtab))

#+Run-in-Maclisp
(defun loop-test-and-step-mapatoms-local (ob list index &aux val)
    (declare (fixnum index))
    (prog () 
     lp (cond ((not (null (cdr list)))
	         (rplaca list (cadr list))
		 (rplacd list (cddr list))
		 (return ()))
	      ((minusp (setq index (1- index))) (return (setq val 't)))
	      ('t ; If this is going to run in multics maclisp also the
		  ; arraycall should be hacked to have type `obarray'.
		  (rplacd list (arraycall t ob index))
		  (go lp))))
    (values val ob list index))

#-Run-in-Maclisp
(defun loop-get-mapatoms-symbol (pkg index something-or-other)
    (declare (ignore something-or-other))
    (vref (si:package-symbol-table pkg) index))

#+Run-in-Maclisp
(defun loop-get-mapatoms-symbol (ob list index)
    (declare (ignore ob index))
    (car list))

(and #+Run-in-Maclisp (status feature complr)
     (*expr loop-get-mapatoms-symbol
	    loop-initialize-mapatoms-state
	    loop-test-and-step-mapatoms
	    loop-test-and-step-mapatoms-local))
)


;;;; Maclisp interned-symbols path

#+For-Maclisp
(defun loop-interned-symbols-path (path variable data-type prep-phrases
				   inclusive? allowed-preps data
				   &aux indexv listv ob)
   allowed-preps data	; unused vars
   (and inclusive? (loop-simple-error
		      "INTERNED-SYMBOLS path doesn't work inclusively"
		      variable))
   (and (not (null prep-phrases))
	(or (cdr prep-phrases)
	    (not (si:loop-tmember (caar prep-phrases) '(in of))))
	(loop-simple-error
	   "Illegal prep phrase(s) in INTERNED-SYMBOLS LOOP path"
	   (list* variable 'being path prep-phrases)))
   (loop-make-variable variable () data-type)
   (loop-make-variable
      (setq ob (gensym)) (if prep-phrases (cadar prep-phrases) 'obarray) ())
   ; Multics lisp does not store single-char-obs in the obarray buckets.
   ; Thus, we need to iterate over the portion of the obarray
   ; containing them also.  (511. = (ascii 0))
   (loop-make-variable
      (setq indexv (gensym)) #+Multics 639. #-Multics 511. 'fixnum)
   (loop-make-variable (setq listv (gensym)) () ())
   `(() ()
     (and #-Multics (null ,listv)
	  #+Multics (or (> ,indexv 510.) (null ,listv))
	  (prog ()
	   lp (cond ((minusp (setq ,indexv (1- ,indexv))) (return t))
		    ((setq ,listv (arraycall ; The following is the kind of
					     ; gratuity that pisses me off:
					     #+Multics obarray #-Multics t
					     ,ob ,indexv))
		       (return ()))
		    ((go lp)))))
     (,variable
       #+Multics (cond ((> ,indexv 510.) ,listv)
		       (t (prog2 () (car ,listv) (setq ,listv (cdr ,listv)))))
       #-Multics (car ,listv))
      ()
     #+Multics () #-Multics (,listv (cdr ,listv))))


;;;; Lispm interned-symbols path

#+Lispm
(progn 'compile

 (defun loop-interned-symbols-path (path variable data-type prep-phrases
				    inclusive? allowed-preps data
				    &aux statev1 statev2 statev3
					 (localp (car data)))
    path data-type allowed-preps			; unused vars
    (and inclusive? (loop-simple-error
		       "INTERNED-SYMBOLS path doesn't work inclusively"
		       variable))
    (and (not (null prep-phrases))
	 (or (cdr prep-phrases)
	     (not (si:loop-tmember (caar prep-phrases) '(in of))))
	   (ferror () "Illegal prep phrase(s) in ~A path of ~A - ~A"
		   path variable prep-phrases))
    (loop-make-variable variable () data-type)
    (loop-make-variable
       (setq statev1 (gensym))
       (if prep-phrases `(pkg-find-package ,(cadar prep-phrases)) 'package)
       ())
    (loop-make-variable (setq statev2 (gensym)) () ())
    (loop-make-variable (setq statev3 (gensym)) () ())
    (push `(multiple-value (,statev1 ,statev2 ,statev3)
		  (loop-initialize-mapatoms-state ,statev1 ,localp))
	    loop-prologue)
    `(() () (multiple-value (nil ,statev1 ,statev2 ,statev3)
	       (,(if localp 'loop-test-and-step-mapatoms-local
		     'loop-test-and-step-mapatoms)
		,statev1 ,statev2 ,statev3)) 
      (,variable (loop-get-mapatoms-symbol ,statev1 ,statev2 ,statev3))
      () ()))

 (defun loop-initialize-mapatoms-state (pkg localp)
    ; Return the initial values of the three state variables.
    ; This scheme uses them to be:
    ; (1)  Index into the package (decremented as we go)
    ; (2)  Temporary (to hold the symbol)
    ; (3)  the package
    localp ; ignored
    (prog ()
       (return (array-dimension-n 2 pkg) () pkg)))

 (defun loop-test-and-step-mapatoms (index temp pkg)
    temp ; ignored
    (prog ()
     lp (cond ((< (setq index (1- index)) 0)
	         (cond ((setq pkg (pkg-super-package pkg))
			  (setq index (array-dimension-n 2 pkg))
			  (go lp))
		       (t (return t))))
	      ((numberp (ar-2 pkg 0 index))
	         (return nil index (ar-2 pkg 1 index) pkg))
	      (t (go lp)))))

 (defun loop-test-and-step-mapatoms-local (index temp pkg)
    temp ; ignored
    (prog ()
     lp (cond ((minusp (setq index (1- index))) (return t))
	      ((numberp (ar-2 pkg 0 index))
	         (return () index (ar-2 pkg 1 index) pkg))
	      (t (go lp)))))

 (defun loop-get-mapatoms-symbol (index temp pkg)
    index pkg ; ignored
    temp)
 )

; We don't want these defined in the compilation environment because
; the appropriate environment hasn't been set up.  So, we just bootstrap
; them up.
(mapc '(lambda (x)
	  (mapc '(lambda (y)
		    (setq loop-path-keyword-alist
			  (cons (cons y (cdr x))
				(delq (si:loop-tassoc
				         y loop-path-keyword-alist)
				      loop-path-keyword-alist))))
		(car x)))
      '(
      #+(or For-NIL For-Maclisp Lispm)
	((interned-symbols interned-symbol)
	   loop-interned-symbols-path (in))
      #+(or For-NIL Lispm)
	((local-interned-symbols local-interned-symbol)
	   loop-interned-symbols-path (in) t)
	))

#-Multics ; none defined yet
(mapc '(lambda (x)
	 (mapc '(lambda (y)
		  (setq loop-path-keyword-alist
			(cons `(,y si:loop-sequence-elements-path
				(of in from downfrom to downto below above by)
				. ,(cdr x))
			      (delq (si:loop-tassoc
				      y loop-path-keyword-alist)
				    loop-path-keyword-alist))))
	       (car x)))
      '(#+Lispm
        ((array-element array-elements) aref array-active-length)
	; These NIL guys are set up by NILAID in the PDP10 version but no one
	; sets them up on the VAX.  Anyway redundancy won't hurt unless i
	; break something.
	#+(and For-NIL (not Run-in-Maclisp))
	  ((vector-element vector-elements) vref vector-length vector)
        #+(and For-NIL (not Run-in-Maclisp))
	  ((bit bits) bit bits-length bits fixnum)
	#+(and For-NIL (not Run-in-Maclisp))
	  ((character characters) char string-length string character)
	)
      )

; Sigh. (c.f. loop-featurep, note macro-expansion lossage.)
; Note that we end up doing both in the PDP10 NIL version.
#+(or (not For-NIL) Run-in-Maclisp)
  (or (status feature loop) (sstatus feature loop))
#+For-NIL
  (set-feature 'loop 'local)




		    lisp_macro_macros_.lisp         07/06/83  0938.4r w 06/29/83  1543.0       11907



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

(%include defmacro)

;; Macros used in the definition of other macros.

(defmacro once-only (vars . body)
   (setq vars (reverse vars))
   (do ((l vars (cdr l))
        (nils nil (cons nil nils))
        (bind-vars (gensym))
        (bind-vals (gensym))
        (tem (gensym)))
       ((null l)
        `((lambda (,bind-vars ,bind-vals)
	   ((lambda (result)
		  (cond ((null ,bind-vars)
		         result)
		        (t
			`((lambda ,,bind-vars ,result) . ,,bind-vals))))
	    ((lambda ,vars
		   . ,body)
	     . ,(do ((l vars (cdr l))
		   (inits nil (cons `(cond ((atom ,(car l))
				        ,(car l))
				       (t
				         (let ((,tem (gensym)))
					    (setq ,bind-vars (cons ,tem ,bind-vars))
					    (setq ,bind-vals (cons ,(car l) ,bind-vals))
					    ,tem)))
				inits)))
		  ((null l) (nreverse inits))))))
	nil
	nil))
       (or (symbolp (car l))
	 (error "Not a symbol (ONCE-ONLY): " (car l)))))

(sstatus feature macro_macros)




		    lisp_other_other_.lisp          07/06/83  0938.4r w 06/29/83  1543.0      101007



;;; **************************************************************
;;; *                                                            *
;;; * 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)




		    lisp_runtime_.lisp              07/06/83  0938.4r w 06/29/83  1543.0       66159



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

(%include sharpsign)
(%include defun)
(%include other_other)

;; Function cell manipulators

(defconst functional-properties-list 
	'(subr lsubr fsubr expr fexpr array macro autoload))

(defun fboundp (symbol)
  (if (getl symbol functional-properties-list) t))

(defun fmakunbound (symbol)
  (mapc (function (lambda (property) (remprop symbol property)))
        functional-properties-list)
  t)

(defun fsymeval (symbol)
  (let ((plist (getl symbol functional-properties-list)))
       (if (eq (car plist) 'macro)
	 (cons 'macro (cadr plist))
	 (cadr plist))))

(defun fset (symbol object)
  (fmakunbound symbol)
  (cond ((symbolp object)
         (putprop symbol object 'expr))         
        ((atom object)
         (putprop symbol object 'subr))
        ((eq (car object) 'macro)
         (putprop symbol (cdr object) 'macro))
        ((eq (car object) 'lambda)
         (putprop symbol object 'expr))
        (t (error "Random functional object - FSET"
	        object 'wrng-type-arg))))

;; Byte operations

(defun ldb (ppss x)
  (boole 1 (1- (lsh 1 (boole 1 77 ppss)))
         (lsh x (- 0 (boole 1 77 (lsh ppss -6))))))

(defun dpb (x ppss y)
  (let ((pp (boole 1 77 (lsh ppss -6)))
        (m (1- (lsh 1 (boole 1 77 ppss)))))
       (boole 7 (boole 2 (lsh m pp) y)
	    (lsh (boole 1 m x) pp))))

;; Lisp Machine list manipulation functions

(defun firstn (n list)
  (declare (fixnum n))
  (do ((old-list list (cdr old-list))
       (new-list nil (cons (car old-list) new-list))
       (count n (1- count)))
      ((zerop count) (nreverse new-list))))

(defun butlast (list)
  ;; (check-arg list (or (null list) (not (atom list))) "a list")
  (cond ((null list) nil)
        (t (do ((list list (cdr list))
              (new-list nil (cons (car list) new-list)))
             ((null (cdr list)) (nreverse new-list))))))

(defun nbutlast (list)
  ;; (check-arg list (or (null list) (not (atom list))) "a list")
  (cond ((null list) nil)
        (t (do ((list list (cdr list)))
             ((null (cddr list)) (rplacd list nil)))
         list)))

;; Thus must understand the ':initial-value keyword to be
;; compatible with the current Lispm definition.

(defun make-list (n &optional entry)
  (declare (fixnum n))
  (do ((list nil (push entry list)))
      ((= n 0) list)
      (setq n (1- n))))

;; MEM works like MEMQ and MEMBER except that it can take an arbitrary
;; comparison predicate, i.e. (MEM 'EQ 3 LIST) = (MEMQ 3 LIST).

(defun mem (predicate element list)
  ;; (check-arg list (or (null list) (not (atom list))) "a list")
  (do ((list list (cdr list)))
      ((null list) nil)
      (if (funcall predicate element (car list)) (return t))))

;; FIND-POSITION-IN-LIST looks down LIST for an element which is eq to OBJECT,
;; like MEMQ.  It reutrns the numeric index in the list at which it found the
;; first occurrence of OBJECT, or nil if it did not find it at all.
;; (find-position-in-list 'a '(a b c)) --> 0
;; (find-position-in-list 'e '(a b c)) --> nil

(defun find-position-in-list (object list)
  ;; (check-arg list (or (null list) (not (atom list))) "a list")
  (do ((l list (cdr l))
       (i 0 (1+ i)))
      ((null l) nil)
      (declare (fixnum i))
      (if (eq object (car l)) (return i))))

;; Generalized ASSOC -- first argument is a comparison predicate which
;; is used instead of EQUAL.

(defun ass (predicate item alist)
  ;; (check-arg alist (or (null alist) (not (atom alist)))
  ;;            "an association list")
  (dolist (pair alist)
          (if (funcall predicate item (car pair)) (return pair))))

;; Reverse ASSQ -- like ASSQ but tries to find an element of the alist whose
;; cdr (not car) is EQ to the object.

(defun rassq (item alist)
  ;; (check-arg alist (or (null alist) (not (atom alist)))
  ;;            "an association list")
  (dolist (pair alist)
          (if (eq item (cdr pair)) (return pair))))

;; Reverse ASSOC -- like ASSOC but tries to find an element of the alist
;; whose cdr (not car) is EQUAL to the object.

(defun rassoc (item alist)
  ;; (check-arg alist (or (null alist) (not (atom alist)))
  ;;          "an association list")
  (dolist (pair alist)
          (if (equal item (cdr pair)) (return pair))))

;; REM, REMQ, REMOVE are non-destructive versions of DEL, DELQ, DELETE.
;; These algorithms could be made more efficient by sharing the tail of the
;; returned list with the original.

(defun rem (predicate item list &optional (count -1))
  (do ((l list (cdr l))
       (result nil))
      ((null l) (nreverse result))
      (if (or (not (funcall predicate item (car l))) (zerop count))
	(push (car l) result)
	(decf count))))

(defun remq (item list &optional (count -1))
  (do ((l list (cdr l))
       (result nil))
      ((null l) (nreverse result))
      (if (or (neq item (car l)) (zerop count))
	(push (car l) result)
	(decf count))))

(defun remove (item list &optional (count -1))
  (do ((l list (cdr l))
       (result nil))
      ((null l) (nreverse result))
      (if (or (nequal item (car l)) (zerop count))
	(push (car l) result)
	(decf count))))

;; This algorithm works in two steps.  First cdr down the list to find the
;; cons we are going to return or until we reach the end of the list.
;; When we find the cons to return, cdr down from there splicing out
;; appropriate cons cells.

(defun del (predicate item list &optional (count -1))
  (do ()
      ((null list) nil)
      (cond ((and (not (zerop count)) (funcall predicate item (car list)))
	   (pop list)
	   (decf count))
	  (t (return nil))))
  (do ((first list)
       (second (cdr list)))
      ((null second))
      (cond ((and (not (zerop count)) (funcall predicate item (car second)))
	   (rplacd first (cdr second))
	   (decf count))
	  (t (pop first)))
      (pop second))
  list)

;; (circular-list-last (circular-list 1 2 3)) --> (3 1 2 3 1 2 ...)
;; Useful for manipulating kill-rings implemented as circular lists.
;; Provides the inverse operation of cdr.

(defun circular-list-last (list)
  (do ((previous list (cdr previous))
       (next (cdr list) (cdr next)))
      ((or (null next) (eq next list))
       previous)))

;; For PDP10 MacLisp compatibility.  Try to use something else if you can.

(defun symbolconc (&rest rest)
  (make_atom (apply (function catenate) rest)))

;; Note: bignum-ash and fixnum-ash are not standard MacLisp or ZetaLisp
;; functions.  Bignum-ash is compatible with the ZetaLisp.  Fixnum-ash is
;; compatible with PDP10 MacLisp.  (defprop ash fixnum-ash expr) if you want
;; ash to mean the fixnum definition rather than the bignum definition.

(defun bignum-ash (x b)
  (if (minusp b)
      (if (minusp x)
	(sub1 (quotient (add1 x) (expt 2 (minus b))))
	(quotient x (expt 2 (minus b))))
      (times x (expt 2 b))))

(defun fixnum-ash (x b)
  (declare (fixnum x b))
  (if (minusp b)
      (if (minusp x)
	(logxor -1 (lsh (logxor -1 x) b))
	(lsh x b))
      (logior (logand #.(rot 1 -1) x)
	    (logand #.(lsh -1 -1) (lsh x b)))))

(defprop ash bignum-ash expr)




		    lisp_setf_.lisp                 07/06/83  0938.4r   06/29/83  1543.1       25146



;; -*- 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)




		    lisp_sharpsign_.lisp            07/06/83  0938.4r w 06/29/83  1543.1       55485



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

;; Lisp Machine sharpsign reader macro
;; Written:	May 1980 by Alan Bawden
;; Modified:	June 1981 by Carl Hoffman and Richard Lamson to remove
;;		defmacro dependencies for installation.
;;		October 1982 by Carl Hoffman and Richard Lamson for
;;		installation in bound_lisp_library_

(%include backquote)

(declare (special sharpsign-data-list))
(setq sharpsign-data-list nil)

(defun sharpsign-set-syntax (ch type fun)
  (cond ((numberp ch))
        ((or (symbolp ch)
	   (stringp ch))
         (setq ch (CtoI ch)))
        (t (error "sharpsign-set-syntax: Not a character - " ch 'fail-act)))
  (or (memq type '(macro peek splicing peek-macro peek-splicing nil))
      (error "sharpsign-set-syntax: Not a valid type - " ch 'fail-act))
  (or (< ch 141)			;#/a
      (> ch 172)			;#/z
      (setq ch (- ch 40)))		;upper case it.
  (let ((peekp   (not (null (memq type '(peek peek-macro peek-splicing)))))
        (splicep (not (null (memq type '(splicing peek-splicing)))))
        (tem     (assoc ch sharpsign-data-list)))
       (cond ((or (null fun) (null type))
	    (or (null tem)
	        (setq sharpsign-data-list (delq tem sharpsign-data-list))))
	   ((null tem)
	    (setq sharpsign-data-list
		`((,ch ,peekp ,splicep . ,fun) . ,sharpsign-data-list)))
	   (t (rplacd tem `(,peekp ,splicep . ,fun))))))

(defun sharpsign-reader-macro ()
 (do ((ch) (arg nil))
     (nil)
   (setq ch (tyipeek))
   (cond ((not (or (< ch 60)			;#/0
	         (> ch 71)))		;#/9
	(tyi)
	(cond ((null arg) (setq arg (- ch 60)))
	      (t (setq arg (+ (* arg 10.) (- ch 60))))))
         (t (cond ((not (null arg)))
	        ((= ch 2)
	         (tyi)
	         (setq ch (tyipeek))
	         (setq arg 'control))
	        ((= ch 3)
	         (tyi)
	         (setq ch (tyipeek))
	         (setq arg 'meta))
	        ((= ch 6)
	         (tyi)
	         (setq ch (tyipeek))
	         (setq arg 'control-meta)))
	  (or (< ch 141)		;#/a
	      (> ch 172)		;#/z
	      (setq ch (- ch 40)))	;upper case it.
	  (let ((x (assoc ch sharpsign-data-list)))
	   (and (null x)
	    (error "sharpsign-reader-macro: Unknown character following # - "
		 (ItoC ch) 'fail-act))
	   (and (null (cadr x)) (tyi))
	   (return
	     (cond ((null (caddr x))
		  (list (funcall (cdddr x) arg)))
		 (t (funcall (cdddr x) arg)))))))))

;; Defsharp is used by this file at eval/compile time.  We also place
;; the macro in the object segment for the benefit of users who wish
;; to extend the sharpsign syntax.

(declare (macros t))

(eval-when (eval load compile)
  (defprop defsharp defsharp-macro macro)
  (defun defsharp-macro (form)
    (let ((ch   (cadr form))
	(type (caddr form))
	(args (cadddr form))
	(body (cddddr form)))
       (let ((name (intern (make_atom (catenate "sharpsign-" ch "-macro")))))
	  `(progn 'compile
		(sharpsign-set-syntax ',ch ',type ',name)
		(defun ,name ,args . ,body))))))

(defsharp // macro (arg) arg ;Ignored
	(tyi))
	
(defsharp /M splicing (arg) arg ;Ignored
	nil)

(defsharp /Q splicing (arg) arg ;Ignored
	(read)
	nil)

(defsharp /N splicing (arg) arg ;Ignored
	(read)
	nil)

(defsharp /R macro (arg)
	(or (numberp arg)
	    (error "#<digits>R please, not: " arg 'fail-act))
	(let ((ibase arg))
	     (read)))

(defsharp /O macro (arg) arg ;Ignored
	(let ((ibase 8.)) (read)))

(defsharp /D macro (arg) arg ;Ignored
	(let ((ibase 10.)) (read)))

;; This doesn't work completely since a sequence of letters and digits
;; will be read as a symbol rather than a fixnum, i.e. "#x 10" reads as 16
;; decimal, but "#x A" reads as the symbol A.  Perhaps this is what
;; the (sstatus + t) is trying to fix? -cwh

(defsharp /X macro (arg) arg ;Ignored
	(unwind-protect
	  (let ((ibase 16.))
	       (sstatus + t)
	       (read))
	  (sstatus + nil)))

(defsharp /' macro (arg) arg ;Ignored
	(list 'function (read)))

(defsharp /. macro (arg) arg ;Ignored
	(eval (read)))

(declare (special gofoo compiler-state))

(defsharp /, macro (arg) arg ;Ignored
	(cond ((and (boundp 'compiler-state) compiler-state)
	       (cons (read) gofoo))
	      (t (eval (read)))))

(defsharp /# macro (arg) arg ;Ignored
	(error "Barf! ## is obsolete, you should use #/  " nil 'fail-act))

(defsharp /^ macro (arg) arg ;Ignored
	(boole 1 37 (tyi)))

(declare (special sharpsign-character-alist))

(setq sharpsign-character-alist
      '(("null" . 0)
        ("bell" . 7)
        ("bs" . 10) ("backspace" . 10)
        ("tab" . 11)
        ("lf" . 12) ("linefeed" . 12) ("newline" . 12)
        ("vt" . 13)
        ("ff" . 14) ("form" . 14) ("formfeed" . 14)
        ("return" . 15) ("cr" . 15)
        ("altmode" . 33) ("alt" . 33) ("escape" . 33) ("esc" . 33)
        ("space" . 40) ("sp" . 40)  
        ("help" . 77)
        ("delete" . 177) ("rubout" . 177)))

(defsharp /\ macro (arg) arg ;Ignored
  (let ((name (get_pname (read))))
    (cdr (or (assoc name sharpsign-character-alist)
	   (error "Unknown symbolic name following #\ - " name 'fail-act)))))

(defsharp /+ splicing (arg) arg ;Ignored
	(or (sharpsign-feature-test (read))
	    (read))
	nil)

(defsharp /- splicing (arg) arg ;Ignored
	(and (sharpsign-feature-test (read))
	     (read))
	nil)

(defun sharpsign-feature-test (frob)
  (cond ((atom frob)
         (apply 'status `(feature ,frob)))
        ((eq (car frob) 'and)
         (do ((l (cdr frob) (cdr l)))
	   ((atom l) t)
	   (or (sharpsign-feature-test (car l))
	       (return nil))))
        ((eq (car frob) 'or)
         (do ((l (cdr frob) (cdr l)))
	   ((atom l) nil)
	   (and (sharpsign-feature-test (car l))
	        (return t))))
        ((eq (car frob) 'not)
         (not (sharpsign-feature-test (cadr frob))))
        (t (error "sharpsign-feature-test: Bad form after #+ or #- - "
	        frob 'fail-act))))

(setsyntax '/# 'splicing 'sharpsign-reader-macro)

(sstatus feature sharpsign)




		    lisp_trace_.lisp                07/06/83  0938.4r w 06/29/83  1543.1      146376



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 *
;;; *                                                            *
;;; **************************************************************
;;  ************************************************************
;;  **** MACLISP **** LISP FUNCTION TRACING PACKAGE (TRACE) ****
;;  ************************************************************
;;  * (C) COPYRIGHT 1974 MASSACHUSETTS INSTITUTE OF TECHNOLOGY *
;;  ***** THIS IS A READ-ONLY FILE!  (ALL WRITES RESERVED) *****
;;  ************************************************************

;; Trace package now works in both Multics and PDP-10 lisp.


;; REVISIONS:
;;  45		(Rick Grossman, 12/74)
;;	Replace the trac1 template with compilable code.
;;	Flush trprint in favor of new trace-printer.
;;	Make trace, remtrace, untrace compilable.
;;	Improve trace-edsub so that this will work:
;;	 (trace y (x wherein y)), and similarly untrace.
;;	 Note that (trace (y wherein z) (x wherein y))
;;	 still partially loses.
;;	Have untrace return only the list of actually
;;	 previously traced functions.
;;  46		(Rick Grossman, 1/75)
;;	Add trace-indenter as default print function.
;;	Fix bug:  (.. value ..) also printed the arg.
;;	Put "break" condition within scope of the "cond" one.
;;	Fix bug:  (trace (foo cond bar1 value)) lost
;;	 because trace*g4 was referenced in "value"
;;	 but never set.
;;	Fix bug:  If FEXPR or MACRO is an atom, loses.
;;	Clean up some of the duplicate trace-1 code.
;;	Add TRACE-OK-FLAG to prevent tracing calls by trace.
;;	Flush definition of PLIST.
;;	Change ADD1 to 1+.
;;	Replace MIN with open-compilable COND.
;;	Flush excess consing in trace-indenter call.
;;  50		(JONL, 1/75)
;;	Try to merge Moons hackery with Grossman's latest stuff
;; 	Add function BREAK-IN
;;	Fix bug in TRACE-INDENTER s.t. if TRACE-INDENTATION
;;	 ever goes to zero, then simply skip indentation.
;;  51		(JONL, 2/75)
;;	Use the PRIN1 variable in TRACE-INDENTER.
;;  52		(GROSS, 2/75)
;;	Lambda-bind TRACE-INDENTATION (and use a gensym name).
;;  53		(MOON Feb. 25, 1975)
;;	Take break out from control of cond, dammit!!
;;	This is the only way to break on condition without
;;	printing a lot of garbage; also it's a documented feature.

;; Note:  When adding new functions to this file,
;;	  be sure to put their names in the list in REMTRACE.


(%include backquote)


(declare 
 (macros nil) 
 (mapex t)
 (setq nfunvars t)
 (special trace-olduuo traced-stuff prin1
  trace*g1 trace*g2 trace*g4 trace*g5
  trace*copies trace*subr-args trace-printer trace-ok-flag
  trace-break-fun trace-indent-incr trace-indent-max)
 (fixnum ng)
 (*fexpr trace untrace))

(defun macex macro (x) 
       (list 'defun (cadr x) 'macro (caddr x) 
	   (eval (cadddr x))))

(macex newlineseq (x)
       (cond
         ((status feature Multics) ''(list (ascii 10.))) 
         (t ''(list (ascii 13.) (ascii 10.)))))
 

(macex version (x) 
       (subst
         (maknam (nconc (newlineseq) 
		    (explodec '/;loading/ trace/ ) 
		    (explodec
		      (cond
		        ((status feature newio) (caddr (names infile))) 
		        ((cadr (status uread)))))
		    (newlineseq)))
         'version
         ''(or (status feature noldmsg)
	     (iog vt (princ 'version) (ascii 0.)))))


(version)


(and (getl 'remtrace '(fsubr fexpr)) (remtrace)) 

(and (not (boundp 'trace-printer))
 (setq trace-printer 'trace-indenter) ) 
(and (not (boundp 'trace-break-fun))
     (setq trace-break-fun 'break))

(setq trace-olduuo nouuo traced-stuff nil trace-ok-flag t) 
;; The flag  trace-ok-flag  is bound NIL inside all trace fns.

(sstatus feature trace) 

(setq
  trace*subr-args
  (list (gensym) (gensym) (gensym) (gensym) (gensym))
  trace*g1 (gensym) trace*g2 (gensym)
  trace*g4 (gensym) trace*g5 (gensym))

;; Initial indentation.
(set trace*g5 0)



;; Define remtrace first in case the loading does not finish.

(defun remtrace ()
       (prog (trace-ok-flag y) 
	   (errset (untrace)) 
	   (mapc '(lambda (x) 
		        (do nil
			  ((null (setq y (getl x '(expr fexpr subr fsubr)))))
			  (remprop x (car y)) ) ) 
	         '(trace untrace remtrace untrace-1 trace-edsub
		       trace-indenter break-in ) ) 
	   (nouuo trace-olduuo) 
	   (sstatus nofeature trace) 
	   (gctwa)))


(defun untrace fexpr (l) 
       (prog (trace-ok-flag) 
	   (cond
	     (l (setq l (mapcan '(lambda (x) (and (untrace-1 x) (list x))) l)))  
	     ((setq l (mapcar 'untrace-1 (trace))) 
	      (and traced-stuff (progn (print 'lossage) (print (trace))))))
	   (and (null traced-stuff) (nouuo trace-olduuo))
	   (return l)))   


(defun untrace-1 (x) 
  (prog (y ret) 
    a 	(cond ((null (setq y (assoc x traced-stuff))) (return ret)) 
	      ((atom (car y)) 
		(and (eq (get (car y) (caddr y)) (cadddr y)) 
		     (remprop (car y) (caddr y)))) 
	      (t (trace-edsub (cons (caddr y) (caar y)) 
			      (caddar y) 
			      (cadr y)))) 
	(setq traced-stuff (delq y traced-stuff)) 
	(setq ret x)
	(go a))) 


(defun trace-edsub (pair sym ind)
       (prog (y z) 
	   ;; Return NIL if lose.
	   (and (setq y (assq sym traced-stuff)) 
	        (eq ind (caddr y)) 
	        (setq z (getl sym (list ind))) 
	        (eq (cadddr y) (cadr z)) 
	        ;; We want to munge the original definition,
	        ;; not the trace kludgery.
	        ;; Note that this partially loses for traced macros,
	        ;; since we munge the macro property, not the
	        ;; trace-generated fexpr one.
	        (setq sym (cdr z)) ) 
	   (return
	     (cond 
	       ((setq y (get sym ind)) 
	        (putprop sym (sublis (list pair) y) ind) ) ) ) )) 




;; Define the code to produce the trace stuff.
 


(defun trace-1 macro (dummy) 
       '(let ((t1 nil)
	    (in-vals nil))
	   (sublis trace*copies
		 `(lambda ,(cond (c) (gg) (g (car g)) (trace*g1))
			((lambda
			   (,trace*g2
			     ,trace*g1
			     ,@(cond ((null q) `(,y)))
			     ,@(cond (f `(,trace*g4)))
			     ,@(cond (p `(,p)))
			     ,@(cond ((eq print 'trace-indenter)`(,trace*g5))))
			   ,@(and f `((setq ,trace*g4 ,(car f))))
			   ,@(cond 
			       ((or ne (memq (car m) '(arg both))) 
			        (setq t1 (cond
				         ((eq print 'trace-indenter) 
					`(,print ,y 'enter ',x 
					         ,(cond
						  ((memq (car m) '(arg both)) trace*g2) 
						  (t `',trace*g2))
					         ,(and (or n ne)
						     `(list ,@ne ,@n))
					         ,trace*g5))
				         (t `(,print 
					     (list ,y
						 'enter
						 ',x
						 ,@(cond
						     ((memq (car m) '(arg both)) 
						      `(,trace*g2)))
						 ,@ne
						 ,@n)))))
			        (cond
				((or f fe) 
				 ;; There is a COND or ENTRYCOND
				 `((and
				     ,@(and f `(,trace*g4))
				     ,@(and fe `(,(car fe)))
				     ,t1)))
				(t `(,t1))))) 
			   ,@(and break
				`(,(cond ((eq trace-break-fun 'break)
					`(break ,y ,break))
				         (t `(and ,break (,trace-break-fun ',x))))))
			   ,(cond (q `(apply ',y ,trace*g2))
				(t `(setq ,trace*g1 (apply ',y ,trace*g2))))
			   ,@(cond ((and (null q)
				       (or nx (memq (car m) '(value both)))) 
				  (setq t1
				        (cond
					((eq print 'trace-indenter) 
					 `(,print ,y 'exit ',x 
						,(cond
						   ((memq (car m) '(value both)) trace*g1) 
						   (t `',trace*g2))
						,(and (or n nx)
						      `(list ,@nx ,@n))
						,trace*g5)) 
					(t `(,print
					      (list ,y
						  'exit
						  ',x
						  ,@(cond
						      ((memq (car m) '(value both)) 
						       `(,trace*g1)))
						  ,@nx
						  ,@n)))))
				  (cond
				    ((or f fx) 
				     ;; There is a COND or EXITCOND
				     `((and
				         ,@(and f `(,trace*g4))
				         ,@(and fx `(,(car fx)))
				         ,t1)))
				    (t `(,t1)))))
			   ,@(cond ((null q) `(,trace*g1))))
			 ;; lambda args
			 ,(setq in-vals
			        (cond
				(c (car c)) 
				(gg `(listify ,gg)) 
				(g `(list ,@(car g))) 
				(t `(listify ,trace*g1))))
			 nil
			 ,@(cond ((null q) `((1+ ,y))))
			 ,@(cond (f `(nil)))
			 ,@(cond
			     ;;ARGPDL stuff
			     (p `((cons (list ,@(cond ((null q)
						 `((1+ ,y))))
					  ',y
					  ,in-vals)
				      ,p))))
			 ,@(cond ((eq print 'trace-indenter)
				`((+ ,trace*g5 trace-indent-incr)))))))))



;;	c is non-nil for f-type, holds lambda list 
;;	 cm = (MACRO (LAMBDA ...) ...) if macro.
;;	g is non-nil for expr type, (car g) is lambda list ;
;;	not c or g => l-form
;;	 gg = lexpr variable (if nil, is lsubr).
;;	q if non-nil means the function is go, throw, etc.,
;;	 so no return values (etc.) will be hacked.

;;	n holds list of extra quantities for typeout

;;	traced-stuff =
;;		list of currently traced stuff, typically
;;		((a 'trace 'expr newexpr) ...)
;;		(((a 'wherein b) 'expr g0003) ...)

;;	x = tracee
;;	y = new symbol for tracee
;;	m = (BOTH/ARGS/VALUE/NIL . stuff-to-print)
;;	Keyword values:
;;	 f:	COND
;;	 fe:	ENTRYCOND
;;	 fx:	EXITCOND
;;	 p:	ARGPDL
;;	 break:	BREAK
;;	 b:	(foo WHEREIN bar)
;;	 ne:	ENTRY
;;	 nx:	EXIT

;; Obscure functions:
;;	qu*	Expand a quoted list, hacking:
;;		(EV frob)	eval the frob, & use result;
;;		(EV* frob)	eval, & splice the result in.
;;
;;	trace-edsub	(pair atom ind):  Do sublis on the
;;					atom's property.
;;		This is used for WHEREIN substitution.


(defun break-in fexpr (l)
  (apply 'trace 
	 (mapcan '(lambda (x) (list (cons x '(break t))))
		 l)))

(defun trace fexpr (l) 
 (cond
  ((null l) (mapcar 'car traced-stuff)) 
  (t
   (prog2 nil
    (mapcan 
     '(lambda (c)
       (prog 
        (x y g gg n ne nx m break f fe fx b p q cm sube
         print getl trace-ok-flag ) 
        (setq print trace-printer) 
        (cond
         ((atom c) (setq x c c nil)) 
         (t
          (setq x (car c)) 
          (setq c (cdr c)) 
          (or (atom x)
	   ;; hack list of functions
           (return (mapcar (function (lambda (x) 
               (car (apply 'trace (list (cons x c)))) )) 
             x )) ) ) )  
        (or
         (setq getl
           (getl x '(fexpr fsubr expr subr lsubr macro)) ) 
         (return (ncons (list '? x 'not 'function))) ) 
        (or (atom (cadr getl)) (eq (caadr getl) 'lambda) 
         (return
          (ncons (list '? x 'bad (car getl) 'definition)) ) )  
        (go y) 
        l
        (setq c (cdr c)) 
        l1
        (setq c (cdr c)) 
        y
        (cond
         ((null c) (setq m '(both)) (go x)) 
         ((eq (car c) 'grind) 
          (setq print 'sprinter) (go l1) ) 
         ((eq (car c) 'break) 
          (setq break (cadr c)) 
          (go l) ) 
         ((eq (car c) 'cond) 
          (setq f (cdr c)) 
          (go l) ) 
         ((eq (car c) 'entrycond) 
          (setq fe (cdr c)) 
          (go l) ) 
         ((eq (car c) 'exitcond) 
          (setq fx (cdr c)) 
          (go l) ) 
         ((memq (car c) '(arg value both nil)) 
          (setq m c)
	  (go x) ) 
         ((eq (car c) 'wherein) 
          (cond
           ((or (not (atom (cadr c))) 
             (null
              (setq y
               (getl (cadr c) '(expr fexpr macro)) ) ) ) 
            (go wherein-loss) ) )  
          (untrace-1 (setq g (list x 'wherein (cadr c)))) 
          (setq traced-stuff
           (cons
            (list g
             (car y) 
             (setq n (copysymbol x nil)) ) 
            traced-stuff ) ) 
	  (setplist n (plist x))
	  (or
           (trace-edsub (cons x n)
	    (cadr c)
	    (car y))
	   ;; This can lose if the EXPR, FEXPR, or MACRO found
	   ;; above is really a tracing frob!  Hence:
	   (go wherein-loss) )
          (setq b g) 
          (setq x n) 
          (go l) ) 
         ((eq (car c) 'argpdl) 
          (cond
           ((and (setq p (cadr c)) (eq (typep p) 'symbol)) 
            (set p nil) 
            (go l) ) 
           ((return (ncons (list '? 'argpdl p)))) ) ) 
         ((eq (car c) 'entry) 
          (setq ne (cons ''/|/| (cadr c))) 
          (go l) ) 
         ((eq (car c) 'exit) 
          (setq nx (cons ''/|/| (cadr c))) 
          (go l) ) 
         ((return (ncons (list '? (car c))))) ) 
	wherein-loss
	(return (ncons (list '? 'wherein (cadr c))))
        x
	(untrace-1 x) 
        (cond
         ((setq q (memq x '(go return err throw))) 
          (cond
           ((eq (car m) 'value) 
            (setq m (cons nil (cdr m))) ) 
           ((eq (car m) 'both) 
            (setq m (cons 'arg (cdr m))) ) ) ) ) 
        ;; copy atom in way that works in any lisp.
        (set (setplist (setq y (copysymbol x nil)) nil) 0) 
        ;; transfer property list to new trace atom
        (setplist y (nconc (plist y) (plist x))) 
        ;;
        (setq c
         (cond
          ((memq (car getl) '(fexpr macro)) 
           (cond
            ((atom (cadr getl)) (list trace*g1)) 
            ((cadr (cadr getl))	) ) )  
          ((eq (car getl) 'fsubr) (list trace*g1)) ) ) 
        (setq cm (cond ((eq (car getl) 'macro) getl))) 
        (setq g
         (cond
          ((eq (car getl) 'expr) 
           (cond
            ((atom (setq g (cadr getl))) nil) 
            ((null (cadr g)) (cdr g)) 
            ((atom (cadr g)) 
             (setq gg (cadr g)) 
             nil ) 
            (t (cdr g)) ) ) 
          ((eq (car getl) 'subr) 
           (cond
            ((setq g (args x)) 
	     (setq g (cond ((> (cdr g) 5)
			    (do ((ng (- (cdr g) 5) (1- ng)) 
			         (l trace*subr-args (cons (gensym) l)))
			         ((zerop ng) l)))
	                   ((do ((ng (- 5 (cdr g)) (1- ng)) 
				 (l trace*subr-args (cdr l))) 
	                        ((zerop ng) l)))))
	     (list g)))))) 
	(and
	 ;; For fns called by TRACE itself, suppress tracing.
	 (or (memq x
           '(*append *delq *nconc args assoc assq boundp cons
             copysymbol fixp gctwa get getl last memq apply
             ncons nreverse plist princ print putprop remprop
             setplist sstatus status sublis terpri typep xcons
             trace-indenter sprinter delq error gensym nouuo
	     prin1 ) ) 
          (eq x prin1) ) 
	 (setq f (list
           (cond
            (f (list 'and 'trace-ok-flag (car f))) 
            ('trace-ok-flag)))))
        (setq sube
         (list (cons 'recurlev y) (cons 'arglist trace*g2))) 
        (setq n
         (cond
          ((cdr m) 
           (cons ''// (sublis sube (cdr m))) ) ) ) 
        (setq ne (sublis sube (list ne f fe break))) 
        (setq nx 
         (sublis 
          (cons (cons 'fnvalue trace*g1) sube) 
          (list nx  fx) ) ) 
        (setq 
         f (cadr ne) fe (caddr ne) 
         break (cadddr ne) ne (car ne) ) 
        (setq fx (cadr nx) nx (car nx)) 
        (setplist
         x
         (cons
          (cond
           (cm
            (setplist y 
             (cons 'fexpr (cons (cadr cm) (plist y))) ) 
            'macro ) 
           (c 'fexpr) 
           (t 'expr) ) 
          (cons (trace-1) (plist x)) ) )  
        (return
         (ncons (cond (b) 
	              (t (setq traced-stuff (cons (list x 'trace (car (plist x)) (cadr (plist x))) 
				                  traced-stuff)) 
	                 x)))))) 
     l) 
    (and traced-stuff (nouuo t) (sstatus uuolinks)))))) 



(declare
 (unspecial n) 
 (fixnum indentation trace-indent-incr trace-indent-max
  n recurlev ) ) 


(defun trace-indenter (recurlev type fn arg stuff indentation) 
 (prog (trace-ok-flag) 
   (setq indentation (- indentation trace-indent-incr))
  (terpri) 
  (do n 
   (cond
    ((< indentation 0) 0) 
    ((< indentation trace-indent-max) indentation) 
    (trace-indent-max) ) 
   (1- n) 
   (zerop n) 
   (princ '/ ) ) 
  (princ '/() (prin1 recurlev) (princ '/ ) (prin1 type) 
  (princ '/ ) (prin1 fn) 
  (cond ((not (eq arg trace*g2)) 
    (princ '/ ) 
    (cond ((and (boundp 'prin1) prin1)
           (funcall prin1 arg))
          ((prin1 arg))) )) 
  (do l stuff (cdr l) (null l) 
   (princ '/ ) 
    (cond ((and (boundp 'prin1) prin1)
           (funcall prin1 (car l)))
          ((prin1 (car l))))
 ) 
  (princ '/)/ ) ) )    


(setq 	trace-indent-incr 2. 
	trace-indent-max 16. 
	trace*copies (mapcar '(lambda (x) (cons x (copysymbol x t))) 
			     '(trace-indenter print quote cond list 
				and setq break apply listify))) 





		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

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


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