;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Lowercase:T -*-

;;;                           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) 1985-1989 Texas Instruments Incorporated. All rights reserved.

;; PHD 12/31/86 Removed alternate-macro-defintions for  macro, deff-macro, deff, defun
;; JLM 04/11/89 Changed altenate-macro-for DEFPROP to use (SETF (GET ... instead of (PUTPROP ... 

;;; this file contains macro definitions for zetalisp special forms
;;; for use with the common-lisp MACRO-FUNCTION function.


(defmacro (:property prog1 alternate-macro-definition) (&body forms &aux (var (gensym)))
  `(let ((,var ,(first forms)))
     ,@(cdr forms)
     ,var))

(defmacro (:property return alternate-macro-definition) (&rest values)
  `(return-from () ,@values)) 


(defmacro (:property nth-value alternate-macro-definition) (value-number exp)
  `(nth ,value-number (multiple-value-list ,exp))) 

(defmacro (:property multiple-value-setq  alternate-macro-definition) (vars exp)
  `(multiple-value-call #'(lambda (&rest forms)
			    (prog1 ,@(loop for var in vars and j from 0 collect `(setq ,var (nth ,j forms)))))
			,exp))

(defmacro (:property multiple-value-list alternate-macro-definition) (exp)
  `(multiple-value-call #'list ,exp)) 


(defmacro (:property multiple-value-bind alternate-macro-definition) (vars exp &body body)
  `(let ,vars
     (multiple-value-setq ,vars
       ,exp)
     ,@body)) 


(defmacro (:property multiple-value alternate-macro-definition) (vars exp)
  `(multiple-value-setq ,vars
     ,exp)) 



(defmacro (:property with-stack-list alternate-macro-definition) ((var . elts) &body body)
  `(let ((,var (list . ,elts)))
     ,@body)) 


(defmacro (:property with-stack-list* alternate-macro-definition) ((var . elts) &body body)
  `(let ((,var (list* . ,elts)))
     ,@body)) 


(defmacro (:property dont-optimize alternate-macro-definition) (&body body)
  `(progn
     . ,body)) 


(defmacro (:property do alternate-macro-definition) (vars (test . result) &body body)
  (let ((tag (gensym)))
    `(prog ,(mapcar #'(lambda (x)
			(if (atom x)
			  x
			  (list (car x) (cadr x))))
		    vars)
       ,tag
       (when ,test
	 ,@result)
       (progn
	 . ,body)
       (psetq
	. ,(loop for x in vars when (and (not (atom x)) (cddr x)) collect (car x) and collect
	      (caddr x)))
       (go ,tag)))) 


(defmacro (:property do* alternate-macro-definition) (vars (test . result) &body body)
  (let ((tag (gensym)))
    `(prog* ,(mapcar #'(lambda (x)
			 (if (atom x)
			   x
			   (list (car x) (cadr x))))
		     vars)
       ,tag
       (when ,test
	 ,@result)
       (progn
	 . ,body)
       (setq
	. ,(loop for x in vars when (and (not (atom x)) (cddr x)) collect (car x) and collect
	      (caddr x)))
       (go ,tag)))) 

;; ; (or a c b d) => (cond (a) (b) (c) (t d))

(defmacro (:property or alternate-macro-definition) (&rest expressions)
  (case (length expressions)
    (0 nil)
    (1 (car expressions))
    (t
     (do ((x expressions (cdr x))
	  (result (list 'cond) (cons (list (car x)) result)))
	 ((null (cdr x))
	  (push (list t (car x)) result)
	  (nreverse result)))))) 

;;;(and a b c d) => (if a (if b (if c d)))

(defmacro (:property and alternate-macro-definition) (&rest expressions)
  (case (length expressions)
    (0 t)
    (1 (car expressions))
    (t
     (do* ((foo (cdr (reverse expressions)) (cdr foo))
	   (result `(,(car (last expressions)))))
	  ((null foo)
	   (car result))
       (setq result `((if ,(car foo)
			,@result))))))) 

;;;(cond (a b c) (d) (e f)) => (if a (progn b c) (let (d) (if d (if e f)))

(defmacro (:property cond
	    alternate-macro-definition) (&rest clauses)
  (do ((foo (reverse clauses) (cdr foo))
       (result nil)
       loser)
      ((null foo)
       (if loser
	 `(let (,loser)
	    ,@result)
	 (car result)))
    (if (> (length (car foo)) 1)
      (setq result `((if ,(caar foo)
		       (progn
			 . ,(cdar foo))
		       ,@result)))
      (progn
	(or loser (setq loser (make-symbol "LOSER" t)))
	(setq result `((if (setq ,loser ,(caar foo))
			 ,loser
			 ,@result))))))) 


(defmacro (:property defprop alternate-macro-definition) (symbol value property)
  `(progn
     ;;(putprop ',symbol ',value ',property) 	; jlm 4/11/89
     (setf (get ',symbol ',property) ',value)
     ',symbol)) 


;;PAD 1/21/87 added alternate-macro-definition for locally
(defmacro (:property locally alternate-macro-definition) (&body body)
  `(let () . ,body))