#!/usr/local/bin/siod -v01,-m2 -*-mode:lisp-*-

;; name:     chtml
;; purpose:  A chunk html compiler. The resulting binary file
;;           can be used as an html template without any
;;           string searching or pattern matching at runtime.
;; author:   George Carrette.
(define *chtml-cmp-id*
  "$Id: chtml-cmp.scm,v 1.16 1998/06/19 16:33:05 gjc Exp $")
;;
;; COPYRIGHT (c) 1995-1996 BY NEWS INTERNET SERVICES
;; ALL RIGHTS RESERVED.
;;
;; Permission to use, copy, modify, distribute and sell this software
;; and its documentation for any purpose and without fee is hereby
;; granted, provided that the above copyright notice appear in all
;; copies and that both the copyright notice and this permission
;; notice appear in supporting documentation, and that the name of
;; News Internet Services not be used in advertising or publicity
;; pertaining to distribution of the software without specific,
;; written prior permission.
;; 
;; THIS SOFTWARE IS MADE AVAILABLE WITHOUT CHARGE, AS-IS.  NEWS 
;; INTERNET SERVICES DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS 
;; SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 
;; FITNESS, IN NO EVENT SHALL NEWS INTERNET BE LIABLE FOR ANY SPECIAL, 
;; INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER 
;; RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION
;; OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;


(require 'chtml.scm)

(define (get-keyword-arg name default set)
  (let ((value (lkey-default (cdddr *args*) name default)))
    (cadr (or (assoc value set)
	      (error (string-append name "not a member of {"
				    (unbreakupstr
				     (mapcar car set)
				     ",")
				    "}")
		     value)))))

(define (get-rest-filenames)
  (let ((j 1)
	(result nil)
	(f nil))
    (while (set! f (larg-default (cdddr *args*) j))
      (set! result (cons f result))
      (set! j (+ 1 j)))
    (nreverse result)))

(define (main)
  (let ((input-filename nil)
	(input-rest-filenames nil)
	(output-filename nil)
	(output-format nil)
	(action nil))
    (set! input-filename (or (larg-default (cdddr *args*) 0)
			     (error "no input filename specified")))
    (set! output-filename (lkey-default (cddr *args*)
					'o
					(string-append input-filename
						       "-bin")))
    (set! *chtml-c-template* (lkey-default (cddr *args*)
					   'c-template
					   *chtml-c-template*))
    (set! *undefined-object-handler*
	  (get-keyword-arg 'undefined "error"
			   '(("error" error)
			     ("silect" silent)
			     ("warn" warn))))
    (set! output-format (get-keyword-arg 'p "fasl"
					 '(("fasl" fasl)
					   ("faslc" faslc)
					   ("read" read)
					   ("none" none)
					   ("c" c))))
    (if (memq 'DIR (assq 'mode (stat output-filename)))
	(set! output-filename (string-append
			       output-filename
			       "/"
			       (car (last
				     (strbreakup input-filename
						 "/")))
			       "-bin")))
    (set! action (get-keyword-arg 'action "parse"
				  '(("parse" parse)
				    ("link" link))))
    (cond ((eq? action 'parse)
	   (if (> (verbose) 1)
	       (writes nil
		       "Input CHTML file: " input-filename "\n"
		       "Output binary   : " output-filename "\n"))
	   (general-compile-chtml input-filename
				  output-filename
				  output-format)
	   (cond ((> (verbose) 1)
		  (writes nil ";; Done, interface = \n")
		  (mapcar print *chtml-interface*))))
	  ((eq? action 'link)
	   (set! input-rest-filenames (get-rest-filenames))
	   (if (> (verbose) 1)
	       (writes nil
		       "Input main obj  : " input-filename "\n"
		       "Input ref objs  : "
		       (unbreakupstr input-rest-filenames ", ")
		       "\n"
		       "Output obj      : " output-filename "\n"))
	   (link-chtml input-filename
		       input-rest-filenames
		       output-filename
		       output-format
		       (eq? 'all
			    (get-keyword-arg 'objectify "some"
					     '(("some" some)
					       ("all" all)))))
	   (if (> (verbose) 1)
	       (writes nil ";; Done\n")))
	  ('else
	   (error "internally inconsistent action" action)))))


