;;; dsssl.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

;;; dsssl expression language reader and code walker
;;; Last edited: Wed Aug 14 12:22:39 1996

(define *debugging* #f)

;;; The first section provides support for a table to record feature usage

(define ft-names
  ;; names of the usage types
  '(rw                                  ; reserved words
    tlk                                 ; toplevel-form keyword
    fn                                  ; builtin function
    var                                 ; user-defined
    unit                                ; quantities
    foc                                 ; flow-object classes
    icn                                 ; inherited characteristics
    chn                                 ; character names
    chpr                                ; character properties
    ))

(define ft-fullnames
    '("reserved words"
    "toplevel-form keyword"
    "builtin function"
    "user-defined variable"
    "quantity"
    "flow-object class"
    "inherited characteristic"
    "character name"
    "character property"
    ))

(define feature-table
  ;; a three-d table indexed by area (expression, query, style and transform),
  ;; level (core and optional) and type (rw, fn or var)
  (let ((top (make-vector 4))
        (type-n (length ft-names)))
    (let loop ((n 3))
      (if (>= n 0)
          (let ((mid (make-vector 2)))
            (vector-set! mid 0 (make-vector type-n))
            (vector-set! mid 1 (make-vector type-n))
            (vector-set! top n mid)
            (loop (- n 1)))))
    top))

