1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*


;;; Edit History

;;;    Data    Patcher    Patch #  Description
;;; -------------------------------------------------------------------
;;;   3-18-87    ab                - Fix to check that region is of structure type and
;;;                                to look in the new symbols areas (not just nr-sym).
;;;   4-24-87    ab                - Fix to handle each object in the symbol areas, not 
;;;                                assuming that everything is a symbol.  This is necessary 
;;;                                for the garbage collector's use of this function, and
;;;                                won't hurt any other user.
;;;  11-17-87    RJF               - Changed mapatoms-all-symbol-areas to handle train space
;;;                                correctly.
;;;   4/11/88    CLM & PHD         Redesign the MAP functions to prevent creating infinite 
;;;                                loops under certain conditions and to make the second 
;;;                                arg (list) required (it was part of the rest arg which 
;;;                                made it optional, which in turned caused the infinite 
;;;                                loop problem).
;;;   6/29/88    CLM               Fixed the map functions to prevent destructively modifying 
;;;                                it &rest arg now a COPY-LIST is done on it first.
;;;   4/19/89    RJF               - Changed mapatoms-all-symbol-areas to handle the 3 new eas
;;;                                space type correctly
 
(DEFVAR *all-symbol-areas* '(nr-sym))

;; *kernel-symbol-area* *compiler-symbol-area* *user-symbol-area*))   - las 

