;;-*-LISP-*-
;; A special-form LET for the maclisp interpreter.
;; 1:07am  Friday, 18 September 1981 -George Carrette.
;; This takes up less space than, and is generally easier to deal
;; with than a hairy macro implementation in the interpreter.

;; grossly hacked for BIL to run on Lispm.

#+MACLISP
(HERALD LETFEX)

#+MACLISP
(PROGN (DEFPROP LET LETFEX FEXPR)
       (DEFPROP LET* LET*FEX FEXPR)
       (DEFPROP PROGN EVALN FEXPR)
       (DEFPROP DESETQ DESETQFEX FEXPR))

#+LISPM
(PROGN 'COMPILE
(DEFUN LET (&QUOTE &REST L) (LETFEX L))
(DEFUN LET* (&QUOTE &REST L) (LET*FEX L))
(DEFUN DESETQ (&QUOTE &REST L) (DESETQFEX L))
)

(DEFUN LETFEX-WTA (F M A &REST L)
  (LEXPR-FUNCALL F (ERROR M A 'WRNG-TYPE-ARG) L))

(DEFUN EVALN (L)
  (DO ((VALUE))
      ((ATOM L)
       (IF (NULL L) VALUE
	   (LETFEX-WTA #'EVALN "is a bad tail of a list for a PROGN" L)))
    (SETQ VALUE (EVAL (POP L)))))

(DEFVAR LETFEX-VARS)
(DEFVAR LETFEX-VALS)

(DEFUN LETFEX-RECLAIM ()
  (#+MACLISP RECLAIM #+LISPM PROGN
	     (PROG1 LETFEX-VARS (SETQ LETFEX-VARS NIL)) NIL)
  (#+MACLISP RECLAIM #+LISPM PROGN
   (PROG1 LETFEX-VALS (SETQ LETFEX-VALS NIL)) NIL))

(DEFUN LETFEX (L)
  (IF (ATOM L)
      (LETFEX-WTA #'LETFEX "bad form to LET" L)
      (LET ((LETFEX-VARS ())
	    (LETFEX-VALS ()))
	(UNWIND-PROTECT
	 (PROGN (LETFEX-BINDING-FORM (CAR L))
		(PROGV LETFEX-VARS LETFEX-VALS
		       (EVALN (CDR L))))
	 (LETFEX-RECLAIM)))))

(DEFUN LET*FEX (L)
  (IF (ATOM L)
      (LETFEX-WTA #'LET*FEX "bad form to LET*" L)
      (LET*FEX1 (CAR L) (CDR L))))

(DEFUN LET*FEX1 (B L)
  (COND ((ATOM B)
	 (IF (NULL B) (EVALN L)
	     (LETFEX-WTA #'LET*FEX1 "bad form to LET*" B L)))
	('ELSE
	 (LET ((LETFEX-VARS ())
	       (LETFEX-VALS ()))
	   (UNWIND-PROTECT
	    (PROGN (LETFEX-BINDING-FORM1 (CAR B))
		   (PROGV LETFEX-VARS LETFEX-VALS
			  (LET*FEX1 (CDR B) L)))
	    (LETFEX-RECLAIM))))))

(DEFUN DESETQ-ERR (M A)
  (ERROR (LIST M "in DESETQ") A 'FAIL-ACT))

(DEFUN DESETQFEX (L)
  (DO ((ANY NIL T)
       (VALUE)
       (LETFEX-VARS NIL NIL)
       (LETFEX-VALS NIL NIL)
       (L L (CDDR L)))
      ((ATOM L)
       (IF (AND (NULL L) ANY)
	   VALUE
	   (LETFEX-WTA #'DESETQFEX "bad DESETQ form" L)))
    (COND ((CDR L)
	   (IF (NULL (CAR L))
	       (DESETQ-ERR "bad variable" (CAR L)))
	   (SETQ VALUE (EVAL (CADR L)))
	   (UNWIND-PROTECT
	    (PROGN (LETFEX-BINDING-PATTERN (CAR L) VALUE)
		   (MAPC 'SET LETFEX-VARS LETFEX-VALS))
	    (LETFEX-RECLAIM)))
	  ('ELSE
	   (DESETQ-ERR "odd number of args" L)))))

(DEFUN LETFEX-BINDING-FORM (B)
  (IF (AND (ATOM B) (NOT (NULL B)))
      (LETFEX-WTA #'LETFEX-BINDING-FORM
		  "bad binding form in LET" B)
      (MAPC #'LETFEX-BINDING-FORM1 B)))

(DEFUN LETFEX-BINDING-FORM1-WTA (FORM)
  (LETFEX-WTA #'LETFEX-BINDING-FORM1
	      "bad single binding form in LET" FORM))

(DEFUN LETFEX-BINDING-FORM1 (PAR)
  (COND ((ATOM PAR)
	 (COND ((AND PAR (SYMBOLP PAR) (NOT (EQ PAR T)))
		(PUSH PAR LETFEX-VARS)
		(PUSH NIL LETFEX-VALS))
	       ('ELSE
		(LETFEX-BINDING-FORM1-WTA PAR))))
	((EQ (TYPEP PAR) 'LIST)
	 (COND ((NULL (CDR PAR))
		(LETFEX-BINDING-PATTERN (CAR PAR) NIL))
	       ((NULL (CDDR PAR))
		(LETFEX-BINDING-PATTERN (CAR PAR) (EVAL (CADR PAR))))
	       ('ELSE
		(LETFEX-BINDING-FORM1-WTA PAR))))
	('ELSE
	 (LETFEX-BINDING-FORM1-WTA PAR))))

(DEFUN LETFEX-BINDING-PATTERN-WTA1 (PATTERN FORM)
  (LETFEX-BINDING-PATTERN
   (ERROR "bad destructuring pattern" pattern 'wrng-type-arg)
   FORM))

(DEFUN LETFEX-BINDING-PATTERN-WTA2 (PATTERN FORM)
  (LETFEX-BINDING-PATTERN
   PATTERN
   (ERROR (LIST "form doesn't destructure against" PATTERN)
	  FORM 'WRNG-TYPE-ARG)))

(DEFVAR LETFEX-BINDING-PATTERN-HUNK ())

(DEFUN LETFEX-BINDING-PATTERN (PATTERN FORM)
  (COND ((ATOM PATTERN)
	 (COND ((NULL PATTERN))
	       ((AND (SYMBOLP PATTERN) (NOT (EQ PATTERN T)))
		(PUSH PATTERN LETFEX-VARS)
		(PUSH FORM    LETFEX-VALS))
	       ('ELSE
		(LETFEX-BINDING-PATTERN-WTA1 PATTERN FORM))))
	((EQ (TYPEP PATTERN) 'LIST)
	 (COND ((OR (EQ (TYPEP FORM) 'LIST)
		    (NULL FORM))
		(LETFEX-BINDING-PATTERN (CAR PATTERN) (CAR FORM))
		(LETFEX-BINDING-PATTERN (CDR PATTERN) (CDR FORM)))
	       ('ELSE
		(LETFEX-BINDING-PATTERN-WTA2 PATTERN FORM))))
	('ELSE
	 (IF LETFEX-BINDING-PATTERN-HUNK
	     (FUNCALL LETFEX-BINDING-PATTERN-HUNK PATTERN FORM)
	     (LETFEX-BINDING-PATTERN-WTA1 PATTERN FORM)))))