;;; -*- Mode: Lisp; Package: Puser; Base: 10. ; -*-

;;;; Version of LLOGO;DEFINE for the Lisp machine.

(EVAL-WHEN
 (EVAL LOAD COMPILE)

 (DEFVAR GENSYM (GENSYM))
 (DEFVAR INSIDE-OPEN-BRACKET? NIL)
  
 (DEFUN OPEN-BRACKET-MACRO NIL
	(COND ((EVAL (READ)) NIL)
	      (T (DO ((STUFF (READ) (READ))
		      (INSIDE-OPEN-BRACKET? T))
		     ((EQ STUFF GENSYM)))
		 NIL))
	NIL) 
 
 (SETSYNTAX 91. 'SPLICING 'OPEN-BRACKET-MACRO) 
 
 (DEFUN CLOSE-BRACKET-MACRO ()
	(COND (INSIDE-OPEN-BRACKET? (LIST GENSYM))
	      (NIL))) 
 
 (SETSYNTAX 93. 'SPLICING 'CLOSE-BRACKET-MACRO)) 

(DEFUN INCREMENT MACRO (CALL) 
	(RPLACA CALL 'SETQ)
	(RPLACD CALL
		(LIST (CADR CALL) (CONS (COND ((NULL (CDDR CALL)) '1+) ('+)) (CDR CALL))))) 

(DEFUN DECREMENT MACRO (CALL) 
	(RPLACA CALL 'SETQ)
	(RPLACD CALL
		(LIST (CADR CALL) (CONS (COND ((NULL (CDDR CALL)) '1-) ('-)) (CDR CALL)))))

(DEFUN BITWISE-AND MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 1. (CDR CALL)))) 

(DEFUN BITWISE-OR MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 7. (CDR CALL))))

(DEFUN BITWISE-NOT MACRO (CALL) 
        (RPLACA CALL 'BOOLE)
        (RPLACD CALL (CONS 6. (CONS -1. (CDR CALL)))))

(DEFUN BITWISE-XOR MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 6. (CDR CALL))))

(DEFUN BITWISE-ANDC MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 2. (CDR CALL))))

;;Replaced by similar thing in DLET.
;;(DEFUN ROUND MACRO (CALL) (LIST 'FIX (LIST '+$ (CADR CALL) 0.5)))

(DEFMACRO REPEAT (REPEAT-ITERATIONS . REPEAT-BODY)
	  `(DO ((REPEAT-COUNT 1. (1+ REPEAT-COUNT)))
	       ((> REPEAT-COUNT ,REPEAT-ITERATIONS))
	       . ,REPEAT-BODY))

(DEFMACRO CCONS CALL `(LIST* ,@ CALL))

(DEFMACRO DEFINE (NAME . DEFINITION)
	  (LET ((CLAUSE-NAMES '(ABB SYN)))
	       (LET ((CLAUSES (DO ((CLAUSES NIL))
				  ((NOT (AND (LISTP (CAR DEFINITION))
					     (MEMQ (CAAR DEFINITION) CLAUSE-NAMES)))
				   CLAUSES)
				  (PUSH (CAR DEFINITION) CLAUSES)
				  (POP DEFINITION))))
		    `(PROGN 'COMPILE
                            ,@ (COND ((ASSQ 'SYN CLAUSES)
				      (MAPCAR '(LAMBDA (ABB name) `(FSET ',NAME ',ABB))
					      (CDR (ASSQ 'SYN CLAUSES))
					      (circular-list name)))
                                     (`((DEFUN ,NAME ,@ DEFINITION))))
                            ,@ (COND ((ASSQ 'ABB CLAUSES)
				      (MAPCAR '(LAMBDA (ABB name) `(FSET ',ABB ',NAME))
					      (CDR (ASSQ 'ABB CLAUSES))
					      (circular-list name))))))))