;; Adapted from PLT Scheme's stx.ss 

; parts ripped of from PLT Scheme

; Syntax objects that represent operators

(define syntax/call (make-operator-syntax 'call))
(define syntax/lambda (make-operator-syntax 'lambda))
(define syntax/begin (make-operator-syntax 'begin))
(define syntax/quote (make-operator-syntax 'quote))
(define syntax/code-quote (make-operator-syntax 'code-quote))
(define syntax/let-syntax (make-operator-syntax 'syntax/let))
(define syntax/if (make-operator-syntax 'if))
(define syntax/set! (make-operator-syntax 'set!))
(define syntax/letrec (make-operator-syntax 'letrec))
(define syntax/define (make-operator-syntax 'define))
(define syntax/define-syntax (make-operator-syntax 'define-syntax))
(define syntax/primitive-procedure (make-operator-syntax 'primitive-procedure))
(define syntax/unspecific (make-operator-syntax 'unspecific))

(define *kernel-syntaxes*
  (list syntax/call syntax/lambda syntax/begin syntax/quote syntax/code-quote 
	syntax/let-syntax syntax/if syntax/set! syntax/letrec
	syntax/define syntax/define-syntax
	syntax/primitive-procedure))

(define (kernel-form-identifier-list)
  *kernel-syntaxes*)

; returns (name-or-#f bindings body)
; bindings is a list of pairs
(define (scan-let-like stx named? star?)

  (if (or (not (stx-list? stx))
	  (let ((tail1 (stx-cdr stx)))
	    (or (stx-null? tail1)
		(stx-null? (stx-cdr tail1))
		(and named?
		     (identifier? (stx-car tail1))
		     (stx-null? (stx-cdr (stx-cdr tail1)))))))
      (syntax-violation (stx-car stx) "bad syntax" stx))

  (let ((name (if named?
		  (let ((n (stx-cadr stx)))
		    (if (identifier? n)
			n
			#f))
		  #f)))
    (let ((bindings (stx->list (stx-cadr (if name
					     (stx-cdr stx)
					     stx))))
	  (body (stx-cdr (stx-cdr (if name
				      (stx-cdr stx)
				      stx)))))
      (if (not bindings)
	  (syntax-violation
	   (stx car stx)
	   "bad syntax (not a sequence of identifier-expression bindings)" 
	   stx
	   (stx-cadr stx)))
      
      (let ((new-bindings
	     (let recur ((l bindings))
	       (if (null? l)
		   '()
		   (let ((binding (car l)))
		     (if (not (stx-2list? binding))
			 (syntax-violation
			  (stx-car stx)
			  "bad syntax (not an identifier and expression for a binding)" 
			  stx
			  binding))
		     (if (not (identifier? (stx-car binding)))
			 (syntax-violation
			  (car stx)
			  "bad syntax (not an identifier)" 
			  stx
			  (stx-car binding)))
		     (cons (cons (stx-car binding)
				 (stx-cadr binding))
			   (recur (cdr l))))))))

	(if (not star?)
	    (check-duplicates stx (map car new-bindings)))
	(values name new-bindings body)))))

(define (id-in-list? id l)
  (cond ((null? l) #f)
	((bound-identifier=? id (car l)) #t)
	(else (id-in-list? id (cdr l)))))

(define (check-duplicates stx ids)
  ;; check for duplicates; PLT Scheme has a hash table for #bindings > 5
  (let check ((l ids)
	      (accum '()))
    (if (pair? l)
	(let ((id (car l)))
	  (if (id-in-list? id accum)
	      (syntax-violation (stx-car stx)
				"duplicate identifier"
				stx
				id)
	      (check (cdr l) (cons id accum)))))))

; also performs checking
(define (formals->identifiers stx formals)
  (let loop ((formals formals)
	     (ids '()))
    
    (define (check id)
      (cond
       ((not (identifier? id))
	(syntax-violation (stx-car stx)
			  "bad syntax"
			  stx
			  id))
       ((id-in-list? id ids)
	(syntax-violation (stx-car stx)
			  "duplicate identifier"
			  stx
			  id))))
      

    (cond
     ((stx-null? formals) (reverse ids))
     ((stx-pair? formals)
      (let ((id (stx-car formals)))
	(check id)
	(loop (stx-cdr formals) (cons id ids))))
     ((identifier? formals) 
      (check formals)
      (reverse (cons formals ids)))
     (else (syntax-violation (stx-car stx)
			     "bad syntax"
			     stx
			     formals)))))

(define (body->expression body)
  (if (stx-null? (stx-cdr body))
      (stx-car body)
      `(,syntax/begin . ,body)))
