;;; -*- Mode:LISP; Package:META-EVAL; Base:8 -*-


;;; runtime support functions.

;;; some special fix-number-of-arguments versions of commonly used lexpr-functions

;;; In mapcar we cannot easily use RPLACA (MAKE-LIST (LENGTH LIST))
;;; because LIST may be infinite with the FCN doing a *THROW.
;;; A version of length which doesn't hang on infinite lists would be
;;; useful here. Time/paging saving of using a cdr-coded list should be
;;; checked in that case.

;; the following should be microcompiled: MAPCAR-1 NCONC-2 APPEND-2
;; with :DEPEND-ON-BEING-MICROCOMPILED T

; foo: KHS and RG handed-microcompiled these guys.
;(EVAL-WHEN (EVAL COMPILE LOAD)
;(DEFCONST *TO-UCOMPILE* '(nconc-2 append-2 mapcar-2))
;(mapc #'(lambda (x)
;	  (putprop x t 'compiler:microcompile)
;	  (putprop x t :depend-on-being-microcompiled))
;      *to-ucompile*)
;)

;(DEFUN MAPCAR-2 (FCN LIST)
;  (PROG (V P LP)
;	(SETQ P (LOCF V))				;ACCUMULATE LIST IN P, V
;     	(SETQ LP LIST)
;    LOOP (IF (NULL LP) (RETURN V))
;	(SETF (CDR P) (SETQ P (NCONS (FUNCALL FCN (POP LP)))))
;        (GO LOOP)))

(defun mapcar-2-expander (fcn list)
  (if (or (symbolp fcn) (and (listp fcn)
			     (memq (car fcn) '(quote function))
			     (setq fcn (cadr fcn))))
      ;; should be using the meta-eval here to do the substitution.
      `(let ((lp ,list) v)
	 (let ((p (locf v)))
	   (prog ()
	      loop
		 (if (null lp) (return v))
		 (SETF (CDR P) (SETQ P (NCONS (,FCN (POP LP)))))
		 (GO LOOP))))))
		

;(DEFUN NCONC-2 (A B)
;  (COND ((NULL A) B)
;	((NULL B) A)
;	(t
;	 (SETF (CDR (LAST A)) B)
;	 A)))

;(DEFUN APPEND-2 (A B)
;  ;; SINCE WE DO NEED TO TAKE THE LENGTH OF A, THEN WE COULD HAVE
;  ;; A VERSION OF LENGTH WHICH RETURNED CDR-CODEDP INFORMATION.
;  ;; IF A IS CDR-CODED THEN WE CAN USE %BLT to do the work of
;  ;; the CDR/SETF loop.
;  (COND ((null a) b)
;	((NULL B)
;	 (let ((val (MAKE-LIST (LENGTH A))))
;	   (DO ((Valp val (cdr valp))
;		(L A (CDR L)))
;	       ((NULL L) Val)
;	     (SETF (CAR Valp) (CAR L)))))
;	('else
;	 (let ((val (make-list (1+ (length a)))))
;	   (do ((valp val (cdr valp))
;		(l a (cdr l)))
;	       ((null l)
;		;; Stick in a pointer to B
;		;; and then change it from an element to a cdr.
;		(RPLACA VALP B)
;	        ;;bin INHIBIT-SCHEDULING-FLAG T, except that when microcompiled
;		;;we won't get scheduled here anyway.
;		(%P-DPB-OFFSET CDR-ERROR %%Q-CDR-CODE VALP 0)
;		(%P-DPB-OFFSET CDR-NORMAL %%Q-CDR-CODE VALP -1)
;		val)
;	     (setf (car valp) (car l)))))))


;(defun load-ucode ()
;  (apply #'compiler:ma-load *to-ucompile*))