;; the following is called from package-initialize during the cold-build
(DEFUN MAPATOMS-ALL-SYMBOL-AREAS (FUNCTION)
  "Call FUNCTION on every symbol in known symbol areas, regardless of packages.
The known symbol areas are the ones in the *all-symbol-areas* list."
  (FUNCALL FUNCTION NIL)
  (FUNCALL FUNCTION T)
  (LOOP FOR area-sym IN *all-symbol-areas*
	WITH area DO
	(WHEN (AND (BOUNDP area-sym)
		   (SETQ area (SYMBOL-VALUE area-sym)))
	  (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region)
		UNTIL (MINUSP region) DO
		(let ((reg-bits (AREF #'region-bits region)))
		  (WHEN (AND (region-structure-p region reg-bits)
			     (NOT (region-oldspace-p   region reg-bits))
			     (NOT (region-train-a-p    region reg-bits))
			     (NOT (region-oldspace-a-p region reg-bits))
			     (NOT (region-entry-p      region reg-bits))
			     (NOT (ZEROP (AREF #'region-free-pointer region))))		    
		    (DO* ((Orig (AREF #'region-origin region))
			  (fp (AREF #'region-free-pointer region))
			  (offset 0)
			  (obj nil)
			  (size nil))
			 ((>= offset fp))
		      (without-interrupts
			(if (and (region-train-p region (AREF #'region-bits region))
				 (eq (%p-ldb %%q-data-type (%POINTER-PLUS orig offset)) dtp-gc-forward))
			    (do ()
				((or (>= offset fp)
				     (not (eq (%p-ldb %%q-data-type (%POINTER-PLUS orig offset)) dtp-gc-forward))))
			      (incf offset) ))
			(WHEN (>= offset fp)
			  (RETURN nil))
			(SETQ obj (%FIND-STRUCTURE-HEADER (%POINTER-PLUS orig offset))
			      size (%STRUCTURE-TOTAL-SIZE obj)))
		      (WHEN (SYMBOLP obj)
			(FUNCALL function obj))
		      (INCF offset size)
		      (WHEN (>= offset fp)
			(RETURN nil))  ))))))
  )

;;;(DEFUN MAPATOMS-ALL-SYMBOL-AREAS (FUNCTION)
;;;  "Call FUNCTION on every symbol in known symbol areas, regardless of packages.
;;;The known symbol areas are the ones in the *all-symbol-areas* list."
;;;  (FUNCALL FUNCTION NIL)
;;;  (FUNCALL FUNCTION T)
;;;  (LOOP FOR area-sym IN *all-symbol-areas*
;;;	WITH area DO
;;;	(WHEN (AND (BOUNDP area-sym)
;;;		   (SETQ area (SYMBOL-VALUE area-sym)))
;;;	  (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region)
;;;		UNTIL (MINUSP region) DO
;;;		(WHEN (AND (region-structure-p region (AREF #'region-bits region))
;;;			   (NOT (ZEROP (AREF #'region-free-pointer region))))
;;;		  (DO* ((orig (AREF #'region-origin region))
;;;			(offset 0)
;;;			(fp (AREF #'region-free-pointer region))
;;;			(obj (%FIND-STRUCTURE-HEADER orig))
;;;			(size (%STRUCTURE-TOTAL-SIZE obj)))
;;;		      ((>= offset fp))
;;;		    (WHEN (SYMBOLP obj)
;;;		      (FUNCALL function obj))
;;;		    (INCF offset size)
;;;		    (WHEN (>= offset fp)
;;;		      (RETURN nil))
;;;		    (SETQ obj (%FIND-STRUCTURE-HEADER (%POINTER-PLUS orig offset))
;;;			  size (%STRUCTURE-TOTAL-SIZE obj)))))))
;;;  )

(DEFF mapatoms-nr-sym 'mapatoms-all-symbol-areas)


;; 4/11/88 CLM & PHD - redesign the MAP functions to prevent creating infinite loops
;;under certain conditions and to make the second arg (list) required (it was part of
;;the rest arg which made it optional, which in turned caused the infinite loop problem).
(DEFUN MAPCAR (fct list
	       &rest lists)
  1"Given a <fct> taking r arguments and r lists (x1 ... xN) ... (z1 ... zN),
MAPCAR returns the list (e1 ... eN) where eI denotes the value of <fct>
when applied to the arguments xI,...,zI ,i.e. eI is the value of (<fct> xI ... zI).
In general, the lists need not have the same length - the length of the return list
is the length of the shortest of the r lists , even if some of the lists are cyclic.
See also MAP, MAPCAN and MAPC."*
  (LET* ((number-of-args (1+ (LENGTH lists)))
	 (lists (copy-list lists))     ;;clm 6/29/88
	 return-list
	 (loc (LOCF return-list)))
    (%ASSURE-PDL-ROOM number-of-args)
    (DO-FOREVER
      (RPLACD loc 
	      (SETQ loc
		    (CONS
		      (progn
			(when (null list)
			  (RETURN-FROM MAPCAR return-list))
			(%push (pop  list))
			(DO ((x lists (CDR x)))
			    ((NULL x) (%CALL fct number-of-args))
			  (WHEN (NULL (CAR x)) (RETURN-FROM MAPCAR return-list))
			  (%PUSH (POP (CAR x)))))
		      nil))))))

(DEFUN MAPLIST (fct list &REST lists)
  1"Given a <fct> taking r arguments and r lists (x1 ... xN) ... (z1 ... zN),
MAPLIST returns the list (e1 ... eN) where eI denotes the value of <fct>
when applied to the arguments (xI...xN),...,(zI...zN) ,i.e. eI is the value of 
 (<fct> (xI...xN) ... (zI...zN)).
In general, the lists need not have the same length - the length of the return list
is the length of the shortest of the r lists , even if some of the lists are cyclic.
See also MAPCAR, MAPL and MAPCON."*

  (LET* ((number-of-args (1+ (LENGTH lists)))
	 (lists (copy-list lists))     ;;clm 6/29/88
	 return-list
	 (loc (LOCF return-list)))
    (%ASSURE-PDL-ROOM number-of-args)
    (DO-FOREVER
      (RPLACD loc 
	      (SETQ loc
		    (CONS
		      (progn
			(when (null list)
			  (return-from maplist return-list))
			(%push list)
			(pop list)
			(DO ((x lists (CDR x)))
			    ((NULL x) (%CALL fct number-of-args))
			  (WHEN (NULL (CAR x)) (RETURN-FROM MAPLIST return-list))
			  (%PUSH (CAR x))
			  (POP (CAR x))))
		      nil))))))

1;;; the implementation of MAPC is similar to that of MAPCAR except that the <return-list> of the latter
;;; is not constructed. The traversal of the component lists in <lists> is the same, the DO-FOREVER
;;; insures all items will be processed and the (WHEN (NULL ... statement insures that exit from MAPC
;;; will occur when the shortest component list has been traversed.*

(DEFUN MAPC (fct list &rest lists)
  1"Given a <fct> taking r arguments and r <lists> (x1 ... xN) ... (z1 ... zN),
MAPC applies <fct> successively to (x1 ... z1),...,(xN ... zN) ignoring the
values returned. MAPC , called chiefly for effect, returns the first of the
lists. In general, the lists need not have the same length - MAPC terminates
when the end of the shortest of the lists has been reached."*

  (LET ((number-of-args (1+ (LENGTH lists)))
	(lists (copy-list lists))     ;;clm 6/29/88
	(return-value list))
    (%ASSURE-PDL-ROOM number-of-args)
    (DO-FOREVER
      (progn
	(when (null list)
	  (return-from mapc return-value))
	(%push (pop list))
	(DO ((x lists (CDR x)))
	    ((NULL x) (%CALL fct number-of-args))
	  (WHEN (NULL (car x)) (RETURN-FROM MAPC return-value))
	  (%PUSH (POP (CAR x)))
	  )))))

;;; the implementation of MAPL is similar to that of MAPC except that the component lists are pushed onto the
;;; stack rather than their elements.

(DEFUN MAPL (fct list &rest lists)
  1"Given a <fct> taking r arguments and r <lists> (x1 ... xN) ... (z1 ... zN),
MAPL applies <fct> successively to ((x1 ... xN) ... (z1...zN)) ,...,((xN) ... (zN)) 
ignoring the values returned. MAPL , called chiefly for effect, returns the first of 
the lists. In general, the lists need not have the same length - MAPL terminates
when the end of the shortest of the lists has been reached."*
  (LET ((number-of-args (1+ (LENGTH lists)))
	(lists (copy-list lists))    ;;clm 6/29/88
	(return-value list))
    (%ASSURE-PDL-ROOM number-of-args)
    (DO-FOREVER
      (progn
	(when (null list)
	  (return-from mapl return-value))
	(%push list)
	(pop list)
	(DO ((x lists (CDR x)))
	    ((NULL x) (%CALL fct number-of-args))
	  (WHEN (NULL (CAR x)) (RETURN-FROM MAPL return-value))
	  (%PUSH (CAR x))
	  (POP (CAR x)))))))
(DEFF GLOBAL:MAP #'MAPL)


(DEFUN MAPCAN (fct list &REST lists)
  1"Given a <fct> taking r arguments and r <lists> (x1 ... xN) ... (z1 ... zN),
MAPCAN returns the list obtained by NCONCing the lists which are the values of
 (<fct> x1 ... z1), ... ,(<fct> xN ... zN). When any of these values are not lists,
the value is ignored. In general, the lists need not have the same length - 
MAPCAN terminates when the end of the shortest of the lists has been reached."*

  (LET* ((number-of-args (1+ (LENGTH lists)))
	 (lists (copy-list lists))     ;;clm 6/29/88
	 result
	 return-list
	 (loc (LOCF return-list)))
    (%ASSURE-PDL-ROOM number-of-args)
    (DO-FOREVER
      (WHEN (CONSP (SETQ result
			 (progn
			   (when (null list)
			     (RETURN-FROM MAPCAN return-list))
			   (%push (pop list))
			   (DO ((u lists (CDR u)))
			       ((NULL u)(%CALL fct number-of-args))
			     (WHEN (NULL (CAR u)) (RETURN-FROM MAPCAN return-list))
			     (%PUSH (POP (CAR u)))
			     ))))
	(RPLACD loc result)            ;;; conc <result> to the end of <return-list> and then save the last element
	(SETQ loc (LAST result))))))   ;;; for the next iteration.

(DEFUN MAPCON (fct list &REST lists)
  1"Given a <fct> taking r arguments and r <lists> (x1 ... xN) ... (z1 ... zN),
MAPCON returns the list obtained by NCONCing the lists which are the values of
 (<fct> (x1...xN) ... (z1...zN)) , ... ,(<fct> (xN) ... (zN)). When any of these 
values are not lists, the value is ignored. In general, the lists need not have 
the same length - MAPCON terminates when the end of the shortest of the lists 
has been reached."*

  (LET* ((number-of-args (1+ (LENGTH lists)))
	 (lists (copy-list lists))   ;;clm 6/29/88
	 result
	 return-list
	 (loc (LOCF return-list)))
    (%ASSURE-PDL-ROOM number-of-args)
    (DO-FOREVER
      (WHEN (CONSP (SETQ result
			 (progn
			   (when (null list)
			     (RETURN-FROM MAPCON return-list))
			   (%push list)
			   (pop list)
			   (DO ((u lists (CDR u)))
			       ((NULL u)(%CALL fct number-of-args))
			     (WHEN (NULL (CAR u)) (RETURN-FROM MAPCON return-list))
			     (%PUSH (CAR u))
			     (POP (CAR u))))))
	(RPLACD loc result)
	(SETQ loc (LAST result))))))   ;;; for the next iteration.