;;; dsssl-templates.scm
;;; Copyright Henry S. Thompson 1996
;;; Alpha version 0.7, not for onward distribution

;;; Produced at HCRC, Edinburgh with support for the UK Economic and Social
;;;  Research Council and SunSoft

;;; built-in special form and function templates for dsssl expression language
;;; Last edited: Wed Aug 14 12:20:38 1996

;;; All template functions return a cons of new bindings and new free uses
;;; using the function m-bu, access functions bu-b (for bindings) and
;;; bu-u (for uses)

(define ac-eval
  (lambda (form env)
    ;; Basic argument evaluation
    ;; Opaque to bindings
    (m-bu '() (process-form form env #f))))

(define ac-evals
  (lambda (form env)
    ;; Process an arbitrary number of args with ac-eval
    (process-more-args (cdr form)
                       ac-evals
                       env
                       '()
                       (ac-eval (car form) env))))

(define ac-walk
  (lambda (form env)
    ;; walk but don't use
    (process-form form env #f)
    (m-bu '() '())))

(define ac-walks
  (lambda (form env)
    ;; Walk but don't use
    (m-bu (bu-b (ac-evals form env)) '())))

(define ac-let-bind
  (lambda (form env)
    ;; Loop over binding forms, collecting bindings but NOT passing them
    ;; down, only up and out
    (let loop ((ptr form)
               (binds '())
               (uses '()))
      (if (pair? ptr)
          (let ((sub (ac-let-term (car ptr) ft-var env binds)))
            (loop (cdr ptr)
                  (append! (bu-b sub) binds)
                  (union (bu-u sub) uses)))
        (m-bu binds uses)))))

(define ac-let*-bind
  (lambda (form env)
    ;; Loop over binding forms, collecting bindings and passing them down
    (let loop ((ptr form)
               (binds '())
               (uses '()))
      (if (pair? ptr)
          (let ((sub (ac-let-term (car ptr) ft-var (append binds env) binds)))
            (loop (cdr ptr)
                  (append! (bu-b sub) binds)
                  (union (bu-u sub) uses)))
        (m-bu binds uses)))))

(define ac-letr-bind
  (lambda (form env)
    ;; Loop twice, once to bind and second to eval with all bindings
    (let loop ((ptr form)
               (env env))
      (if (pair? ptr)
          (loop (cdr ptr)(cons (list (caar ptr)) env))
        (let loop2 ((ptr form)
                    (binds '())
                    (uses '()))
          (if (pair? ptr)
              (let ((sub (ac-let-term (car ptr) ft-var env binds)))
                (loop2 (cdr ptr)
                       (append! (bu-b sub) binds) ; override first binding
                       (union (bu-u sub) uses)))
            (m-bu binds uses)))))))

(define ac-dlet-term
  (lambda (form env)
    ;; basic define binding
    (ac-let-term form
                 (if (get (car form) 'builtin)
                     ft-fn
                   ft-var)
                 env
                 '())))

(define ac-let-term
  (lambda (form type env binds)
    ;; Handle single let term
    (if (and (list? form)
             (= (length form) 2)
             (symbol? (car form)))
        (let ((uses (process-form (cadr form) env #f)))
          ;; protect reserved words
          (if (get (car form) 'spec-form)
              (begin (set! type 0)
                     (spec-error "Attempt to redefine reserved word"
                                 (car form))))
          (if (assq (car form) binds)
              (begin (spec-error "Attempt to bind twice" (car form))
                     (list '()))
            ;; this assumes that lambda cheats and DOES walk its body
            (if (and (pair? (cadr form))(memq (caadr form) '(d!lambda
							     d!lambda-2)))
                (m-bu (list (cons (car form)
                                  uses))
                      '())
              (m-bu (list (cons (car form) type))
                    uses))))
      (begin (spec-error "Invalid let binding" form)
             (list '())))))

(define ac-sbind
  (lambda (form env)
    ;; For named let name or other unspecified bindings
    (m-bu (list (cons form '()))        ; no-use lambda binding
          '())))

(define ac-body
  (lambda (form env)
    ;; A cross between let* (for defines) and eval
    ;; Opaque to bindings
    (let loop ((ptr form)
               (binds env)
               (uses '()))
      (if (pair? ptr)
          (if (and (pair? (car ptr))
		   (eq? (caar ptr) 'define))
              (let ((sub (process-form (car ptr) binds #t)))
                (loop (cdr ptr)
                      (append! (bu-b sub) binds)
                      (union (bu-u sub) uses)))
            (begin
              (if (not (null? (cdr ptr)))
                  (spec-error "Too many expressions in body" ptr))
              (m-bu '()
                    (union uses (bu-u (ac-eval (car ptr) binds))))))
        (begin
          (spec-error "No expression in body" form)
          (m-bu '() uses))))))

(define ac-noval
  (lambda (form env)
    (m-bu '() '())))

(define ac-sym
  (lambda (form env)
    ;; Must be a symbol, unevaluated
    (if (not (symbol? form))
        (spec-error "Must be a symbol" form))
    (ac-noval form env)))

(define ac-syml
  (lambda (form env)
    ;; symbol orlistof
    (if (not (or (symbol? form)
		 (and (pair? form)
		      (not (thereis (lambda (s) (not (symbol? s)))
				    form)))))
	(spec-error "Must be symbol or list of symbols" form))
    (ac-noval form env)))

(define ac-symstring
  (lambda (form env)
    ;; symbol or string
    (if (not (or (symbol? form)
		 (string? form)))
	(spec-error "Must be a symbol or a string" form))
    (ac-noval form env)))

(define ac-symorf
  (lambda (form env)
    ;; symbol or #f
    (if (not (or (symbol? form)
		 (eq? form #f)))
	(spec-error "Must be a symbol or #f" form))
    (ac-noval form env)))

(define ac-string
  (lambda (form env)
    ;; string
    (if (not (string? form))
	(spec-error "Must be a string" form))
    (ac-noval form env)))

(define ac-char
  (lambda (form env)
    ;; Must be a string, character namespace
    (if (not (string? form))
        (spec-error "Must be a string" form))
    (m-bu '() (list (cons form ft-chn)))))

(define ac-pmod
  (lambda (form env)
    ;; Page model-def binding
    (let ((frm (cdr form))
	  (uses '())
	  (w #f)(h #f)(r #f)(fd #f))
      (let ((pms (lambda (type valp flag)
		   (if flag
		       (spec-error "Multiple sub-spec. for"
				   type "not allowed" frm)
		     (if (and (pair? valp)(null? (cdr valp)))
			 (set! uses (union uses (bu-u (ac-eval (car valp)
							       env))))
		       (spec-error "Sub-spec must be a two-element list"
				   (cons type valp)))))))
	(let loop ((ptr frm))
	     (if (pair? ptr)
		 (let ((spec (car ptr)))
		   (if (and (pair? spec) (list? spec))
		       (case (car spec)
			 ((width) (pms (car spec)(cdr spec) w)(set! w #t))
			 ((height) (pms (car spec)(cdr spec) h)(set! h #t))
			 ((filling-direction) (pms (car spec)(cdr spec) fd)
			  (set! fd #t))
			 ((region) (set! uses
					 (union uses
						(ac-region (cdr spec) env)))
			  (set! r #t))
			 (else (spec-error "Not a valid page model spec."
					   spec))
			 )
		     (spec-error "Spec in page-model-def must be a list" spec))
		   (loop (cdr ptr)))
	       )))
      (if (not w)
	  (spec-error "Page-model missing width specification"
		      (cons 'd!ind (if (pair? frm)
				       (car frm)
				     frm))
		      (cons 'd!sum frm)))
      (if (not h)
	  (spec-error "Page-model missing height specification"
		      (cons 'd!ind (if (pair? frm)
				       (car frm)
				     frm))
		      (cons 'd!sum frm)))
      (if (not r)
	  (spec-error "Page-model missing region specification"
		      (cons 'd!ind (if (pair? frm)
				       (car frm)
				     frm))
		      (cons 'd!sum frm)))
      (m-bu (bu-b (ac-symbind form env)) uses))))

(define ac-region
  (lambda (specs env)
    ;; content of region sub-spec
    ;; Sigh, this and next should be made table-driven
    (let ((uses '())
	  (x #f)(y #f)(w #f)(h #f)(fd #f)(hd #f)(ft #f)(pr #f))
      (let ((pms (lambda (type form flag)
		   (if flag
		       (spec-error "Multiple sub-spec. for"
				   type "not allowed" specs)
		     (if form
			 (if (and (pair? (cdr form))(null? (cddr form)))
			     (set! uses (union uses (bu-u (ac-eval
							   (cadr form) env))))
			   (spec-error "Sub-spec must be a two-element list"
				       form)))))))
	(let loop ((ptr specs))
	     (if (pair? ptr)
		 (let ((spec (car ptr)))
		   (if (and (pair? spec) (list? spec))
		       (case (car spec)
			 ((x-origin) (pms (car spec) spec x)(set! x #t))
			 ((y-origin) (pms (car spec) spec y)(set! y #t))
			 ((width) (pms (car spec) spec w)(set! w #t))
			 ((height) (pms (car spec) spec h)(set! h #t))
			 ((flow) (pms (car spec) #f pr)
			  (for-each (lambda (form)
				      (ac-symorf form env))
				     (cdr spec))
			  (set! pr #t))
			 ((header) (pms (car spec) #f hd)
			  (set! uses (union uses (ac-gac (cdr spec) env)))
			  (set! hd #t))
			 ((footer) (pms (car spec) #f ft)
			  (set! uses (union uses (ac-gac (cdr spec) env)))
			  (set! ft #t))
			 ((filling-direction) (pms (car spec) spec fd)
			  (set! fd #t))
			 ((decorate) (pms (car spec) spec #f))
			 (else (spec-error "Not a valid region spec." spec))
			 )
		     (spec-error "Spec in region-spec must be a list" spec))
		   (loop (cdr ptr)))
	       )))
      (if (not w)
	  (spec-error "Region spec. missing width specification"
		      (cons 'd!ind (if (pair? specs)
				       (car specs)
				     specs))
		      (cons 'd!sum specs)))
      (if (not h)
	  (spec-error "Region spec. missing height specification"
		      (cons 'd!ind (if (pair? specs)
				       (car specs)
				     specs))
		      (cons 'd!sum specs)))
      (if (not x)
	  (spec-error "Region spec. missing x-origin specification"
		      (cons 'd!ind (if (pair? specs)
				       (car specs)
				     specs))
		      (cons 'd!sum specs)))
      (if (not y)
	  (spec-error "Region spec. missing y-origin specification"
		      (cons 'd!ind (if (pair? specs)
				       (car specs)
				     specs))
		      (cons 'd!sum specs)))
      uses)))

(define summ
  (lambda (form)
    ;; top level list 'summar
    (if (pair? form)
	(cons (if (pair? (car form))
		  (list (caar form) "...")
		(car form))
	      (summ (cdr form)))
      '())))

(define ac-gac
  (lambda (gacs env)
    ;; generated area clauses
    (let ((uses '())
	  (w #f)(h #f)(fd #f)(ca #f)(g #f))
      (let ((pms (lambda (type form flag)
		   (if flag
		       (spec-error "Multiple sub-spec. for"
				   type "not allowed")
		     (if form
			 (if (and (pair? (cdr form))(null? (cddr form)))
			     (set! uses (union uses (bu-u (ac-eval
							   (cadr form) env))))
			   (spec-error "Sub-spec must be a two-element list"
				       form)))))))
	(let loop ((ptr gacs))
	     (if (pair? ptr)
		 (let ((spec (car ptr)))
		   (if (and (pair? spec) (list? spec))
		       (case (car spec)
			 ((width) (pms (car spec) spec w)(set! w #t))
			 ((height) (pms (car spec) spec h)(set! h #t))
			 ((filling-direction) (pms (car spec) spec fd)
			  (set! fd #t))
			 ((contents-alignment) (pms (car spec) spec ca)
			  (set! ca #t))
			 ((generate) (pms (car spec) spec g)
			  (set! g #t))
			 (else (spec-error
				"Not a valid generated area clause" spec))
			 )
		     (spec-error "Spec in page-model-def must be a list" spec))
		   (loop (cdr ptr)))
	       )))
      (if (not g)
	  (spec-error "Generated-area-clauses missing generate spec"
		      (cons 'd!ind (if (pair? gacs)
				       (car gacs)
				     gacs))
		      (cons 'd!sum gacs)))
      uses)))

(define ac-csmod
  (lambda (form env)
    ;; Column-set-model
        (let ((uses '())(frm (cdr form))
	  (fo #f)(w #f)(h #f)(fd #f))
      (let ((pms (lambda (type valp flag)
		   (if flag
		       (spec-error "Multiple sub-spec. for"
				   type "not allowed" frm)
		     (if (and (pair? valp)(null? (cdr valp)))
			 (set! uses (union uses (bu-u (ac-eval (car valp)
							       env))))
		       (spec-error "Sub-spec must be a two-element list"
				   (cons type valp)))))))
	(let loop ((ptr frm))
	     (if (pair? ptr)
		 (let ((spec (car ptr)))
		   (if (and (pair? spec) (list? spec))
		       (case (car spec)
			 ((width) (pms (car spec)(cdr spec) w)(set! w #t))
			 ((height) (pms (car spec)(cdr spec) h)(set! h #t))
			 ((filling-direction) (pms (car spec)(cdr spec) fd)
			  (set! fd #t))
			 ((fill-out) (pms (car spec)(cdr spec) fo)
			  (set! fo #t))
			 ((decorate) (pms (car spec) spec #f))
			 ((column-subset) (set! uses
						(union uses
						       (ac-csub
							(cdr spec) env))))
			 ((tie) (set! uses
				      (union uses
					     (ac-ctsub
					      (cdr spec) env))))
			 (else (spec-error "Not a valid column set model spec."
					   spec))
			 )
		     (spec-error
		      "Spec in column-set-model-def must be a list" spec))
		   (loop (cdr ptr)))
	       )))
      (m-bu (bu-b (ac-symbind (car form) env)) uses))))

(define ac-csub
  (lambda (specs env)
    ;; content of column-subset sub-spec
    (let ((uses '())
	  (cs #f)
	  (csfm #f)
	  (tf #f)(bf #f)(b #f)(j #f)(jl #f)(jll #f)(ld #f)(ldo #f)(al #f))
      (let ((pms (lambda (type form flag)
		   (if flag
		       (spec-error "Multiple sub-spec. for"
				   type "not allowed" specs)
		     (if form
			 (if (and (pair? (cdr form))(null? (cddr form)))
			     (set! uses (union uses (bu-u (ac-eval
							   (cadr form) env))))
			   (spec-error "Sub-spec must be a two-element list"
				       form)))))))
	(let loop ((ptr specs))
	     (if (pair? ptr)
		 (let ((spec (car ptr)))
		   (if (and (pair? spec) (list? spec))
		       (case (car spec)
			 ((top-float-space-below)
			  (pms (car spec) spec tf)(set! tf #t))
			 ((bottom-float-space-above)
			  (pms (car spec) spec bf)(set! bf #t))
			 ((balance?)
			  (pms (car spec) spec b)(set! b #t))
			 ((justify?)
			  (pms (car spec) spec j)(set! j #t))
			 ((justify-limit)
			  (pms (car spec) spec jl)(set! jl #t))
			 ((justify-last-limit)
			  (pms (car spec) spec jll)(set! jll #t))
			 ((length-deviation)
			  (pms (car spec) spec ld)(set! ld #t))
			 ((length-decrease-order)
			  (pms (car spec) spec ldo)(set! ldo #t))
			 ((align-lines?)
			  (pms (car spec) spec al)(set! al #t))
			 ((flow) (ac-csflow
				  (cdr spec) env)
			  (set! csfm #t))
			 ((column) (set! uses
				      (union uses
					     (ac-col
					      (cdr spec) env)))
			  (set! cs #t))
			 (else (spec-error "Not a valid column-subset spec."
					   spec))
			 )
		     (spec-error
		      "Spec in column-subset spec must be a list" spec))
		   (loop (cdr ptr)))
	       )))
      (if (not cs)
	  (spec-error "Column-subset spec. missing column specification"
		      (cons 'd!ind (if (pair? specs)
				       (car specs)
				     specs))
		      (cons 'd!sum specs)))
      (if (not csfm)
	  (spec-error
	   "Column-subset spec. missing subset flowmap specification"
		      (cons 'd!ind (if (pair? specs)
				       (car specs)
				     specs))
		      (cons 'd!sum specs)))
      uses)))

(define ac-csflow
  (lambda (specs env)
    ;; column-subset-flow-map specs
    (if (and (pair? specs)(list? specs))
	(let loop ((ptr specs))
	      (if (pair? ptr)
		  (let ((spec (car ptr)))
		    (if (not
			 (and
			  (list? spec)
			  (>= (length spec) 2)
			  (or (eq? (car spec) #f)
			      (symbol? (car spec)))
			  (not (thereis (lambda (z)
					  (not
					   (memq
					    z
					    '(top-float body-text
					      bottom-float footnote))))
					(cdr spec)))))
			(spec-error "Invalid column-subset flow-map entry"
				    spec))
		    (loop (cdr ptr)))))
      (spec-error "Column-subset flow-map must be non-empty list" specs))
    ))

(define ac-col
  (lambda (specs env)
    ;; column spec
    (let ((uses '())
	  (x #f)(y #f)(w #f)(h #f)(fs #f)(hd #f)(ft #f))
      (let ((pms (lambda (type form flag)
		   (if flag
		       (spec-error "Multiple sub-spec. for"
				   type "not allowed" specs)
		     (if form
			 (if (and (pair? (cdr form))(null? (cddr form)))
			     (set! uses (union uses (bu-u (ac-eval
							   (cadr form) env))))
			   (spec-error "Sub-spec must be a two-element list"
				       form)))))))
	(let loop ((ptr specs))
	     (if (pair? ptr)
		 (let ((spec (car ptr)))
		   (if (and (pair? spec) (list? spec))
		       (case (car spec)
			 ((x-origin) (pms (car spec) spec x)(set! x #t))
			 ((y-origin) (pms (car spec) spec y)(set! y #t))
			 ((width) (pms (car spec) spec w)(set! w #t))
			 ((height) (pms (car spec) spec h)(set! h #t))
			 ((header) (pms (car spec) #f hd)
			  (set! uses (union uses (ac-gac (cdr spec) env)))
			  (set! hd #t))
			 ((footer) (pms (car spec) #f ft)
			  (set! uses (union uses (ac-gac (cdr spec) env)))
			  (set! ft #t))
			 ((footnote-separator) (pms (car spec) #f fs)
			  (set! uses (union uses (ac-gac (cdr spec) env)))
			  (set! fs #t))
			 (else (spec-error "Not a valid column spec." spec))
			 )
		     (spec-error "Spec in column-spec must be a list" spec))
		   (loop (cdr ptr)))
	       )))
      uses)))

(define ac-ctsub
  (lambda (specs env)
    ;; tied-column subset
    (if (and (list? specs)
	     (> (length specs) 1)
	     (not (thereis (lambda (spec)
			     (not (and (pair? spec)
				       (eq? (car spec) 'column-subset))))
			   specs)))
	(let ((uses '()))
	  (let loop ((ptr specs))
	       (if (pair? ptr)
		   (begin
		    (set! uses (union uses (ac-csub (cdar ptr) env)))
		    (loop (cdr ptr)))))
	  uses)
      '())))

(define ac-qsym
  (lambda (form env)
    ;; Must be a unit symbol, unevaluated
    (if (not (symbol? form))
        (spec-error "Unit must be a symbol" form))
    (m-bu '() (list (cons form ft-unit)))))

(define ac-duterm
  (lambda (form env)
    ;; for units
    (if (eq? (car form) 'e)
        (spec-error "Not a valid unit" (car form)))
    (if (eq? (car form) 'm)
        (spec-error "Redefining the 'm' unit is likely to be catastrophic"
                    form))
    (ac-let-term form ft-unit env '())))

(define ac-cpdecl
  (lambda (form env)
    ;;; character property declaration
    (ac-let-term form ft-chpr env '())))

(define ac-ccp
  (lambda (form env)
    ;;; declare-char-characterictic+property
    (ac-sym (car form) env)
    (ac-string (cadr form) env)
    (set-car! alr2-dummy (car form))
    (set-car! (cdr alr2-dummy) (caddr form))
    (ac-let-term alr2-dummy ft-chpr env '())))

(define ac-acp
  (lambda (form env)
    ;;; add-char-properties
    (if (and (pair? form)
             (pair? (car form))
             (eq? (caar form) 'd!k)
             (pair? (cdr form)))
	(process-more-args (cddr form) ac-acp env (list (cons (cadar form)
							      ft-chpr))
			   (ac-eval (cadr form) env))
      (ac-acpc form env))))

(define ac-acpc
  (lambda (form env)
    (if (and (pair? form)
             (pair? (car form))
             (eq? (caar form) 'd!c))
      (m-bu '() (map (lambda (cp)
                       (if (and (pair? cp)
                                (eq? (car cp) 'd!c))
                         (cons (cadr cp) ft-chn)
                         (begin (spec-error "Expected a character" form)
                                (list #f))))
                     form))
      (begin (spec-error "Invalid arglist for add-char-properties" form)
             (m-bu '() '())))))

(define ac-ln
  (lambda (form env)
    ;; for languages -- no separate name space, I think
    (if (pair? (cdr form))
      (spec-warning "Checking of define-language arguments not implemented"))
    (ac-symbind (car form) env)))

(define ac-symbind
  (lambda (sym env)
    (set-car! alr-dummy sym)
    (ac-let-term alr-dummy ft-var env '())))

(define ac-tle
  (lambda (form env)
    (let ((frm (cadr form)))
      (if (not (and (pair? frm)(list? frm)(= (length frm) 2)))
	  (spec-error "translit-entry must be two-element list" frm)
	(begin
	 (if (not (char? (car frm)))
	     (spec-error "source character in translit entry must be a character"
			 frm))
	 (if (not (and (pair? (cadr frm))(list? (cadr frm))))
	     (spec-error "char-list in translit-entry must be a list" frm)
	   (if (thereis (lambda (x) (not (char? x))) (cadr frm))
	       (spec-error "all members of char-list in translit-entry must be characters" (cadr frm))
	     (ac-symbind (car form) env))))))))

(define ac-keys
  (lambda (form env)
    ;; Process key-arg pairs
    (if (keyword? (car form))
        (if (pair? (cdr form))
            (process-more-args (cddr form)
                               ac-keys
                               env
                               '()
                               (ac-eval (cadr form) env))
          (begin
            (spec-error "No argument expression after keyword" form)
            (list '())))
      (begin (spec-error "Expected keyword" form)
             (list '())))))

(define ac-keysplus
  (lambda (form env)
    ;; Process key-arg pairs then expressions
    (if (keyword? (car form))
        (if (pair? (cdr form))
            (process-more-args (cddr form)
                               ac-keysplus
                               env
                               '()
                               (ac-eval (cadr form) env))
          (begin
            (spec-error "No argument expression after keyword" form)
            (list '())))
      (process-args form ac-evals env '() #f))))

(define ac-cpairs
  (lambda (form env)
    ;; cond body
    (if (and (pair? form)
             (pair? (cdr form))
             (eq? (caar form) 'else))
        (spec-error "else clause not last in cond" form))
    (process-more-args (cdr form)
                       ac-cpairs
                       env
                       '()
                       (ac-cpair (car form) env))))

(define ac-cpair
  (lambda (form env)
    ;; cond `pair'
    ;; note that diagnose-cond has already checked it's a proper list
    (if (if (pair? (cdr form))
            (if (eq? (cadr form) '=>)
                (or (eq? (car form) 'else)
                    (not (= (length form) 3)))
              (not (= (length form) 2)))
          (not (eq? (car form) 'else)))
        (spec-error "Ill-formed cond clause" form))
    (if (eq? (car form) 'else)
        (ac-eval (cadr form) env)
      (if (and (pair? (cdr form))
               (eq? (cadr form) '=>))
          ;; stand things on their heads, makes it work out right
          (process-more-args (list (car form))
                             ac-evals
                             env
                             '()
			     ;; cheat to get it treated as an application
                             (ac-proc1 (cddr form) env))
        (process-more-args (cdr form)
                           ac-evals
                           env
                           '()
                           (ac-eval (car form) env))))))

(define ac-proc1
  (lambda (form env)
    ;; car of form in an application environment
    ;; Do this so we get arg checking and dssslisation on symbols
    ;; Cheat like crazy -- wants 1 arg so provide a dummy argument
    (let ((scdr (cdr form)))
      (set-cdr! form '(#f))
      (ac-proc-cleanup (ac-eval form env) form scdr env))))

(define ac-proc-cleanup
  (lambda (res form scdr env)
    (set-cdr! form scdr)
    (process-more-args scdr ac-evals env '() res)))

(define ac-proc0
  (lambda (form env)
    ;; car of form in an application environment, should want 0 args
    ;; Do this so we get arg checking and dssslisation on symbols
    (let ((scdr (cdr form)))
      (set-cdr! form '())
      (ac-proc-cleanup (ac-eval form env) form scdr env))))

(define ac-procn
  (lambda (form env)
    ;; form in an application environment, don't know how many args will be
    ;; provided.
    (let ((r-n-e report-nargs-errors)
	  (scdr (cdr form))
	  (res #f))
      (set! report-nargs-errors #f)
      (set-cdr! form '())
      (set! res (ac-eval form env))
      (set! report-nargs-errors r-n-e)
      (ac-proc-cleanup res form scdr env))))

(define ac-cclauses
  (lambda (form env)
    ;; case body
    (if (and (pair? form)
             (pair? (cdr form))
             (eq? (caar form) 'else))
        (spec-error "else clause not last in case" form))
    (process-more-args (cdr form)
                       ac-cclauses
                       env
                       '()
                       (ac-cclause (car form) env))))

(define ac-cclause
  (lambda (form env)
    ;; case clause
    (if (and (pair? form)
             (pair? (cdr form))
             (null? (cddr form)))
        (if (not (or (eq? (car form) 'else)
                     (list? (car form))))
            (spec-error "Invalid start to case clause" (car form))
          (ac-eval (cadr form) env))
      (spec-error "Ill-formed case clause" form))))       

(define ac-lbind
  (lambda (form env)
    ;; vanilla lambda bind
    (if (list? form)
      (m-bu (let loop ((ptr form)
		       (res '()))
		 (if (pair? ptr)
		     (let ((s (car ptr)))
		       (if (not (symbol? s))
			   (begin
			    (spec-error "Simple lambda formal must be a symbol"
					s)
			    (set! s 'nas))
			 (if (memq s (cdr ptr))
			     (spec-error "Attempt to bind twice" s)))
		       (loop (cdr ptr)(cons (cons s ft-var) res)))
		   res))
            '())
      (begin
        (spec-error "Lambda formals must be a list" form)
        (ac-noval form env)))
    ))

(define ac-lkbind
  (lambda (form env)
    ;; full dsssl lambda bind
    (if (list? form)
        (ac-lkbind-req form env '() '())
      (begin
        (spec-error "Lambda formals must be a list" form)
        (ac-noval form env)))))

(define alr-dummy (list #f #f))
(define alr2-dummy (list #f #f))

(define ac-lkbind-req
  (lambda (form env binds uses)
    ;; required segment of lambda binding
    (if (pair? form)
        (if (and (pair? (car form))
                 (eq? (caar form) 'd!d))
            (case (cadar form)
              ((optional) (ac-lkbind-opt (cdr form) env binds uses))
              ((rest) (ac-lkbind-rest (cdr form) env binds uses))
              ((key) (ac-lkbind-key (cdr form) env binds uses))
              (else (begin (spec-error "Invalid lambda key" (car form))
                           (m-bu binds uses))))
          (begin
            (if (pair? (car form))
                (spec-error "List not allowed in required formals" form))
            (if (symbol? (car form))
                (begin (set-car! alr-dummy (car form))
                       (set! binds (cons
                                    (car
                                     (bu-b
                                      (ac-let-term alr-dummy ft-var
                                                   env binds)))
                                    binds)))
              (spec-error "Required lambda formal must be a symbol" (car form)))
            (ac-lkbind-req (cdr form) env binds uses)))
      (m-bu binds uses))))

(define ac-lkbind-opt
  (lambda (form env binds uses)
    ;; optional segment of lambda binding
    (if (pair? form)
        (if (and (pair? (car form))
                 (eq? (caar form) 'd!d))
            (case (cadar form)
              ((rest) (ac-lkbind-rest (cdr form) env binds uses))
              ((key) (ac-lkbind-key (cdr form) env binds uses))
              (else (begin (spec-error "Invalid lambda key" (car form))
                           (m-bu binds uses))))
          (process-more-largs
           ac-lkbind-opt
           (cdr form)
           env
           binds
           uses
           (if (pair? (car form))
               (ac-let-term (car form) ft-var (append binds env) binds)
             (begin (set-car! alr-dummy (car form))
                    (ac-let-term alr-dummy ft-var
                                 (append binds env) binds)))))
      (m-bu binds uses))))

(define ac-lkbind-rest
  (lambda (form env binds uses)
    ;; rest variable of lambda binding
    (or (if (pair? form)
      (begin
      (if
        (symbol? (car form))
        (begin (set-car! alr-dummy (car form))
                       (set! binds (cons
                                    (car
                                     (bu-b
                                      (ac-let-term alr-dummy ft-var
                                                   env binds)))
                                    binds)))
        (spec-error "Rest binding must be a symbol" (car form)))
      (if (pair? (cdr form))
        (if (equal? (cadr form) '(d!d key))
          (ac-lkbind-key (cddr form) env binds uses)
          (spec-error "Only #!key allowed after #!rest binding"
                             (cdr form)))
        (m-bu binds uses)))
      (spec-error "No variable provided for #!rest" form))
        (m-bu binds uses))))

(define ac-lkbind-key
  (lambda (form env binds uses)
    ;; keyword segment of lambda binding
    ;; Should keep a table of user functions with calling sequence info
    (if (pair? form)
      (process-more-largs
           ac-lkbind-key
           (cdr form)
           env
           binds
           uses
           (if (pair? (car form))
               (ac-let-term (car form) ft-var (append binds env) binds)
             (begin (set-car! alr-dummy (car form))
                    (ac-let-term alr-dummy ft-var
                                 (append binds env) binds))))
      (m-bu binds uses))))

(define process-more-largs
  (lambda (fn form env binds uses res)
    ;; should unify this with process-more-args
    (fn form env (append (bu-b res) binds) (union (bu-u res) uses))))

(define ac-specq
  (lambda (form env)
    ;; special-query-forms
    (if (not (symbol? (car form)))
      (spec-error "Expected a symbol in special query form" (car form)))
    (process-more-args
     (list (cadr form))
     ac-body
     env
     '()
     (ac-eval (caddr form) (cons (cons (car form) ft-var) env)))))

(define ac-crl
  (lambda (form env)
    ;; construction rule list
    (if (thereis (lambda (x) (not
			      (and (pair? x)
				   (memq (car x)
					 '(query element id root default)))))
		 form)
	(spec-error "Mode spec. must consist entirely of construction rules: query, element, id, root, default" form))
    ;; we don't care about results, i.e. this is a walk, not an eval
    (let loop ((ptr form))
	 (if (pair? ptr)
	     (begin
	      (process-form (car ptr) env #t)
	      (loop (cdr ptr)))))
    (m-bu '() '())))

(define ac-qq
  ;;  backquote
  (lambda (form env)
    (spec-warning "Quasiquote checking not supported yet")
    (m-bu '() '())))

(define ac-uq
  ;; unquote
  (lambda (form env)
    (spec-error "Unquote not inside quasiquote" form)
    (m-bu '() '())))

(define ac-uqs
  ;; unquote-splicing
  (lambda (form env)
    (spec-error "Unquote-splicing not inside quasiquote" form)
    (m-bu '() '())))

(define diagnose-define
  (lambda (form top-level)
    ;; Normalise the two forms
    (if (and (pair? (cdr form))
	     (pair? (cadr form)))
	(let ((fal (cdr (cadr form))))
	  (set-car! (cdr form) (car (cadr form)))
	  (set-car! (cddr form) `(lambda ,fal ,(caddr form)))
	  'define-2)
      'define-1)))

(define diagnose-cond
  (lambda (form top-level)
    ;; check for special clause types
    (if (let loop ((ptr (cdr form)))
          (if (pair? ptr)
              (if (and (pair? (car ptr))
                       (list? (car ptr)))
                  (if (or (null? (cdr (car ptr))) ; singleton clause
                          (eq? (cadr (car ptr)) '=>))
                      #t
                    (loop (cdr ptr)))
                (begin (spec-error "Invalid cond clause" (car ptr))
                       (loop (cdr ptr))))
            #f))
        'cond-2
      'cond-1)))

(define diagnose-tlf
  (lambda (form top-level)
    ;; protect special top-level forms like define from redefinition (:-)
    (if top-level
        (set-car! form (dssslize (symbol->string (car form))))
      (spec-warning "Use of top-level form in non-top-level context" form))
    (car form)))

(define dssslize
  (lambda (ss)
    ;; make internal dsssl symbol from string
    (string->symbol
     (string-append "d!" ss))))

(define diagnose--
  (lambda (form top-level)
     (if (> (length form) 3)
         '--2
         '--1)))

(define diagnose-/
  (lambda (form top-level)
    (if (> (length form) 3)
         '/-2
         '/-1)))

(define diagnose-apply
  (lambda (form top-level)
    (if (> (length form) 3)
              'apply-2
            'apply-1)))

(define diagnose-let
  (lambda (form top-level)
    (if (symbol? (cadr form))
              'let-2
            'let-1)))

(define diagnose-lambda
  (lambda (form top-level)
    ;; Check for use of special declared constants (#!keys, #!opt, #!rest)
    (if (and (list? (cadr form))
             (let loop ((ptr (cadr form)))
               (if (pair? ptr)
                 (if (pair? (car ptr))
                   #t
                   (loop (cdr ptr)))
                 #f)))
         ;; DSSSL lambda
         (fix-form 'd!lambda-2 form)
         'lambda-1)))

(define fix-form
  (lambda (new-fn form)
    (set-car! form new-fn)
    new-fn))

;;; Access functions for calling sequence properties

(define t-lev
  (lambda (ev)
    (vector-ref ev 0)))
(define t-co
  (lambda (ev)
    (vector-ref ev 1)))
(define t-argn
  (lambda (ev)
    (vector-ref ev 2)))
(define t-pat
  (lambda (ev)
    (vector-ref ev 3)))

(define lookup-id
  (lambda (sym form prop tlc top-level)
    ;; find the right entry
    (and (symbol? sym)
	 (let* ((entry (get sym prop))
		(new-sym (if (and entry (procedure? (t-lev entry)))
			     ((t-lev entry) form top-level)
			   (if (memq sym tlc)
			       (diagnose-tlf form top-level)
			     #f))))
	   (if new-sym
	       (if (eq? sym new-sym)
		   ;; remap only possible in case of non-top-level tlf
		   #f
		 (lookup-id new-sym form prop tlc top-level))
	     entry)))))

(define record-decl
  (lambda (syms prop decl)
    (if (pair? syms)
	(for-each (lambda (sym) (put sym prop decl)) syms)
      (put syms prop decl))))

(define make-spec-form-decl
  (lambda (decl-list)
    (list->vector (if (null? (cdr decl-list))
		      decl-list
		    (list (car decl-list)
			  (cadr decl-list)
			  (caddr decl-list)
			  (cdddr decl-list))))))

;; Store basic information for code-walker

(for-each
 (lambda (ent)
   (record-decl (car ent) 'spec-form (make-spec-form-decl (cdr ent))))
 `(
   ;; expr core
   (quote ,ft-expr ,ft-core 1 ,ac-noval)
   (if ,ft-expr ,ft-core 3 . ,ac-evals)
   (cond ,diagnose-cond)
   (cond-1 ,ft-expr ,ft-core (1 . #f) . ,ac-cpairs)
   (case ,ft-expr ,ft-core (2 . #f) ,ac-eval . ,ac-cclauses)
   (and ,ft-expr ,ft-core #f . ,ac-evals)
   (or ,ft-expr ,ft-core #f . ,ac-evals)
   (define ,diagnose-define)		; special case depending on form
   (define-1 ,ft-expr ,ft-core 2 . ,ac-dlet-term)
   (d!c ,ft-expr ,ft-core 1 ,ac-char)	; character name
   (d!k ,ft-expr ,ft-core 1 ,ac-sym)	; keyword (should rarely occur free)
   (d!m ,ft-expr ,ft-core (2 . 3) ,ac-eval ,ac-qsym ,ac-eval)
   (d!g ,ft-expr ,ft-core 1 ,ac-eval)	; glyph id
   ;; expr opt
   (cond-2 ,ft-expr ,ft-opt (1 . #f) . ,ac-cpairs)
   (define-2 ,ft-expr ,ft-opt 2  . ,ac-dlet-term)
   (lambda ,diagnose-lambda)
   (lambda-1 ,ft-expr ,ft-opt (2 . #f) ,ac-lbind . ,ac-body)
   (d!lambda-2 ,ft-expr ,ft-opt (2 . #f) ,ac-lkbind . ,ac-body)
   (d!d ,ft-expr ,ft-opt 1 ,ac-sym)	; formal arg't separator
   (let ,diagnose-let)
   (let-1 ,ft-expr ,ft-opt (2 . #f) ,ac-let-bind . ,ac-body)
   (let-2 ,ft-expr ,ft-opt (3 . #f) ,ac-sbind ,ac-let-bind . ,ac-body)
   (let* ,ft-expr ,ft-opt (2 . #f) ,ac-let*-bind . ,ac-body)
   (letrec ,ft-expr ,ft-opt (2 . #f) ,ac-letr-bind . ,ac-body)
   ,(list 'quasiquote ft-expr ft-opt 1 ac-qq)
   ,(list 'unquote ft-expr ft-opt 1 ac-uq)
   ,(list 'unquote-splicing ft-expr ft-opt 1 ac-uqs)
   (d!define-unit ,ft-expr ,ft-opt 2 . ,ac-duterm)
   (d!declare-char-property ,ft-expr ,ft-opt 2 . ,ac-cpdecl)
   (d!add-char-properties ,ft-expr ,ft-opt (1 . #f) . ,ac-acp)
   (d!define-language ,ft-expr ,ft-opt (1 . 4) . ,ac-ln)
   ;; query opt
   ((there-exists? for-all? select-each union-for-each)
    ,ft-query ,ft-opt 3 . ,ac-specq)
   ;; style core
   (d!mode ,ft-style ,ft-core (1 . #f) ,ac-sym . ,ac-crl)
   (d!query ,ft-style ,ft-core 3 . ,ac-walks)
   (d!element ,ft-style ,ft-core 2 ,ac-syml . ,ac-walks)
   (d!default ,ft-style ,ft-core 1 . ,ac-walks)
   (d!root ,ft-style ,ft-core 1 . ,ac-walks)
   (d!id ,ft-style ,ft-core 2 ,ac-symstring . ,ac-walks)
   (make ,ft-style ,ft-core (1 . #f) ,ac-sym . ,ac-keysplus)
   (d!declare-flow-object-class ,ft-style ,ft-core 2 ,ac-sym ,ac-string)
   (with-mode ,ft-style ,ft-core 2 ,ac-symorf ,ac-eval)
   (style ,ft-style ,ft-core #f . ,ac-keys)
   (d!declare-characteristic ,ft-style ,ft-core 3 ,ac-sym ,ac-string ,ac-eval)
   (d!declare-char-characteristic+property ,ft-style ,ft-core 3 . ,ac-ccp)
   (d!declare-initial-value ,ft-style ,ft-core 2 ,ac-sym ,ac-eval)
   ;; style opt
   (d!declare-reference-value-type ,ft-style ,ft-opt 1 ,ac-sym)
   (d!define-page-model ,ft-style ,ft-opt (4 . #f) . ,ac-pmod)
   (d!define-column-set-model ,ft-style ,ft-opt
			      (1 . #f) . ,ac-csmod)
   ;; transform core
   (d!=> ,ft-transform ,ft-core 3  . ,ac-walks)
   (d!define-transliteration-map ,ft-transform ,ft-core 2 . ,ac-tle)
   ))

(define toplevel-cmds
  ;; special only at top level
  '(define-unit declare-initial-value define define-language
    declare-char-property add-char-properties => define-transliteration-map
    mode query element default root id declare-flow-object-class
    declare-characteristic declare-char-characteristic+property
    declare-reference-value-type define-page-model define-column-set-model))

(define toplevel-internals
  ;; internal forms of above
  '(d!define-unit d!declare-initial-value d!define-1 d!define-2
     d!define-language d!declare-char-property d!add-char-properties d!=>
     d!define-transliteration-map d!mode d!query d!element d!root d!default
     d!id d!declare-flow-object-class d!declare-characteristic
     d!declare-char-characteristic+property d!declare-reference-value-type
     d!define-page-model d!define-column-set-model))

(define funarg1to1-fns
  ;; functions which treat their first argument as a procedure of 1 arg
  '(map))

(define funarg1ton-fns
  ;; functions which treat their first argument as a procedure of unknown args
  '(apply))

(define funarg2to0-fns
  ;; functions which treat their second argument as a procedure of 0 args
  '(with-language))

;;; Store information about built-in functions for code-walker

(for-each
 (lambda (ent)
   (record-decl (car ent) 'builtin (list->vector (cdr ent))))
 `(
   ;; expr core
   (not ,ft-expr ,ft-core 1)
   (boolean? ,ft-expr ,ft-core 1)
   (equal? ,ft-expr ,ft-core 2)
   (null? ,ft-expr ,ft-core 1)
   (list? ,ft-expr ,ft-core 1)
   (list ,ft-expr ,ft-core #f)
   (length ,ft-expr ,ft-core 1)
   (append ,ft-expr ,ft-core #f)
   (reverse ,ft-expr ,ft-core 1)
   (list-tail ,ft-expr ,ft-core 2)
   (list-ref ,ft-expr ,ft-core 2)
   (member ,ft-expr ,ft-core 2)
   ((symbol? keyword? quantity? number? real? integer?) ,ft-expr ,ft-core 1)
   ((= < > <= >=),ft-expr ,ft-core (2 . #f))
   ((max min) ,ft-expr ,ft-core (1 . #f))
   (+ ,ft-expr ,ft-core #f)
   (* ,ft-expr ,ft-core #f)
   (- ,diagnose--)
   (--1 ,ft-expr ,ft-core (1 . 2))
   (/ ,diagnose-/)
   (/-1 ,ft-expr ,ft-core (1 . 2))
   (abs ,ft-expr ,ft-core 1)
   ((quotient remainder modulo) ,ft-expr ,ft-core 2)
   ((floor ceiling truncate round) ,ft-expr ,ft-core 1)
   (sqrt ,ft-expr ,ft-core 1)
   (number->string ,ft-expr ,ft-core (1 . 2))
   (string->number ,ft-expr ,ft-core (1 . 2))
   (char? ,ft-expr ,ft-core 1)
   (char=? ,ft-expr ,ft-core 2)
   (char-property ,ft-expr ,ft-core (2 . 3))
   (string? ,ft-expr ,ft-core 1)
   (string ,ft-expr ,ft-core #f)
   (string-length ,ft-expr ,ft-core 1)
   (string-ref ,ft-expr ,ft-core 2)
   (string=? ,ft-expr ,ft-core 2)
   (substring ,ft-expr ,ft-core 3)
   (string-append ,ft-expr ,ft-core #f)
   (format-number ,ft-expr ,ft-opt 2)
   (format-number-list ,ft-expr ,ft-opt 3)
   (procedure? ,ft-expr ,ft-core 1)
   (apply ,diagnose-apply)
   (apply-1 ,ft-expr ,ft-core 2)
   (external-procedure ,ft-expr ,ft-core 1)
   (time ,ft-expr ,ft-core 0)
   (time->string ,ft-expr ,ft-core (1 . 2))
   (error ,ft-expr ,ft-core 1)
   ;; opt
   (pair? ,ft-expr ,ft-opt 1)
   (cons ,ft-expr ,ft-opt 2)
   ((car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar
     cdddr caaar caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
     cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) ,ft-expr ,ft-opt 1)
   (assoc ,ft-expr ,ft-opt 2)
   ((symbol->string string->symbol keyword->string string->keyword)
    ,ft-expr ,ft-opt 1)
   ((exact? inexact?) ,ft-expr ,ft-opt 1)
   ((zero? positive? negative? odd?  even?) ,ft-expr ,ft-opt 1)
   (--2 ,ft-expr ,ft-opt (1 . #f))
   (/-2 ,ft-expr ,ft-opt (2 . #f))
   ((exp log sin cos tan asin acos) ,ft-expr ,ft-opt 1)
   (atan ,ft-expr ,ft-opt (1 . 2))
   (expt ,ft-expr ,ft-opt 2)
   ((exact->inexact inexact->exact) ,ft-expr ,ft-opt 1)
   (quantity->number ,ft-expr ,ft-opt 1)
   (language? ,ft-expr ,ft-opt 1)
   (current-language ,ft-expr ,ft-opt 0)
   (with-language ,ft-expr ,ft-opt 2)
   ((char<? char>? char<=? char>=?
	    char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?) ,ft-expr ,ft-opt 2)
   ((char-upcase char-downcase) ,ft-expr ,ft-opt 1)
   (string-ci=? ,ft-expr ,ft-opt 2)
   (string-equiv? ,ft-expr ,ft-opt 3)
   ((string<? string>? string<=? string>=?
	      string-ci<? string-ci>? string-ci<=? string-ci>=?) ,ft-expr ,ft-opt 2)
   ((string->list list->string) ,ft-expr ,ft-opt 1)
   (apply-2 ,ft-expr ,ft-opt (2 . #f))
   (map ,ft-expr ,ft-opt 2)
   ((time<? time>? time<=? time>=?) ,ft-expr ,ft-opt 1)
   ;; query core
   (current-node ,ft-query ,ft-core 0)
   ((node-list? node-list-empty?) ,ft-query ,ft-core 1)
   (node-list-error ,ft-query ,ft-core 2)
   (parent ,ft-query ,ft-core 1)
   (ancestor ,ft-query ,ft-core (1 . 2))
   ((gi first-child-gi id) ,ft-query ,ft-core (0 . 1))
   ((child-number element-number) ,ft-query ,ft-core (0 . 1))
   ((ancestor-child-number hierarchical-number hierarchical-number-recursive
			   element-number-list)
    ,ft-query ,ft-core (1 . 2))
   ((attribute-string inherited-attribute-string) ,ft-query ,ft-core (1 . 2))
   (inherited-element-attribute-string ,ft-query ,ft-core (2 . 3))
   ((first-sibling? absolute-first-sibling? last-sibling?
		    absolute-last-sibling?)
    ,ft-query ,ft-core (0 . 1))
   (have-ancestor? ,ft-query ,ft-core (1 . 2))
   ((entity-public-id entity-system-id entity-generated-system-id
		      entity-text entity-notation entity-type notation-public-id
		      notation-system-id notation-generated-system-id) ,ft-query ,ft-core (1 . 2))
   (entity-attribute-string ,ft-query ,ft-core (2 . 3))
   ((general-name-normalize entity-name-normalize) ,ft-query ,ft-core (1 . 2))
   ;; query opt
   (current-root ,ft-query ,ft-opt 0)
   ((node-list-first node-list-rest node-list-no-order) ,ft-query ,ft-opt 1)
   (node-list ,ft-query ,ft-opt (1 . #f))
   (node-list=? ,ft-query ,ft-opt 2)
   ((named-node-list? named-node-list-names) ,ft-query ,ft-opt 1)
   (named-node ,ft-query ,ft-opt 2)
   (named-node-list-normalize ,ft-query ,ft-opt 3)
   (node-property ,ft-query ,ft-opt (2 . 8)) ; default: null: rcs?:
   (sgml-parse ,ft-query ,ft-opt (1 . 5)) ; active: parent:
   (value-proploc ,ft-query ,ft-opt (2 . 6)) ; apropsrc?: default:
   ((list-proploc node-list-proploc)
    ,ft-query ,ft-opt (2 . 6))		; apropsrc?: ignore-missing?:
   (listloc  ,ft-query ,ft-opt (2 . 4)) ; overrun:
   (nameloc ,ft-query ,ft-opt (2 . 4))	; ignore-missing?:
   (groveloc ,ft-query ,ft-opt (2 . 4)) ; overrun:
   ((treeloc pathloc) ,ft-query ,ft-opt (2 . 6)) ; overrun: treecom?:
   ((relloc-anc relloc-esib relloc-ysib relloc-des)
    ,ft-query ,ft-opt (2 . 4))		; overrun:
   (datatok ,ft-query ,ft-opt (1 . 25)) ; filter: concat: catsrcsp: catressp:
					; tokensep: ascp: stop: min: max:
					; nlword: stem?:
   ((make-grove compare span) ,ft-query ,ft-opt 2)
   ((literal-match hylex-match) ,ft-query ,ft-opt (2 . 10)) ; level: boundary:
					; min-hits: max-hits:
   ((ordered-may-overlap? ordered-no-overlap?) ,ft-query ,ft-opt 1)
   (empty-node-list ,ft-query ,ft-opt 0)
   (node-list-reduce ,ft-query ,ft-opt 3)
   (node-list-contains? ,ft-query ,ft-opt 2)
   (node-list-remove-duplicates ,ft-query ,ft-opt 1)
   ((node-list-union node-list-intersection node-list-difference
		     node-list-symmetric-difference) ,ft-query ,ft-opt #f)
   ((node-list-map node-list-union-map node-list-some? node-list-every?
		   node-list-filter)
    ,ft-query ,ft-opt 2)
   ((node-list->list node-list-length node-list-reverse node-list-count
		     node-list-last)
    ,ft-query ,ft-opt 1)
   ((node-list-ref node-list-tail node-list-head)  ,ft-query ,ft-opt 2)
   (node-list-sublist ,ft-query ,ft-opt 3)
   (node-list-property ,ft-query ,ft-opt 2)
   ((origin origin-to-subnode-rel tree-root grove-root children data
	    source subtree subgrove descendants ancestors grove-root-path rsiblings
	    ipreced ifollow preced follow sort-in-tree-order tree-before)
    ,ft-query ,ft-opt 1)
   ((grove-before? tree-before? select-by-class select-by-null-property
		   select-by-missing-property)
    ,ft-query ,ft-opt 2)
   (select-by-property ,ft-query ,ft-opt 3)
   (property-lookup ,ft-query ,ft-opt 4)
   ((attributes referent) ,ft-query ,ft-opt 1)
   ((attribute element-with-id match-element? select-elements) 
	       ,ft-query ,ft-opt 2)
   ((q-element q-class q-sdata) ,ft-query ,ft-opt (1 . 2))
   (word-parse ,ft-query ,ft-opt (1 . 2))
   (select-tokens ,ft-query ,ft-opt 2)
   (regexp? ,ft-query ,ft-opt 1)
   ((regexp-node regexp-rep regexp-opt regexp-plus string->regexp)
    ,ft-query ,ft-opt 1)
   ((regexp-seq regexp-or regexp-and) ,ft-query ,ft-opt (1 . #f))
   (regexp-range ,ft-query ,ft-opt 3)
   ((regexp-search regexp-search-disjoint) ,ft-query ,ft-opt 2)
   ;; style core
   ((sosofo? process-node-list) ,ft-style ,ft-core 1)
   ((literal process-matching-children process-first-descendant
     sosofo-append next-match) ,ft-style ,ft-core #f)
   ((empty-sosofo process-children process-children-trim) ,ft-style ,ft-core 0)
   ((map-constructor sosofo-label sosofo-discard-labeled) ,ft-style ,ft-core 2)
   (next-match ,ft-style ,ft-core (0 . 1))
   (style? ,ft-style ,ft-core 1)
   (merge-style ,ft-style ,ft-core #f)
   (char-script-case ,ft-style ,ft-core #f)
   (display-space? ,ft-style ,ft-core 1)
   (display-space ,ft-style ,ft-core (1 . 9)) ; min: max:
                                              ; conditional?: priority:
   (inline-space? ,ft-style ,ft-core 1)
   (inline-space ,ft-style ,ft-core (1 . 5)) ; min: max:
   ((glyph-id? glyph-id) ,ft-style ,ft-core 1)
   ((glyph-subst-table? glyph-subst-table) ,ft-style ,ft-core 1)
   (glyph-subst ,ft-style ,ft-core 2)
   ((address? address-local? address-visited? idref-address entity-address
     node-list-address) ,ft-style ,ft-core 1)
   ((hytime-linkend current-node-address) ,ft-style ,ft-core 0)
   (sgml-document-address ,ft-style ,ft-core 2)
   ((color-space color) ,ft-style ,ft-core (1 . #f))
   ((color-space? color?) ,ft-style ,ft-core 1)
   ;; style optional
   (sync ,ft-style ,ft-opt (2 . 8)) ; type: min: max:
   (side-sync ,ft-style ,ft-opt 1)
   (generated-object? ,ft-style ,ft-opt 1)
   (general-indirect-sosofo ,ft-style ,ft-opt (1 . #f))
   ((process-element-with-id asis-indirect-sosofo) ,ft-style ,ft-opt 1)
   (number-indirect-sosofo ,ft-style ,ft-opt (1 . 7)) ; format: add: multiple:
   ((page-number category-page-number column-number) ,ft-style ,ft-opt (0 . 4))
				; first-area-of-node: last-area-of-node:
   ((page-number-in-node total-node-page-numbers) ,ft-style ,ft-opt 1)
   ((footnote-number line-number) ,ft-style ,ft-opt (1 . 5))
				; first-area-of-node: last-area-of-node:
   ((first-area-reference-value last-area-reference-value)
    ,ft-style ,ft-opt (1 . 5)) ; default: inherit:
   (last-preceding-area-reference-value ,ft-style ,ft-opt (1 . 3)) ; default:
   (all-area-reference-values ,ft-style ,ft-opt (1 . 5)) ; unique: inherit:
   (display-size ,ft-style ,ft-opt 0)
   (length-spec? ,ft-style ,ft-opt 1)
   (decoration-area ,ft-style ,ft-opt (1 . 7)) ; placement-point-x: placement-point-y:
                             ; placement-direction:
   ((decorated-area-width decorated-area-height) ,ft-style ,ft-opt 0)
   (font-property ,ft-style ,ft-opt (2 18))
				 ; size: name: family-name: weight: posture:
                          ; structure: proportionate-width: writing-mode:
   (page-model? ,ft-style ,ft-opt 1)
   (column-set-model? ,ft-style ,ft-opt 1)
   ((page-number-sosofo current-node-page-number-sosofo) ,ft-style ,ft-opt 0)
   (table-unit ,ft-style ,ft-opt 1)
   ;; transform core
   (create-spec? ,ft-transform ,ft-core 1)
   (create-root ,ft-transform ,ft-core 2)
   ((select-by-relation select-by-attribute-token) ,ft-transform ,ft-core 3)
   (transform-grove-spec? ,ft-transform ,ft-core 1)
   (select-grove ,ft-transform ,ft-core 2)
   (sgml-parse-prolog ,ft-transform ,ft-core 1)
   (transliteration-map? ,ft-transform ,ft-core 1)
   ;; transform optional
   (subgrove-spec ,ft-transform ,ft-core (0 . 20)); node: subgrove: class: add:
					; null: remove: children: sub:
					; label: sort-children:
   (create-sub ,ft-transform ,ft-core (2 . 12)) ; property: label: result-path
					; optional: unique:
   ((create-preced create-follow)
    ,ft-transform ,ft-core (2 . 10))	; label: result-path: optional: unique:
   (transform-grove ,ft-transform ,ft-core (1 . #f))
   ))

(define characters
  ;; should be all of ASCII
  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$%&*/:<=>?~_")

(define predef-idents
  ;; Builtin identifiers of various types
  `((m . ,ft-unit)
    (cm . ,ft-unit)
    (mm . ,ft-unit)
    (in . ,ft-unit)
    (pt . ,ft-unit)
    (pica . ,ft-unit)
    (numeric-equiv . ,ft-chpr)
    ,@(let loop ((i (- (string-length characters) 1))
                 (res '()))
        (if (>= i 0)
          (loop (- i 1)(cons (cons (string (string-ref characters i)) ft-chn)
                             res))
          res))))

(define inherited-characteristics
  ;; I THINK this is the correct list
  '(align-leader? alignment-point-offset allowed-ligatures
    anchor-keep-with-previous? annotation-glyph-placement
    annotation-glyph-style asis-truncate-char asis-wrap-char
    asis-wrap-indent background-color background-layer background-tile
    binding-edge blank-back-page-model blank-front-page-model
    border-alignment border-omit-at-break? border-present?
    border-priority bottom-margin box-border-alignment
    box-corner-radius box-corner-rounded box-open-end? box-size-after
    box-size-before box-type cell-after-column-border
    cell-after-column-margin cell-after-row-border
    cell-after-row-margin cell-background? cell-before-column-border
    cell-before-column-margin cell-before-row-border
    cell-before-row-margin cell-crossed cell-row-alignment char-map
    color column-set-model-map column-set-model contents-alignment
    country denominator-align display-alignment end-indent end-margin
    escapement-space-after escapement-space-before expand-tabs? expand-tabs
    field-align field-width filling-direction first-line-align
    first-line-start-indent first-page-type float-out-line-numbers?
    float-out-marginalia? float-out-sidelines? font-family-name
    font-name font-posture font-proportionate-width font-size
    font-structure font-weight footer-margin force-first-page
    force-last-page fraction-bar glyph-alignment-mode
    glyph-reorder-method glyph-subst-method glyph-subst-table
    grid-column-alignment grid-equidistant-columns?
    grid-equidistant-rows? grid-position-cell-type grid-row-alignment
    hanging-punct? header-margin hyphenate? hyphenation-char
    hyphenation-exceptions hyphenation-keep hyphenation-ladder-count
    hyphenation-method hyphenation-push-char-count
    hyphenation-remain-char-count ignore-record-end?
    implicit-bidi-method inhibit-line-breaks? initial-page-models
    inline-note-line-count inline-note-style inline-space-space
    input-whitespace-treatment justify-glyph-space-max-add
    justify-glyph-space-max-remove justify-spread? kern-mode kern?
    language last-line-end-indent last-line-justify-limit
    last-line-quadding layer left-margin ligature?
    line-breaking-method line-cap line-composition-method line-dash
    line-join line-miter-limit line-number-sep line-number-side
    line-number line-repeat line-sep line-spacing-priority
    line-spacing line-thickness lines marginalia-keep-with-previous?
    marginalia-sep marginalia-side mark-distribution mark-style
    math-display-mode min-leader-repeat min-leading
    min-post-line-spacing min-pre-line-spacing numbered-lines?
    numerator-align orphan-count overflow-action page-category
    page-height page-width position-point-shift
    principal-mode-simultaneous? quadding repeat-page-models
    right-margin score-spaces? script-mid-sub-align
    script-mid-sup-align script-post-align script-pre-align
    side-by-side-overlap-control side-by-side-post-align
    side-by-side-pre-align sideline-sep sideline-side span-weak? span
    start-indent start-margin table-auto-width-method table-border
    table-corner-radius table-corner-rounded
    table-part-omit-middle-footer? table-part-omit-middle-header?
    top-margin truncate-leader? widow-count writing-mode))

(let ((vect (list->vector `(,ft-style ,ft-opt 0))))
  (for-each
   (lambda (characteristic)
     (record-decl (string->symbol
		   (string-append "inherited-"
				  (symbol->string characteristic)))
		  'builtin
		  vect)
     (record-decl (string->symbol
		   (string-append "actual-"
				  (symbol->string characteristic)))
		  'builtin
		  vect))
   inherited-characteristics))