(define init-feature-table
  (lambda ()
    ;; set all feature-table cells to ()
    (let* ((type-n (length ft-names))
           (i-f-t (lambda (vect)
                   (let loop ((i 0))
                        (if (< i type-n)
                            (begin
                             (vector-set! vect i '())
                             (loop (+ i 1))))))))
      (let loop ((n 3))
        (if (>= n 0)
            (begin (i-f-t (vector-ref
                           (vector-ref feature-table n)
                           0))
                   (i-f-t (vector-ref
                           (vector-ref feature-table n)
                           1))
                   (loop (- n 1))))))))

(define display-ft
  (lambda ()
    (letrec ((dft1 (lambda (vect name)
                     (display name log-port)
                     (dft2 (vector-ref vect 0) 'core)
                     (dft2 (vector-ref vect 1) 'opt)))
             (dft2 (lambda (vect name)
                     (newline log-port)
                     (display "  " log-port)
                     (display name log-port)
                     (let loop ((i 0)
                                (names ft-names))
                          (if (pair? names)
                              (begin
                               (dft3 (vector-ref vect i) (car names))
                               (loop (+ i 1)(cdr names)))))))
             (dft3 (lambda (ul name)                     
                     (if (pair? ul)
                       (begin(newline log-port)
                     (display "    " log-port)
                     (display name log-port)
                     (display ":" log-port)
                         (map (lambda (elt)
                                (display " " log-port)
                                (display elt log-port))
                              ul))))))
      (let loop ((n 0)
                 (names '(expr query style transform)))
           (if (< n 4)
               (begin (dft1 (vector-ref feature-table n) (car names))
                      (newline log-port)
                      (loop (+ n 1) (cdr names))))))))

;;; constants for indexing into feature table
(define ft-expr 0)
(define ft-query 1)
(define ft-style 2)
(define ft-transform 3)

(define ft-core 0)
(define ft-opt 1)

(define ft-rw 0)
(define ft-tlk 1)
(define ft-fn 2)
(define ft-var 3)
(define ft-unit 4)
(define ft-foc 5)
(define ft-icn 6)
(define ft-chn 7)
(define ft-chpr 8)

(define record-use
  (lambda (area level type name)
    ;; record a use of a name in a cell in feature-table
    (let* ((type-vect (vector-ref (vector-ref feature-table area)
                                  level))
           (old-val (vector-ref type-vect type)))
      (if (not (memq name old-val))
          (vector-set! type-vect type (cons name old-val))))))

;;; Next some simple error reporting support

(define expr-n
  ;; index in file of current expression
  0)

(define nerrs
  ;; number of total errors
  0)

(define log-port
  ;; port for all output messages
  (current-output-port))

(define spec-msg
  (lambda (type-msg usr-msgs)
    ;; warning or error
    (display type-msg log-port)
    (if (= line-no -1)
	(display " at EOF" log-port)
      (begin
       (display " in expression " log-port)
       (display expr-n log-port)
       (display " at line " log-port)
       (let ((fltr form-line-tbl)
	     (entry #f)
	     (lform (or (thereis (lambda (form)
				   (and (pair? form)
					(eq? (car form) 'd!ind)))
				 usr-msgs)
			(thereis pair? usr-msgs))))
	 (if lform (set! entry (assq (if (eq? (caar lform) 'd!ind)
					 (cdar lform)
				       (car lform))
				     fltr)))
	 (if (not entry)
	     ;; pair not found or no pair to be found
	     ;; look one level down for atom or string
	     (let ((fltr (reverse fltr)))
	       (let loop ((ptr usr-msgs))
		    (if (pair? ptr)
			(begin 
			 (if (or (string? (car ptr))
				 (symbol? (car ptr))) ; float?
			     (set! entry
				   (thereis (lambda (x) (and (list? (car x))
							     (memq (car ptr)
							      (car x))))
					    fltr)))
			 (if entry
			     (set! entry (car entry))
			   (loop (cdr ptr))))))))
	 (display
	  (if entry (cdr entry) 
		 (if (pair? fltr)
		     (if (pair? (car fltr))
			 (cdar fltr)
		       (car fltr))
		   "source not found"))
	  log-port))))
    (display ":" log-port)
    (map (lambda (msg)
           (write-char #\space log-port)
	   (if (not (and (pair? msg)
			 (eq? (car msg) 'd!ind)))
	       (display (if (and (pair? msg)
				 (eq? (car msg) 'd!sum))
			    (summ (cdr msg))
			  msg)
			log-port)))
         usr-msgs)
    (newline log-port)))

(define *d!repping* #f)

(define spec-error
  (lambda msgs
    ;; use this to report specification errors
    (set! nerrs (+ nerrs 1))
    (spec-msg "Spec. error" msgs)
    (if *d!repping*
	(error 'dsssl "DSSSL syntax error"))))

(define spec-warning
  (lambda msgs
    ;; use this to report warnings
    (spec-msg "Spec. warning" msgs)))

;;; Main entry point

(define read-spec
  (lambda (filename quiet? out-fn)
    ;; Returns list of form-specs, one per top-level form
    ;; Tabulates usage in feature-table
    (init-feature-table)
    (set! expr-n 0)
    (set! line-no 1)
    (set! nerrs 0)
    (let ((part-no 1)
	  (expr-no 0))
      (let ((rs1 (lambda (port)
		   (let loop ((result '()))
			(set! form-line-tbl '())
			(let ((form (d!read port)))
			  (if (eq? form 'd!part-separator)
			      (begin (set! part-no (+ part-no 1))
				     (set! expr-no 0)
				     (loop result))
			    (set! expr-n (+ 1 expr-n))
			    (set! expr-no (+ 1 expr-no))
			    (if (eof-object? form)
				(post-process (if (pair? result)
						  (car result)
						'())
					      quiet?
					      out-fn)
			      (loop
			       (let ((pf (process-form form '() 'file)))
				 (if (pair? pf)
				     (tconc
				      result
				      ;; single binding only
				      (cons (m-bu (if (pair? (bu-b pf))
						      (begin
							(if (pair? (cdr
								    (bu-b pf)))
							    (sce-error
							     'shouldnt "4"))
							(car (bu-b pf)))
						    #f)
						  (bu-u pf))
					    (cons form
						  (cons
						   part-no
						   expr-no))))
				   result))))))))))
	(if (string=? "-" filename)
	    (rs1 (current-input-port))
	  (call-with-input-file filename rs1))))
    nerrs))

(define post-process
  (lambda (pf-list quiet? out-fn)
    ;; pf-list is a list of forms and process-form output
    ;; Each element is of the form
    ;; ((binding . uses) form part-no . expr-no)
    (if (not quiet?) (display-ft))
    (let ((done '())
	  (done-lambdas '())
	  (rem-first
	   (lambda (key?-fn)
	     (let loop ((prev #f)
			(ptr pf-list))
	       (if (pair? ptr)
		   (let ((head (car ptr)))
		     (if (key?-fn head)
			 (begin (if prev
				    (set-cdr! prev (cdr ptr))
				  (set! pf-list (cdr ptr)))
				head)
		       (loop ptr (cdr ptr))))
		 #f))))
	  (redef?
	   (lambda (pf)
	     (and (pair? (bu-b (car pf)))
		  (number? (cdr (bu-b (car pf))))
		  (= (cdr (bu-b (car pf))) ft-fn)))))
      (let
	  ((not-done?
	    (lambda (b pn en)
	      (if (and b (number? (cdr b))(= (cdr b) ft-rw))
		  (begin (spec-error "Attempt to redefine rw ignored"
				     (car b) "in part" pn "expr" en)
			 #f)
		(or (not b)
		    (let ((ent (assoc b done)))
		      (if ent
			  (begin
			    (if (memq pn (cdr ent))
				(spec-error
				 "attempted within-part redefinition of symbol"
				 (car b) "with type"
				 (list-ref ft-fullnames (cdr b)) "in part" pn
				 "expr" en)
			      (begin
				(set-cdr! ent (cons pn (cdr ent)))
				(spec-warning
				 "redefinition of" (car b) "with type"
				 (list-ref ft-fullnames (cdr b))
				 "in part" pn "expr" en "ignored")))
			    #f)
			#t))))))
	   (note-done
	    (lambda (b pn)
	      (if (pair? b)
		  (if (pair? (cdr b))
			;; lambda usage
		      (begin
			(set! done-lambdas
			      (cons b done-lambdas))
			(set! done (cons (list (cons (car b) ft-var) pn)
					 done)))
		    (set! done (cons (list b pn) done))))))
	   (find-redef (lambda () (rem-first redef?)))
	   (next-def (lambda ()
		       (if (pair? pf-list)
			   (let ((tmp (car pf-list)))
			     (set! pf-list (cdr pf-list))
			     tmp)
			 #f))))
	(letrec
	    ((out-preconds
	      (lambda (uses indep? self pn en)
		(if (pair? uses)
		    (let ((use (car uses)))
		      (if (not (or (memq (cdr use) `(,ft-rw ,ft-tlk ,ft-fn))
				   (and self (eq? (car use) self)
					(number? (cdr use))
					(= (cdr use) ft-var))))
			  (if (assoc use done)
			      (if (= (cdr use) ft-var)
				  (let ((lent (assq (car use) done-lambdas)))
				    (if lent
					;; applicative use of done lambda
					(out-preconds (cdr lent) #f
						      (car lent) pn en))))
			    (if (not (member use predef-idents))
				;; Not in done -- find it and put it first
				(let ((hit (rem-first
					    (lambda (tpf)
					      (or
					       (equal? (bu-b (car tpf))
						       use)
					       ;; lambda
					       (and
						(= (cdr use) ft-var)
						(bu-b (car tpf))
						(eq? (car (bu-b (car tpf)))
						     (car use))
						(pair? (cdr (bu-b
							     (car tpf))))))))))
				  (if hit
				      (out-with-pre hit #f pn en)
					(spec-warning
					 "Unbound symbol" (car use) "with type"
					 (list-ref ft-fullnames (cdr use))
					 "used in part" pn
					 "expr" en))))))
		      (out-preconds (cdr uses) indep? self pn en)))))
	     (out-with-pre
	      (lambda (pf indep? pn en)
		(if (and (not indep?)
			 (bu-b (car pf))
			 (pair? (cdr (bu-b (car pf)))))
		    ;; applicative use of a lambda binding, chase the usages
		    (out-preconds (cdr (bu-b (car pf))) #f
				  (car (bu-b (car pf))) pn en))
		(if (not-done? (bu-b (car pf))
			       (caddr pf)
			       (cdddr pf))
		    (begin
		      (out-preconds (bu-u (car pf))
				    indep?
				    (and (bu-b (car pf))
					 (number? (cdr (bu-b (car pf))))
					 (= (cdr (bu-b (car pf))) ft-var)
					 (list? (caddr (cadr pf)))
					 (memq
					  (car (caddr (cadr pf)))
					  '(d!lambda d!lambda-2))
					 (car (bu-b (car pf))))
				    (caddr pf)(cdddr pf))
		      (out-fn (cdr pf))
		      (note-done (bu-b (car pf))
				 (caddr pf)))))))
	  (let ((looper (lambda (next-fn)
			  (let loop ((top (next-fn)))
			    (if top
				(begin (out-with-pre top #t
						     (caddr top)(cdddr top))
				       (loop (next-fn))))))))
	    (looper find-redef)
	    (looper next-def)))))))

;;; Results of processing are often a pair of bindings (an alist) and
;;; free uses (another alist)
(define m-bu cons)
(define bu-b car)
(define bu-u cdr)

(define report-nargs-errors #t)		; fake fluid-bound flag, see ac-procn

(define process-form
  (lambda (form env top-level)
    (if *debugging*
        (begin
         (display form)
         (display env)
         (display " ")
         (display top-level)
         (newline)))      
    (if (pair? form)
        (let ((type #f)
              (pattern #f)
              (uses '())
              (entry (lookup-id (car form) form 'spec-form
                                toplevel-cmds top-level)))
          (if (not (list? form))
              (begin (spec-error "non-null tail" form)
                     (append! form '()) ; clobbers last tail with ()
                     ))
          (if entry
              (begin (set! type (if (memq (car form) toplevel-internals)
                                    ft-tlk
				  (let ((ss (symbol->string (car form))))
				    (if (not (equal? "d!" (substring ss 0 2)))
					(set-car! form
						  (dssslize ss)))
				    ft-rw)))
                     (set! pattern (t-pat entry)))
            (begin
             (if (eq? top-level 'file)
                 (spec-error "procedure calls not allowed at top level"))
             (set! entry (lookup-id (car form) form 'builtin
                                    '() top-level))
             (set! pattern (if (memq (car form) funarg1to1-fns)
                               ac-proc1
                               (if (memq (car form) funarg2to0-fns)
                                 `(,ac-eval . ,ac-proc0)
				 (if (memq (car form) funarg1ton-fns)
				     ac-procn
				   ac-evals))))
             (if entry (begin (set! type ft-fn)
			      (set-car! form (dssslize (symbol->string
							(car form))))))))
          (if *debugging*
              (begin
                (display type)
                (display (car form))
                (newline)))
          (if entry
              (let ((arg-spec (t-argn entry))
                    (ln (length (cdr form))))
                ;; check calling sequence
                (if (or (and (number? arg-spec)
                             (not (= ln arg-spec)))
                        (and (pair? arg-spec)
                             (or (< ln (car arg-spec))
                                 (and (number? (cdr arg-spec))
                                      (> ln (cdr arg-spec))))))
		    (if report-nargs-errors
			(spec-error "builtin function"
				    (car form)
				    "requires"
				    (cond ((number? arg-spec)
					   arg-spec)
					  (else
					   (string-append (number->string
							   (car arg-spec))
							  " or "
							  (if (number?
							       (cdr arg-spec))
							      (number->string
							       (cdr arg-spec))
							    "more"))))
				    "arguments but is called here"
				    (cons 'd!sum form) "with" ln
				    (cons 'd!ind form))))
                ;; enter in feature-table
                (record-use (t-lev entry) (t-co entry) type (car form))
                (set! uses (list (cons (car form) type)))
                )
              ;; unknown or computed fn
              (cond ((and (symbol? (car form))
                          (assq (car form) env))
                     =>
                     (lambda (binding)
                       (if (list? (cdr binding))
                         (set! uses  (cdr binding))
                         (spec-warning "possible application of non-procedure"
                                    form))))
                    ((and (pair? (car form))
                          (memq (caar form) '(d!lambda d!lambda-2)))
                     (set! uses (process-form (car form) env #f))
                     (set! entry #t)))
            )
          (let ((res (process-args
                      (if entry (cdr form) form) ; note open lambda
                                        ; handled here
                      pattern
                      env
                      uses
                      top-level)))
            (if *debugging*
                (begin (display "->")
                       (display res)
                       (newline)))
            (if top-level
                res
              (begin
               (if (pair? (bu-b res))
                   (spec-error "Binding form not allowed here" form))
               (bu-u res)))))
      (if (eq? top-level 'file)
          (spec-error "Not allowed at top level:" form)
        (if (symbol? form)
            (if (assq form env)
                '()
              (list (cons form ft-var)))
          '())))))

(define process-args
  (lambda (arg-list pattern env uses top-level)
    ;; Destructuring pattern match, accumulating free uses for return,
    ;; propagating environment changes
    ;; Opaque to bindings except at top level
;;;    (display arg-list)
;;;    (display pattern)
    (if (pair? arg-list)
        (if (procedure? pattern)
            ;; give it the whole thing
            (let ((res (pattern arg-list env)))
              (if top-level
                  res
                (begin(if (pair? (bu-b res))
                          (sce-error 'shouldnt "3"))
                      (m-bu '() (union uses (bu-u res))))))
          (if (pair? pattern)
              (process-more-args (cdr arg-list)
                                 (cdr pattern)
                                 env
                                 uses
                                 ((car pattern)(car arg-list) env))
            (sce-error 'shouldnt "1")))
      (if (null? arg-list)
          (m-bu '() uses)
        (sce-error 'shouldnt "2")))))

(define process-more-args
  (lambda (arg-list pattern env uses updates)
    (process-args arg-list pattern (append! (bu-b updates) env)
                  (union uses (bu-u updates)) #f)))



