;;;; macros.scm


(define-syntax (define-macro x r c)
  (let ((head (cadr x))
	(body (cddr x))
	(form (gensym)))
    `(define-syntax (,(car head) ,form ,(gensym) ,(gensym))
       (apply (lambda ,(cdr head) ,@body) (cdr (strip-syntax form))))))


(let ()

  (define sx-length length)
  (define sx-rest cdr)
  (define sx-first car)
  (define sx-second cadr)
  (define sx-third caddr)
  (define sx-fourth cadddr)
  (define (sx-fifth x) (car (cddddr x)))
  (define (sx-sixth x) (cadr (cddddr x)))
  (define (sx-seventh x) (caddr (cddddr x)))
  (define (sx-eighth x) (cadddr (cddddr x)))
  (define (sx-ninth x) (car (cddddr (cddddr x))))
  (define (sx-tenth x) (cadr (cddddr (cddddr x))))
  (define (sx-eleventh x) (caddr (cddddr (cddddr x))))
  (define (sx-twelfth x) (cadddr (cddddr (cddddr x))))
  (define sx-unlist identity)
  (define sx-datum identity)
  (define (fuck-up) (panic "This shouldn't happen"))
  (define panic error)
  (define sx-map map)
  (define sx-symbol? symbol?)
  (define sx-null? null?)
  (define sx-eq? eq?)
  (define sx-list? list?)
  (define sx-string? string?)
  (define rest sx-rest)
  (define first car)

(define (reduce f l i)
 (cond ((null? l) i)
       ((null? (rest l)) (first l))
       (else (let loop ((l (rest l)) (c (first l)))
	      (if (null? l) c (loop (rest l) (f c (first l))))))))

(define (map-indexed f l)
 ;; needs work: To eliminate REVERSE.
 (let loop ((i 0) (l l) (c '()))
  (if (null? l)
      (reverse c)
      (loop (+ i 1) (sx-rest l) (cons (f (sx-first l) i) c)))))

(define (sx-every p l . &rest)
 (let loop ((l l) (&rest &rest))
  (or (null? l)
      (and (apply p (sx-first l) (map sx-first &rest))
	   (loop (sx-rest l) (map sx-rest &rest))))))

  (for-each
   (lambda (mdef)
     (let ((name (car mdef))
	   (handler (cadr mdef)))
       (##sys#extend-macro-environment
	name
	'()
	(##sys#er-transformer
	 (lambda (x r c)
	   (handler (strip-syntax x)))))))

   (list
    (list 'define-structure
	  (lambda (s)
	    (unless (and (>= (sx-length s) 3) (sx-every sx-symbol? (sx-rest s)))
	      (syntax-error s "Improper DEFINE-STRUCTURE"))
	    (let ((type (sx-datum (sx-second s)))
		  (slots (sx-unlist (sx-rest (sx-rest s)))))
	      ;; conventions: TYPE SLOTS
	      `(begin
		 (define (,(string->symbol
			    (string-append "make-" (symbol->string type)))
			  ,@(map sx-datum slots))
		   (##sys#make-structure 
		    ',type
		    ,@(map sx-datum slots)))
		 (define (,(string->symbol
			    (string-append (symbol->string type) "?"))
			  obj)
		   (##sys#structure? obj ',type))
		 ,@(map-indexed
		    (lambda (slot i)
		      ;; conventions: SLOT I
		      (let ((slot (sx-datum slot)))
			;; conventions: SLOT
			`(begin
			   (define (,(string->symbol
				      (string-append (symbol->string type)
						     "-"
						     (symbol->string slot)))
				    s)
			     (assert (##sys#structure? s ',type))
			     (##sys#slot s ,(+ i 1)))
			   (define (,(string->symbol
				      (string-append "set-"
						     (symbol->string type)
						     "-"
						     (symbol->string slot)
						     "!"))
				    s x)
			     (assert (##sys#structure? s ',type))
			     (##sys#setslot s ,(+ i 1) x))
			   (define (,(string->symbol
				      (string-append "local-set-"
						     (symbol->string type)
						     "-"
						     (symbol->string slot)
						     "!"))
				    s x)
			     (assert (##sys#structure? s ',type))
			     (let ((p (##sys#slot s ,(+ i 1))))
			       ;; conventions: P
			       (upon-failure
				(##sys#setslot s ,(+ i 1) p)))
			     (##sys#setslot s ,(+ i 1) x)))))
		    slots)
		 ))))
    (list 'while
	  (lambda (s)
	    (let ((loop (gensym "loop"))) ;changed
	      ;; conventions: LOOP
	      `(begin (define (,loop)
			(when ,(sx-second s)
			  ,@(sx-unlist (sx-rest (sx-rest s))) (,loop)))
		      (,loop)))))
    (list 'either
	  (lambda (s)
	    (cond ((sx-null? (sx-rest s)) '(fail))
		  ((sx-null? (sx-rest (sx-rest s))) (sx-second s))
		  (else `(if (a-boolean)
			     ,(sx-second s)
			     (either ,@(sx-unlist (sx-rest (sx-rest s)))))))))
    (list 'for-effects
	  (lambda (s)
	    (let ((return (gensym "return"))   ;changed
		  (old-fail (gensym "old-fail"))) ;changed
	      ;; conventions: RETURN OLD-FAIL
	      `(call-with-current-continuation
		(lambda (,return)
		  (let ((,old-fail fail))
		    (set! fail (lambda () (set! fail ,old-fail) (,return #f)))
		    (begin ,@(sx-unlist (sx-rest s)))
		    (fail)))))))
    (list 'one-value
	  (lambda (s)
	    (unless (or (= (sx-length s) 2) (= (sx-length s) 3))
	      (syntax-error s "Improper ONE-VALUE"))
	    (let ((s1 (sx-second s))
		  (s2 (if (= (sx-length s) 2) '(fail) (sx-third s)))
		  (return (gensym "return"))   ;changed
		  (old-fail (gensym "old-fail"))) ;changed
	      ;; conventions: S1 S2 RETURN OLD-FAIL
	      `(call-with-current-continuation
		(lambda (,return)
		  (let ((,old-fail fail))
		    (set! fail (lambda () (set! fail ,old-fail) (,return ,s2)))
		    (let ((v ,s1))
		      (set! fail ,old-fail)
		      v)))))))		;changed
    (list 'local-one-value
	  ;; needs work: *FAIL?* can potentially be captured.
	  (lambda (s)
	    (unless (or (= (sx-length s) 2) (= (sx-length s) 3))
	      (syntax-error s "Improper LOCAL-ONE-VALUE"))
	    (let ((s1 (sx-second s))
		  (s2 (if (= (sx-length s) 2) '(fail) (sx-third s)))
		  (return (gensym "return"))  ;changed
		  (old-fail (gensym "old-fail")) ;changed
		  (v (gensym "v")))		 ;changed
	      ;; conventions: S1 S2 RETURN OLD-FAIL V
	      `(call-with-current-continuation
		(lambda (,return)
		  (let ((,v #f)
			(,old-fail fail))
		    (set!
			fail
		      (lambda ()
			(set! fail ,old-fail)
			(,return (cond (*fail?* ,s2) (else (set! *fail?* #t) ,v)))))
		    (set! ,v ,s1)
		    (set! *fail?* #f)
		    (fail)))))))
    (list 'all-values
	  ;; needs work: To eliminate REVERSE.
	  (lambda (s)
	    (let ((values (gensym "values"))) ;changed
	      ;; conventions: VALUEs
	      `(let ((,values '()))
		 (for-effects
		  (set! ,values (cons (begin ,@(sx-unlist (sx-rest s))) ,values)))
		 (reverse ,values)))))
    (list 'possibly?
	  (lambda (s)
	    (let ((return (gensym "return"))  ;changed
		  (old-fail (gensym "old-fail")) ;changed
		  (v (gensym "v")))		 ;changed
	      ;; conventions: RETURN OLD-FAIL V
	      `(call-with-current-continuation
		(lambda (,return)
		  (let ((,old-fail fail))
		    (set! fail (lambda () (set! fail ,old-fail) (,return #f)))
		    (let ((,v (begin ,@(sx-unlist (sx-rest s)))))
		      (unless ,v (fail))
		      (set! fail ,old-fail)
		      ,v)))))))		;changed
    (list 'necessarily?
	  (lambda (s)
	    (let ((return (gensym "return"))  ;changed
		  (old-fail (gensym "old-fail")) ;changed
		  (v (gensym "v"))		 ;changed
		  (u (gensym "u")))		 ;changed
	      ;; conventions: RETURN OLD-FAIL V U
	      `(call-with-current-continuation
		(lambda (,return)
		  (let ((,old-fail fail)
			(,u #t))
		    (set! fail (lambda () (set! fail ,old-fail) (,return ,u)))
		    (let ((,v (begin ,@(sx-unlist (sx-rest s)))))
		      (when ,v (set! ,u ,v) (fail))
		      (set! fail ,old-fail)
		      #f)))))))		;changed
    (list 'upon-failure
	  (lambda (s)
	    (let ((old-fail (gensym "old-fail"))) ;changed
	      ;; conventions: OLD-FAIL
	      `(let ((,old-fail fail))
		 (set! fail (lambda ()
			      (set! fail ,old-fail)
			      ,@(sx-unlist (sx-rest s))
			      (fail)))))))
    (list 'local-set!
	  (lambda (s)
	    (unless (= (sx-length s) 3) (syntax-error s "Improper LOCAL-SET!"))
	    (let ((p (gensym "p")))	;changed
	      ;; conventions: P
	      `(begin
		 (let ((,p ,(sx-second s))) (upon-failure (set! ,(sx-second s) ,p)))
		 (set! ,(sx-second s) ,(sx-third s))))))
    (list 'lazy
	  (lambda (s)
	    (let ((args (gensym "args"))) ;changed
	      ;; conventions: LAZY
	      `(lambda ,args (apply ,(sx-second s) ,args)))))
    (list 'define-command
	  (lambda (s)
	    (define (valid-command-arguments? l)
	      (define (valid-optional-parameter? l)
		(and (sx-list? l)
		     (= (sx-length l) 4)
		     (sx-symbol? (sx-first l))
		     (sx-string? (sx-second l))))
	      (define (valid-required-parameter? l)
		(and (sx-list? l)
		     (= (sx-length l) 3)
		     (sx-symbol? (sx-first l))
		     (sx-string? (sx-second l))))
	      (define (order-ok-optional? l)
		(or (sx-null? l)
		    (and (sx-eq? (sx-first (sx-first l)) 'optional)
			 (order-ok-optional? (sx-rest l)))
		    (and (sx-eq? (sx-first (sx-first l)) 'rest)
			 (sx-null? (sx-rest l)))))
	      (define (order-ok-required? l)
		(or (sx-null? l)
		    (and (sx-eq? (sx-first (sx-first l)) 'required)
			 (order-ok-required? (sx-rest l)))
		    (and (sx-eq? (sx-first (sx-first l)) 'optional)
			 (order-ok-optional? (sx-rest l)))
		    (and (sx-eq? (sx-first (sx-first l)) 'rest)
			 (sx-null? (sx-rest l)))))
	      (define (order-ok? l)
		(or (sx-null? l)
		    (and (or (sx-eq? (sx-first (sx-first l)) 'any-number)
			     (sx-eq? (sx-first (sx-first l)) 'at-least-one)
			     (sx-eq? (sx-first (sx-first l)) 'at-most-one)
			     (sx-eq? (sx-first (sx-first l)) 'exactly-one))
			 (order-ok? (sx-rest l)))
		    (and (sx-eq? (sx-first (sx-first l)) 'required)
			 (order-ok-required? (sx-rest l)))
		    (and (sx-eq? (sx-first (sx-first l)) 'optional)
			 (order-ok-optional? (sx-rest l)))
		    (and (sx-eq? (sx-first (sx-first l)) 'rest)
			 (sx-null? (sx-rest l)))))
	      (and
	       (sx-list? l)
	       (>= (sx-length l) 1)
	       (sx-symbol? (sx-first l))
	       (sx-every
		(lambda (l)
		  (and
		   (sx-list? l)
		   (>= (sx-length l) 1)
		   (or (and (or (sx-eq? (sx-first l) 'exactly-one)
				(sx-eq? (sx-first l) 'at-most-one))
			    (>= (sx-length l) 2)
			    (sx-every
			     (lambda (l)
			       (and (sx-list? l)
				    (>= (sx-length l) 2)
				    (sx-string? (sx-first l))
				    (sx-symbol? (sx-second l))
				    (sx-every valid-optional-parameter?
					      (sx-rest (sx-rest l)))))
			     (sx-rest l)))
		       (and (or (sx-eq? (sx-first l) 'at-least-one)
				(sx-eq? (sx-first l) 'any-number))
			    (>= (sx-length l) 2)
			    (sx-every
			     (lambda (l)
			       (and (sx-list? l)
				    (>= (sx-length l) 2)
				    (sx-string? (sx-first l))
				    (sx-symbol? (sx-second l))
				    (sx-every valid-required-parameter?
					      (sx-rest (sx-rest l)))))
			     (sx-rest l)))
		       (and (or (sx-eq? (sx-first l) 'required)
				(sx-eq? (sx-first l) 'rest))
			    (= (sx-length l) 2)
			    (valid-required-parameter? (sx-second l)))
		       (and (sx-eq? (sx-first l) 'optional)
			    (= (sx-length l) 2)
			    (valid-optional-parameter? (sx-second l))))))
		(sx-rest l))
	       (order-ok? (sx-rest l))))
	    (define (command-usage l)
	      (define (command-usage1 l)
		(let ((s (let loop ((l l))
			   (define (command-usage l)
			     (string-append
			      "-"
			      (sx-datum (sx-first l))
			      (let loop ((l (sx-rest (sx-rest l))))
				(cond
				 ((sx-null? l) "")
				 ((sx-null? (sx-rest l))
				  (string-append
				   " " (sx-datum (sx-second (sx-first l)))))
				 (else (string-append
					" "
					(sx-datum (sx-second (sx-first l)))
					(loop (sx-rest l))))))))
			   (if (sx-null? (sx-rest l))
			       (command-usage (sx-first l))
			       (string-append
				(command-usage (sx-first l))
				"|"
				(loop (sx-rest l)))))))
		  (if (= (sx-length l) 1) s (string-append "[" s "]"))))
	      (if (sx-null? l)
		  ""
		  (case (sx-datum (sx-first (sx-first l)))
		    ((any-number)
		     (string-append " ["
				    (command-usage1 (sx-rest (sx-first l)))
				    "]*"
				    (command-usage (sx-rest l))))
		    ((at-least-one)
		     (string-append " ["
				    (command-usage1 (sx-rest (sx-first l)))
				    "]+"
				    (command-usage (sx-rest l))))
		    ((at-most-one)
		     (string-append
		      " ["
		      (command-usage1 (sx-rest (sx-first l)))
		      "]"
		      (command-usage (sx-rest l))))
		    ((exactly-one)
		     (string-append
		      " "
		      (command-usage1 (sx-rest (sx-first l)))
		      (command-usage (sx-rest l))))
		    ((required)
		     (string-append " "
				    (sx-datum (sx-second (sx-second (sx-first l))))
				    (command-usage (sx-rest l))))
		    ((optional)
		     (string-append " ["
				    (sx-datum (sx-second (sx-second (sx-first l))))
				    (command-usage (sx-rest l)) "]"))
		    ((rest)
		     (string-append " ["
				    (sx-datum (sx-second (sx-second (sx-first l))))
				    "]*"))
		    (else (fuck-up)))))
	    (define (command-bindings l)
	      (if (sx-null? l)
		  '()
		  (case (sx-datum (sx-first (sx-first l)))
		    ((any-number at-least-one)
		     (append
		      (reduce
		       append
		       (sx-map (lambda (l)
				 (cons (list (sx-second l) #f)
				       (sx-map (lambda (l) (list (sx-first l) ''()))
					       (sx-rest (sx-rest l)))))
			       (sx-rest (sx-first l)))
		       '())
		      (command-bindings (sx-rest l))))
		    ((at-most-one exactly-one)
		     (append
		      (reduce
		       append
		       (sx-map (lambda (l)
				 (cons (list (sx-second l) #f)
				       (sx-map (lambda (l)
						 (list (sx-first l) (sx-fourth l)))
					       (sx-rest (sx-rest l)))))
			       (sx-rest (sx-first l)))
		       '())
		      (command-bindings (sx-rest l))))
		    ;; changed
		    ((required) (cons (sx-first (sx-second (sx-first l)))
				      (command-bindings (sx-rest l))))
		    ((optional) (cons (list (sx-first (sx-second (sx-first l)))
					    (sx-fourth (sx-second (sx-first l))))
				      (command-bindings (sx-rest l))))
		    ((rest) (cons (list (sx-first (sx-second (sx-first l))) ''())
				  (command-bindings (sx-rest l))))
		    (else (fuck-up)))))
	    (define (command-keyword-argument-parser l)
	      (cons
	       `(let loop ()
		  (unless (null? arguments)
		    (cond
		     ,@(let loop ((l l))
			 (if (sx-null? l)
			     '(((string=? (car arguments) "-usage") (usage))) ;changed
			     (case (sx-datum (sx-first (sx-first l)))
			       ((any-number at-least-one)
				(append
				 (sx-map
				  (lambda (l)
				    `((string=? (car arguments) ;changed
						,(string-append
						  "-" (sx-datum (sx-first l))))
				      (set! arguments (cdr arguments)) ;changed
				      (set! ,(sx-second l) #t)
				      ,@(reduce
					 append
					 (sx-map
					  (lambda (l)
					    `((when (null? arguments) (usage))
					      (set! ,(sx-first l)
						(cons (,(sx-third l)
						       ;; changed
						       (car arguments) usage)
						      ,(sx-first l)))
					      ;; changed
					      (set! arguments (cdr arguments))))
					  (sx-rest (sx-rest l)))
					 '())
				      (loop)))
				  (sx-rest (sx-first l)))
				 (loop (sx-rest l))))
			       ((at-most-one exactly-one)
				(append
				 (sx-map
				  (lambda (l1)
				    `((string=? (car arguments) ;changed
						,(string-append
						  "-" (sx-datum (sx-first l1))))
				      (set! arguments (cdr arguments)) ;changed
				      (when (or ,@(sx-map sx-second
							  (sx-rest (sx-first l))))
					(usage))
				      (set! ,(sx-second l1) #t)
				      ,@(reduce
					 append
					 (sx-map (lambda (l)
						   `((when (null? arguments) (usage))
						     (set! ,(sx-first l)
						       (,(sx-third l)
							;; changed
							(car arguments) usage))
						     ;; changed
						     (set! arguments (cdr arguments))))
						 (sx-rest (sx-rest l1)))
					 '())
				      (loop)))
				  (sx-rest (sx-first l)))
				 (loop (sx-rest l))))
			       ((required optional rest) (loop (sx-rest l)))
			       (else (fuck-up))))))))
	       (let loop ((l l))
		 (if (sx-null? l)
		     '()
		     (case (sx-datum (sx-first (sx-first l)))
		       ((at-least-one exactly-one)
			(cons `(unless (or ,@(sx-map sx-second
						     (sx-rest (sx-first l))))
				 (usage))
			      (loop (sx-rest l))))
		       ((at-most-one any-number required optional rest)
			(loop (sx-rest l)))
		       (else (fuck-up)))))))
	    (define (command-positional-argument-parser l)
	      (let loop ((l l))
		(if (sx-null? l)
		    '((unless (null? arguments) (usage)))
		    (case (sx-datum (sx-first (sx-first l)))
		      ((any-number at-least-one at-most-one exactly-one)
		       (loop (sx-rest l)))
		      ((required)
		       (append `((when (null? arguments) (usage))
				 (set! ,(sx-first (sx-second (sx-first l)))
				   (,(sx-third (sx-second (sx-first l)))
				    (car arguments) usage))  ;changed
				 (set! arguments (cdr arguments))) ;changed
			       (loop (sx-rest l))))
		      ((optional)
		       (cons `(unless (null? arguments)
				(set! ,(sx-first (sx-second (sx-first l)))
				  (,(sx-third (sx-second (sx-first l)))
				   (car arguments) usage)) ;changed
				(set! arguments (cdr arguments))) ;changed
			     (loop (sx-rest l))))
		      ((rest)
		       `((let loop ()
			   (unless (null? arguments)
			     (set! ,(sx-first (sx-second (sx-first l)))
			       (cons (,(sx-third (sx-second (sx-first l)))
				      (car arguments) usage) ;changed
				     ,(sx-first (sx-second (sx-first l)))))
			     (set! arguments (cdr arguments)) ;changed
			     (loop)))))
		      (else (fuck-up))))))
	    (unless (and (sx-list? s)
			 (>= (sx-length s) 2)
			 (valid-command-arguments? (sx-second s)))
	      (syntax-error s "Improper DEFINE-COMMAND"))
	    ;; changed
	    `(let ((arguments (cons (car (argv)) (command-line-arguments))))
	       (define (string-argument string usage)
		 ;; changed
		 (if (string? string) string (panic "This shouldn't happen")))
	       (define (integer-argument string usage)
		 (let ((integer (string->number string)))
		   ;; changed
		   (if (integer? integer)
		       (if (exact? integer) integer (usage))
		       (usage))))
	       (define (real-argument string usage)
		 (let ((real (string->number string)))
		   ;; changed
		   (if (real? real) (exact->inexact real) (usage))))
	       (let ((program (car arguments))) ;changed
		 (define (usage)
		   ;; removed: STDERR-PORT
		   (panic
		    (string-append
		     "usage: " program ,(command-usage (sx-rest (sx-second s))))))
		 (set! arguments (cdr arguments)) ;changed
		 (let ,(command-bindings (sx-rest (sx-second s)))
		   ,@(command-keyword-argument-parser (sx-rest (sx-second s)))
		   ,@(command-positional-argument-parser (sx-rest (sx-second s)))
		   ,@(sx-unlist (sx-rest (sx-rest s))))))))
    (list 'define-primitive-procedure
	  (lambda (s)
	    (unless (= (sx-length s) 9)
	      (syntax-error s "Wrong number of arguments"))
	    `(set! *primitive-procedure-handlers*
	       (cons
		(cons ',(sx-second s)
		      (make-primitive-procedure
		       ,(sx-third s)
		       (lambda (y u0 w0) ,(sx-fourth s))
		       (lambda (y u0 n w0) ,(sx-fifth s))
		       (lambda (y u0 n w0) ,(sx-sixth s))
		       (lambda (y u0 propagate-result!
				  propagate-type-predicate! w0)
			 ,(sx-seventh s))
		       (lambda (r y u0 ws w w0 w1 w2 w3) ,(sx-eighth s))
		       (lambda (r y u0 ts ws t w compile-type-predicate
				  t0 w0 t1 w1 t2 w2 t3 w3)
			 ,(sx-ninth s))))
		*primitive-procedure-handlers*))))))

)