(define *chtml-c-template*
  (cond ((eq? 'win32 (os-classification))
	 ;; bug in fasl, don't have time to fix.
	 "chtml-cmp.c")
	('else
	 "chtml-cmp.c-bin")))

(define (chtml-load-or-parse x)
  (cond ((substring-equalcase? "-bin" x (- (length x) 4) (length x))
	 (car (load x t)))
	('else
	 (let ((old *chtml-interface*)
	       (data nil))
	   (set! *chtml-interface* nil)
	   (set! data (load-chtml x))
	   (set! *chtml-interface* old)
	   data))))

(define (get-chtml-c-template)
  (define (f x)
    (cond ((symbol-bound? 'access-problem?)
	   (not (access-problem? x "r")))
	  ('else
	   (stat x))))
  (chtml-load-or-parse (if (f *chtml-c-template*)
			   *chtml-c-template*
			 (string-append (siod-lib)
					(if (eq? 'unix (os-classification))
					    "/" "")
					*chtml-c-template*))))


(define (general-compile-chtml input-filename
			       output-filename
			       output-format)
  (let ((form (load-chtml input-filename))
	(comment (string-append "generated from " input-filename
				" on "
				(unix-ctime))))
    (save-chtml form comment output-filename output-format)))

(define (link-chtml input-filename
		    input-rest-filenames
		    output-filename
		    output-format
		    all-objects-flag)
  (save-chtml (link-form (car (load input-filename t))
			 (let ((object-table (cons-array 100)))
			   (mapcar (lambda (filename)
				     (build-object-table object-table
							 filename
							 all-objects-flag))
				   input-rest-filenames)
			   (cond ((> (verbose) 2)
				  (writes nil "*** OBJECT TABLE ***\n")
				  (let ((j 0)
					(l nil))
				    (while (< j (length object-table))
				      (set! l (aref object-table j))
				      (while l
					(print (car l))
					(set! l (cdr l)))
				      (set! j (+ 1 j))))))
			   object-table))
	      (string-append "generated from "
			     (unbreakupstr (cons input-filename
						 input-rest-filenames)
					   ", ")
			     " on "
			     (unix-ctime))
	      output-filename
	      output-format))

(define (build-object-table object-table filename all-objects-flag)
  (define (redef-warn sym)
    (writes nil ";; " filename
	    " tries to define "
	    sym " already defined by "  (cadr (href object-table sym))
	    "\n"))
  (define (walk form)
    (or (number? form) (symbol? form) (string? form)
	(begin (cond ((and all-objects-flag (symbol? (aref form 0)))
		      (if (href object-table (aref form 0))
			  (if (> (verbose) 1)
			      ;; in fact, not an error since
			      ;; idioms could share repeated object
			      ;; references.
			      (redef-warn (aref form 0)))
			(hset object-table (aref form 0)
			      (list (make-1-object form 0) filename))))
		     ((and (equal? 0 (aref form 0)) (symbol? (aref form 1)))
		      (if (href object-table (aref form 1))
			  (redef-warn (aref form 1))
			(hset object-table (aref form 1)
			      (list (make-1-object form 1) filename)))))
	       (let ((j 1))
		 (while (< j (length form))
		   (walk (aref form j))
		   (set! j (+ 1 j)))))))
  (walk (car (load filename t))))

(define (make-1-object obj skip)
  (let ((new (cons-array (- (length obj) skip)))
	(j 1))
    (aset new 0 1)
    (while (< j (length new))
      (aset new j (aref obj (+ j skip)))
      (set! j (+ 1 j)))
    new))

(define (link-form form object-table)
  (define (walk form)
    (cond ((or (number? form) (string? form))
	   form)
	  ((symbol? form)
	   (let ((new (href object-table form)))
	     (if new
		 (walk (car new) object-table)
	       form)))
	  ('else
	   (let ((new (cons-array (length form)))
		 (j 1))
	     (aset new 0 (aref form 0))
	     (while (< j (length form))
	       (aset new j (walk (aref form j)))
	       (set! j (+ 1 j)))
	     new))))
  (walk form))

(define (save-chtml form comment output-filename output-format)
  (cond ((memq output-format '(fasl faslc))
	 (fast-save output-filename
		    (list form)
		    (eq? output-format 'fasl)
		    (string-append "# CHTML -*-parser:fasl-*-\n"
				   "# " comment "\n")
		    "wb"))
	((eq? output-format 'read)
	 (let ((stream (fopen output-filename "w")))
	   (writes stream ";; CHTML -*-mode:lisp-*-\n"
		   ";; " comment "\n")
	   (almost-pretty-print form stream)
	   (fclose stream)))
	((eq? output-format 'none))
	((eq? output-format 'c)
	 (let ((table (cons-array 10))
	       (c-form (get-chtml-c-template)))
	   (hset table 'CHTML_CMP_SCM *chtml-cmp-id*)
	   (hset table 'CONST
		 (lkey-default (cdddr *args*)
			       'const
			       "const"))
	   (hset table 'COMMENT comment)
	   (hset table 'PROC_NAME
		 (convert-output-symbol-name output-filename))
	   (if (> (verbose) 1)
	       (writes nil "Optimizing data structures.\n"))
	   (output-c-structures form table)
	   (if (> (verbose) 1)
	       (writes nil "Generating C code.\n"))
	   (let ((stream (fopen output-filename "w")))
	     (write-chtml stream table c-form)
	     (fclose stream))))
	('else
	 (error "output format not supported"
		output-format))))

(define (convert-output-symbol-name output-filename)
  (let ((x (car (last (strbreakup output-filename "/"))))
	(j 0))
    (while (< j (length x))
      (cond ((or (and (>= (aref x j) (aref "A" 0))
		      (<= (aref x j) (aref "Z" 0)))
		 (and (>= (aref x j) (aref "a" 0))
		      (<= (aref x j) (aref "z" 0)))
		 (and (>= (aref x j) (aref "0" 0))
		      (<= (aref x j) (aref "9" 0)))))
	    ('else
	     (aset x j (aref "_" 0))))
      (set! j (+ 1 j)))
    x))

	      
(define (output-c-structures data table)
  (let ((heap-index 0)
	(array-index 0)
	(heap-table (cons-array 1000))
	(array-table (cons-array 1000))
	(heap-array (cons-array 1000))
	(array-array (cons-array 1000))) 
    (define (walk obj)
      (cond ((href heap-table obj))
	    ((begin (hset heap-table obj heap-index)
		    (hset heap-array heap-index obj)
		    (set! heap-index (+ 1 heap-index))
		    (or (number? obj)
			(string? obj)
			(symbol? obj))))
	    ((eq? 'tc_lisp_array (typeof obj))
	     (hset array-table obj array-index)
	     (hset array-array array-index obj)
	     (set! array-index (+ array-index (length obj)))
	     (let ((j 0))
	       (while (< j (length obj))
		 (walk (aref obj j))
		 (set! j (+ 1 j)))))
	    ('else
	     (error "object type not handled by walk" (typeof obj)))))
    (walk data)
    (hset table 'HEAP_DIMENSION heap-index)
    (hset table 'ARRAY_DIMENSION array-index)
    (let ((j 0)
	  (OBJ_ARRAY nil)
	  (OBJ_NUMBER nil)
	  (OBJ_STRING nil)
	  (OBJ_SYMBOL nil)
	  (OBJ_SIZE nil)
	  (OBJ_VALUE nil)
	  (obj nil))
      (while (< j heap-index)
	(set! obj (href heap-array j))
	(cond ((not obj)
	       (error "compiler error, no object found at internal index" j))
	      ((number? obj)
	       (set! OBJ_ARRAY (cons 0 OBJ_ARRAY))
	       (set! OBJ_NUMBER (cons 1 OBJ_NUMBER))
	       (set! OBJ_STRING (cons 0 OBJ_STRING))
	       (set! OBJ_SYMBOL (cons 0 OBJ_SYMBOL))
	       (set! OBJ_SIZE (cons 0 OBJ_SIZE))
	       (set! OBJ_VALUE (cons obj OBJ_VALUE)))
	      ((string? obj)
	       (set! OBJ_ARRAY (cons 0 OBJ_ARRAY))
	       (set! OBJ_NUMBER (cons 0 OBJ_NUMBER))
	       (set! OBJ_STRING (cons 1 OBJ_STRING))
	       (set! OBJ_SYMBOL (cons 0 OBJ_SYMBOL))
	       (set! OBJ_SIZE (cons (length obj) OBJ_SIZE))
	       (set! OBJ_VALUE (cons (print-to-string
				      obj
				      (cons-array (+ 2 (* (length obj) 2))
						  'string))
				     OBJ_VALUE)))
	      ((symbol? obj)
	       (set! obj (string-append obj))
	       (set! OBJ_ARRAY (cons 0 OBJ_ARRAY))
	       (set! OBJ_NUMBER (cons 0 OBJ_NUMBER))
	       (set! OBJ_STRING (cons 0 OBJ_STRING))
	       (set! OBJ_SYMBOL (cons 1 OBJ_SYMBOL))
	       (set! OBJ_SIZE (cons (length obj) OBJ_SIZE))
	       (set! OBJ_VALUE (cons (print-to-string
				      obj
				      (cons-array (+ 2 (* (length obj) 2))
						  'string))
				     OBJ_VALUE)))
	      ((eq? 'tc_lisp_array (typeof obj))
	       (set! OBJ_ARRAY (cons 1 OBJ_ARRAY))
	       (set! OBJ_NUMBER (cons 0 OBJ_NUMBER))
	       (set! OBJ_STRING (cons 0 OBJ_STRING))
	       (set! OBJ_SYMBOL (cons 0 OBJ_SYMBOL))
	       (set! OBJ_SIZE (cons (length obj) OBJ_SIZE))
	       (set! OBJ_VALUE (cons (href array-table obj) OBJ_VALUE)))
	      ('else
	       (error "object type not handled by heap emit"
		      (typeof obj))))
	(set! j (+ 1 j)))

      (set! OBJ_ARRAY (nreverse OBJ_ARRAY))
      (set! OBJ_NUMBER (nreverse OBJ_NUMBER))
      (set! OBJ_STRING (nreverse OBJ_STRING))
      (set! OBJ_SYMBOL (nreverse OBJ_SYMBOL))
      (set! OBJ_SIZE (nreverse OBJ_SIZE))
      (set! OBJ_VALUE (nreverse OBJ_VALUE))

      (hset table 'OBJ_ARRAY OBJ_ARRAY)
      (hset table 'OBJ_NUMBER OBJ_NUMBER)
      (hset table 'OBJ_STRING OBJ_STRING)
      (hset table 'OBJ_SYMBOL OBJ_SYMBOL)
      (hset table 'OBJ_SIZE OBJ_SIZE)
      (hset table 'OBJ_VALUE OBJ_VALUE))
    (let ((j 0)
	  (OBJ_PTR nil)
	  (obj nil))
      (while (< j array-index)
	(cond ((set! obj (href array-array j))
	       (let ((k 0))
		 (while (< k (length obj))
		   (set! OBJ_PTR (cons (href heap-table (aref obj k))
				       OBJ_PTR))
		   (set! k (+ 1 k))))
	       (set! j (+ j (length obj))))
	      ('else
	       (error "compiler error in computation of array index" j))))
      (set! OBJ_PTR (nreverse OBJ_PTR))
      (hset table 'OBJ_PTR OBJ_PTR))))

(define *indent-table* (cons-array 100))

(define (almost-pretty-print form stream)
  (almost-pretty-prin1 form stream 0)
  (fwrite "\n" stream))

(define (almost-pretty-prin1 form stream indent)
  ;; since this format is useful, currently, only for debugging
  ;; (because the siod read/print can't handle all symbol formats!
  ;; make sure it is at least half-way pretty by using indentation.
  (fwrite (or (href *indent-table* indent)
	      (hset *indent-table* indent (cons-array indent 'string)))
	  stream)
  (cond ((eq? 'tc_lisp_array (typeof form))
	 (fwrite "#(\n" stream)
	 (let ((j 0))
	   (while (< j (length form))
	     (almost-pretty-prin1 (aref form j) stream (+ indent 2))
	     (fwrite "\n" stream)
	     (set! j (+ 1 j))))
	 (fwrite (or (href *indent-table* indent)
		     (hset *indent-table* indent (cons-array indent 'string)))
		 stream)
	 (fwrite ")\n" stream))
	('else
	 (prin1 form stream))))