#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
- !#
;;; "pas2scm": Program for compiling Pascal code to Scheme
;;; Copyright (C) 1998-1999 Aubrey Jaffer.
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(define (pas2scm.script args)
  (cond ((positive? (length args)) (apply pascal->scheme args) #t)
	(else (pas2scm.usage))))

(define (pas2scm.usage)
  (display "\
\
Usage: pas2scm SRC.pas
\
  Translates the Pascal file SRC.pas to Scheme.  Creates SRC.sch containing
  a single expression; creates SRC.sc containing mulitple expressions.

           http://swissnet.ai.mit.edu/~jaffer/PAS2SCM.html
"
	   (current-error-port))
  #f)

(require 'common-list-functions)
(require 'string-search)
(require 'string-case)
(require 'fluid-let)
(require 'line-i/o)
(require 'filename)
(require 'printf)
(require 'delay)

(define *program-name* #f)
(define *pascal:token* #f)
(define *pascal:labels* '())
(define *pascal:constants* '())
(define *pascal:types* '())
(define *pascal:undeclared-types* '())
(define *pascal:variables* '())
(define *pascal:procedures* '())
(define *pascal:functions* '())

(define *pascal-input-port* #f)
(define *pascal-eof-thunk* #f)

(define *line* 1)
(define *column* 0)
(define *procedure-name* #f)
(define *input-filename* #f)

(define (pascal:warn . args)
  (define ifname (or *input-filename* ""))
  (let ((procname (if (null? *pascal:procedures*)
		      *program-name*
		      (car *pascal:procedures*))))
    (cond ((equal? procname *procedure-name*))
	  (else (printf "%s: In procedure `%s':\\n" ifname procname)
		(set! *procedure-name* procname))))
  (printf "%s:%d: warning: " ifname *line*)
  (for-each (lambda (x) (display x) (display #\ )) args)
  (newline))

;;;; Lexer

(define tok:decimal-digits "0123456789")
(define tok:upper-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(define tok:lower-case "abcdefghijklmnopqrstuvwxyz")
(define tok:whitespaces
  (do ((i (+ -1 (min 256 char-code-limit)) (+ -1 i))
       (ws "" (if (char-whitespace? (integer->char i))
		  (string-append ws (string (integer->char i)))
		  ws)))
      ((negative? i) ws)))

;;; PC, RC, and RL stand for peek-char, read-char, and read-line.

(define (pc) (peek-char *pascal-input-port*))
(define (rc)
  (let ((chr (read-char *pascal-input-port*)))
    (cond ((eqv? #\newline chr)
	   (set! *column* 0)
	   (set! *line* (+ 1 *line*)))
	  (else (set! *column* (+ 1 *column*))))
    chr))
;;;(define (rl)
;;;  (set! *column* 0)
;;;  (set! *line* (+ 1 *line*))
;;;  (read-line *pascal-input-port*))

(define (divert-input filename)
  (define port (open-input-file (in-vicinity *input-vicinity* filename)))
  (let ((old-line *line*)
	(old-column *column*)
	(old-port *pascal-input-port*)
	(old-filename *input-filename*)
	(old-eof-thunk *pascal-eof-thunk*))
    (set! *line* 1)
    (set! *column* 0)
    (set! *procedure-name* #f)
    (set! *pascal-input-port* port)
    (set! *input-filename* filename)
    (set! *pascal-eof-thunk*
	  (lambda ()
	    (close-input-port port)
	    (set! *line* old-line)
	    (set! *column* old-column)
	    (set! *procedure-name* #f)
	    (set! *pascal-input-port* old-port)
	    (set! *input-filename* old-filename)
	    (set! *pascal-eof-thunk* old-eof-thunk)))))

;;; discard characters through the first occurrence of argument CHR.
(define (read-through! match)
  ;;(set! *pascal:token* #f)
  (do ((chr (rc) (rc)))
      ((or (if (char? match)
	       (eqv? chr match)
	       (and (eqv? (string-ref match 0) chr)
		    (eqv? (string-ref match 1) (pc))
		    (rc)))
	   (eof-object? chr)))))

(define (accumulate-chars proc chr)
  (do ((chr (pc) (pc))
       (lst (list chr) (cons chr lst)))
      ((or (eof-object? chr) (not (proc chr)))
       (list->string (reverse lst)))
    (rc)))

(define (accumulate-alpha-token chr)
  (define str (accumulate-chars
	       (lambda (chr) (or (char-alphabetic? chr)
				 (char-numeric? chr)
				 (memv chr '(#\$ #\_))))
	       chr))
  (if (equal? "" str)
      (pascal:error 'null-alpha-token)
      (string-ci->symbol str)))

(define (accumulate-numeric chr)
  (let* ((str (accumulate-chars char-numeric? chr))
	 (ans (case (pc)
		((#\#)
		 (rc)
		 (string->number
		  (accumulate-chars (lambda (chr)
				      (or (char-numeric? chr)
					  (memv chr '(#\a #\b #\c #\d #\e #\f
						      #\A #\B #\C #\D #\E #\F
						      ))))
				    (rc))
		  (string->number str)))
		((#\.)
		 (rc)
		 (case (pc)
		   ((#\.)		; OOPS! - undo `..'
		    (rc)
		    (set! tokenize (lambda ()
				     (set! tokenize pascal:tokenize)
				     'dots))
		    (string->number str))
		   (else
		    (set! str (string-append
			       str (accumulate-chars char-numeric? #\.)))
		    (case (pc)
		      ((#\e #\E)
		       (set! str (string-append str "e"))
		       (rc)
		       (set! str (string-append
				  str (accumulate-chars char-numeric? (rc))))))
		    (string->number str))))
		(else (string->number str)))))
    (cond (ans ans)
	  (else (pascal:warn 'non-number? str) str))))

(define (accumulate-funny-token chr)
  (define str (accumulate-chars (lambda (chr) (string-index ":=<>" chr)) chr))
  (case (string-length str)
    ((0) (pascal:error 'null-funny-token))
    ((1) chr)
    (else (string->symbol str))))

(define (accumulate-string)
  (do ((chr (rc) (rc))
       (lst '() (cons chr lst)))
      ((or (eof-object? chr)
	   (and (eqv? chr #\') (not (eqv? (pc) #\'))))
       (string-subst (list->string (reverse lst)) "''" "'"))))

(define (pascal:tokenize)
  (define chr (rc))
  (qase chr
    ((,@(string->list (string-append "%" tok:lower-case tok:upper-case)))
     (accumulate-alpha-token chr))
    ((,@(string->list tok:decimal-digits))
     (accumulate-numeric chr))
    ((,@(string->list ":=<>"))
     (accumulate-funny-token chr))
    ((#\newline)
;;;     (do () ((not (eqv? #\% (pc))))
;;;       (rl))
     (pascal:tokenize))
    ((,@(remove #\newline (string->list tok:whitespaces)))
     (pascal:tokenize))
    ((#\')
     (accumulate-string))
    ((#\{)
     (read-through! #\})
     (pascal:tokenize))
    ((#\.)
     (cond ((eqv? #\. (pc)) (rc) 'dots)
	   (else #\.)))
    ((#\()
     (case (pc)
       ((#\*)
	(read-through! "*)")
	(pascal:tokenize))
       (else chr)))
    (else (cond ((and (eof-object? chr) *pascal-eof-thunk*)
		 (*pascal-eof-thunk*)
		 (pascal:tokenize))
		(else chr)))))
(define tokenize pascal:tokenize)

(define (advance!)
  (set! *pascal:token* (delay (tokenize))))

;;; Now use tokens returned by (the lexer) TOKENIZE.

(define (peek-token)
  (force *pascal:token*))
(define (read-token)
  (let ((ans (and *pascal:token* (force *pascal:token*))))
    (advance!)
    ans))

(define (must-read expect)
  (define token (read-token))
  (cond ((eqv? token expect) token)
	((and (list? expect) (memv token expect)) token)
	(else (pascal:warn 'missed-token expect (list token)))))

;;;; The main parser.

(define read-identifier read-token)

(define (read-multiple read-object sep . optterm)
  (let loop ((objects (list (read-object))))
    (cond ((eqv? sep (peek-token))
	   (advance!)
	   (loop (cons (read-object) objects)))
	  ((null? optterm) (reverse objects))
	  (else (must-read (car optterm)) (reverse objects)))))

(define (read-identifiers term)
  (read-multiple read-identifier #\, term))

(define (read-simple-type token)
  (case token
    ((#\() `(set-of ,@(read-identifiers #\))))
    (else (case (peek-token)
	    ((dots)
	     (must-read 'dots)
	     (list token (read-simple-expression)))
	    (else token)))))

(define (read-field-list)
  (let* ((field-list (read-identifiers #\:))
	 (type (read-type)))
    (map (lambda (field) `(,field ,type))
	 field-list)))

(define (read-field-lists term)
  (define token (peek-token))
  (cond ((eqv? term token) (advance!) '())
	(else
	 (let loop ((field-list (read-field-list)))
	   (cond ((eqv? #\; (peek-token))
		  (advance!)
		  (cond ((eqv? term (peek-token)) (advance!) field-list)
			(else (loop (append field-list (read-field-list))))))
		 (else field-list))))))

(define (read-type)
  (define token (read-token))
  ;;(print 'read-type token (peek-token))
  (case token
    ((PACKED)
     `(packed ,(read-type)))
    ((#\^)
     (read-type))
    ((ARRAY)
     (cond ((eqv? 'OF (peek-token))
	    (must-read 'OF)
	    `(array-of ,(read-type)))
	   (else
	    (must-read #\[)
	    (let ((bounds (read-simple-type (read-simple-expression))))
	      (must-read #\])
	      (must-read 'OF)
	      `(array-of ,(read-type) ,@bounds)
	      ))))
    ((FILE)
     (must-read 'OF)
     `(file-of ,(read-type)))
    ((SET)
     (must-read 'OF)
     (read-simple-type (read-token)))
    ((RECORD)
     `(record ,@(read-field-lists 'end)))
    (else (read-simple-type token))))

(define (pascal:type var)
  (cond ((list? var)
	 (case (car var)
	   ((array-ref) (pascal:type (cadr var)))
	   ((list-ref)
	    (let ((type (pascal:type (cadr var)))
		  (field-name (symbol->string (caddr var))))
	      (cond ((char=? #\@ (string-ref field-name 0))
		     (set! field-name
			   (string->symbol
			    (substring field-name 1
				       (string-length field-name)))))
		    (else
		     (pascal:warn 'unusual 'field-name field-name)))
	      (let* ((def (assq type *pascal:types*))
		     (pair (and def (assq field-name (cdadr def)))))
		;;(print 'field field-name 'def def)
		(cond (pair (cadr pair))
		      (else (pascal:warn 'type-of var '?) #f)))))
	   (else #f)))
	(else
	 (let ((pair (assq var *pascal:variables*)))
	   ;;(and (not pair) (print 'var var) (pretty-print *pascal:variables*))
	   (and pair (cadr pair))))))

(define (pascal:record-type-fields type)
  (cond ((symbol? type)
	 (let ((def (assq type *pascal:types*)))
	   (cond (def (pascal:record-type-fields (cadr def)))
		 (else #f))))
	((not (pair? type)) #f)
	(else (case (car type)
		((record) (map car (cdr type)))
		((array-of) (pascal:record-type-fields (cadr type)))
		(else (pascal:warn 'pascal:record-type-fields
				   'not 'found 'for type)
		      #f)))))

(define (read-variable1 token)
  (case (peek-token)
    ((#\[) (advance!)
     (read-variable1 `(array-ref ,token ,@(read-expressions #\]))))
    ((#\^) (advance!) (read-variable1 token))
    ((#\.) (advance!)
     (read-variable1
      (let* ((type (pascal:type token))
	     (fields (and type (pascal:record-type-fields type)))
	     (tkn (read-token)))
	(if fields
	    (if (not (memq tkn fields))
		(pascal:warn tkn 'not 'found 'in fields))
	    (pascal:note-undeclared-type-field type tkn))
	`(list-ref ,token ,(symbol-append "@" tkn)))))
    (else token)))

(define (read-variable)
  (read-variable1 (read-token)))

(define (read-factor)
  (define token (peek-token))
  (case token
    ((#\() (advance!) (let ((ans (read-expression))) (must-read #\)) ans))
    ((NOT) (advance!) `(not ,(read-factor)))
    ((#\[) (advance!)
     (cond ((eqv? #\] (peek-token)) (advance!) '())
	   (else (let loop ((idxs '()))
		   (let* ((expr (read-expression))
			  (token (read-token)))
		     (case token
		       ((DOTS)
			(set! expr (list token expr (read-expression)))
			(set! token (read-token)))
		       ((OF)
			(set! expr (read-expression))
			(set! token (read-token))))
		     (case token
		       ((#\,) (loop (cons expr idxs)))
		       ((#\]) (cons expr idxs))
		       (else (pascal:warn 'read-factor 'funny 'token token
					  expr idxs)
			     (list expr idxs))))))))
    (else (advance!)
	  (set! token (read-variable1 token))
	  ;;(print 'token token)
	  (case (peek-token)
	    ((#\() (advance!)
	     (if (memq token *pascal:functions*)
		 (set! token (symbol-append token '?)))
	     (case (peek-token)
	       ((#\)) (advance!) (list token))
	       (else (cons token (read-expressions #\))))))
	    (else token)))))

(define (read-term)
  (let loop ((cur (read-factor)))
    (case (peek-token)
      ((#\*) (advance!) (loop `(* ,cur ,(read-factor))))
      ((#\/) (advance!) (loop `(/ ,cur ,(read-factor))))
      ((div) (advance!) (loop `(div ,cur ,(read-factor))))
      ((mod) (advance!) (loop `(mod ,cur ,(read-factor))))
      ((and) (advance!) (loop `(and ,cur ,(read-factor))))
      ((#\&) (advance!) (loop `(logand ,cur ,(read-factor))))
      (else (if (and (string? cur) (eqv? 1 (string-length cur)))
		(string-ref cur 0)
		cur)))))

(define (read-simple-expression)
  (let ((isgn (case (peek-token)
		((#\+) (advance!) '+)
		((#\-) (advance!) '-)
		(else #f))))
    (let loop ((curexp (if isgn (list isgn (read-term)) (read-term))))
      (case (peek-token)
	((#\+) (advance!) (loop `(+ ,curexp ,(read-term))))
	((#\-) (advance!) (loop `(- ,curexp ,(read-term))))
	((or) (advance!) (loop `(or ,curexp ,(read-term))))
	(else curexp)))))

(define (read-expression)
  (let* ((simp (read-simple-expression))
	 (token (peek-token)))
    (case token
      ((#\= #\< #\> <> <= >=)
       (advance!)
       (if (char? token) (set! token (string->symbol (string token))))
       `(,token ,simp ,(read-simple-expression)))
      ((IN)
       (advance!)
       (if (char? token) (set! token (string->symbol (string token))))
       `(memv ,simp ',(read-simple-expression)))
      (else simp))))

(define (read-expressions term)
  (read-multiple read-expression #\, term))

(define (pascal:inline-type-scalar? type)
  (case (car type)
    ((SET-OF) #t)
    (else #f)))
(define (pascal:scalar? type)
  (case type
    ((REAL INTEGER LINTEGER INTEGER32 INTEGER16 BOOLEAN CHAR WORD DOUBLE) #t)
    ((STRING) #f)
    (else (cond ((pair? type) (pascal:inline-type-scalar? type))
		(else (let ((def (assq type *pascal:types*)))
			(if def
			    (if (pair? (cadr def))
				(pascal:inline-type-scalar? (cadr def))
				#t)
			    #t)))))))

(define (check-VAR defs)
  (for-each
   (lambda (def) (if (pascal:scalar? (cadr def))
		     (pascal:warn "VAR scalars not supported" def)))
   defs)
  defs)

(define (read-parameters)
  (let loop ((parameters '()) (storage-class #f))
    (let ((token (peek-token)))
      (case token
	((VAR) (advance!) (check-VAR (loop parameters 'VAR)))
	((IN) (advance!) (loop parameters 'IN))
	((FUNCTION) (advance!) (loop parameters storage-class))
	((PROCEDURE) (advance!) (read-identifiers storage-class))
	(else
	 (let* ((ids (read-identifiers #\:))
		(type (read-type)))
	   (map (lambda (id) (list id type storage-class)) ids)))))))

(define (read-parameter-list term)
  (define parameters
    (case (peek-token)
      ((#\()
       (advance!)
       (apply append (read-multiple read-parameters #\; #\))))
      (else '())))
  (must-read term)
  parameters)

(define (copy-parameters parameters)
  (apply append
	 (map (lambda (param)
		(if (and (not (caddr param))
			 (not (pascal:scalar? (cadr param))))
		    `((define ,(car param) (make-pascal-copy ,(car param))))
		    '()))
	      parameters)))

(define (read-clause)
  (cons (map (lambda (expr)
	       (if (or (char? expr) (number? expr))
		   expr
		   (list 'unquote expr)))
	     (read-expressions #\:))
	(unbeginify (read-statement))))

(define (read-clauses)
  (let loop ((clauses (list (read-clause))))
    (cond ((eqv? #\; (peek-token))
	   (advance!)
	   (cond ((eqv? 'end (peek-token))
		  (advance!)
		  (reverse clauses))
		 (else (loop (cons (read-clause) clauses)))))
	  (else (must-read 'end)
		(reverse clauses)))))

(define (beginify statements)
  (case (length statements)
    ((1) (car statements))
    (else `(begin ,@statements))))

(define (unbeginify expr)
  (if (and (pair? expr) (list? expr) (eq? 'begin (car expr)))
      (cdr expr)
      (list expr)))

(define (labelfy obj)
  (string->symbol
   (string-append ":" ((if (number? obj) number->string symbol->string) obj))))

(define (make-set! place value)
  (cond ((not (list? place)) `(set! ,place ,value))
	((and (case (car place)
		((list-ref)
		 `(list-set! ,(cadr place) ,(caddr place) ,value))
		(else #f))))
	((case (car place)
	   ((array-ref) `(array-set! ,(cadr place) ,value ,@(cddr place)))
	   (else #f)))
	(else `(set! ,place ,value))))

(define (construct-with vars statement)
  (if (null? vars)
      (unbeginify statement)
      (let ((fields (pascal:record-type-fields (pascal:type (car vars)))))
	`(@apply
	  (lambda ,fields
	    ,@(construct-with (cdr vars) statement))
	  ,(car vars)))))

(define (read-statement)
  (case (peek-token)
    ((#\; ELSE) ''(noop))		; null statement
    ((BEGIN) (read-block))
    ((IF) (advance!) (let ((test (read-expression)))
		       (must-read 'then)
		       (let* ((csq (read-statement)))
			 (case (peek-token)
			   ((else)
			    (advance!)
			    `(if ,test ,csq ,(read-statement)))
			   (else  `(if ,test ,csq))))))
    ((CASE) (advance!) (let ((test (read-expression)))
			 (must-read 'OF)
			 (let ((clauses (read-clauses)))
			   `(qase ,test ,@clauses))))
    ((WHILE) (advance!) (let ((test (read-expression)))
			  (must-read 'DO)
			  `(do () ((not ,test))
			     ,@(unbeginify (read-statement)))))
    ((REPEAT) (advance!) (let ((body (read-statements 'until)))
			   `(do ((repeat? #f ,@(unbeginify (read-expression))))
				(repeat?)
			      ,@body)))
    ((FOR) (advance!) (let ((var (read-identifier)))
			(must-read ':=)
			(let* ((from (read-expression))
			       (dir (read-token))
			       (to (read-expression)))
			  (must-read 'DO)
			  `(do ((,var ,from (+ ,(case dir ((to) 1)
						     ((downto) -1))
					      ,var)))
			       ((,(case dir ((to) '>) ((downto) '<))
				 ,var ,to))
			     ,@(unbeginify (read-statement))))))
    ((WITH) (advance!)
     (let ((vars (read-multiple read-variable #\, 'DO)))
       (construct-with vars (read-statement))))
    ((goto) (advance!) (list (labelfy (read-token))))
    (else				; two token lookahead
     (let* ((token (read-variable1 (read-token)))
	    (tok2 (peek-token)))
       (case tok2			; label code reorganized later
	 ((#\:) (advance!) (beginify (list (read-statement) token)))
	 ((:=) (advance!) (make-set! token (read-expression)))
	 ((#\() (advance!) (cons (cond ((memq token *pascal:procedures*)
					(symbol-append token '!))
				       ((memq token *pascal:functions*)
					(pascal:warn 'calling 'function
						     token 'as 'procedure)
					(symbol-append token '?))
				       (else token))
				 (case (peek-token)
				   ((#\)) (advance!) '())
				   (else (read-expressions #\))))))
	 (else (list token)))))))

(define (read-statements term)
  (let loop ((statements (unbeginify (read-statement))))
    (cond ((eqv? #\; (peek-token))
	   (advance!)
	   (cond ((eqv? term (peek-token))
		  (advance!)
		  (reverse statements))
		 (else (loop (append (unbeginify (read-statement))
				     statements)))))
	  (else (must-read term)
		(reverse statements)))))

(define (read-const-def)
  (let ((id (read-identifier)))
    (must-read #\=)
    (let ((const (read-expression)))
      (must-read #\;)
      (list id const))))

(define (symbol-append . args)
  (string->symbol (apply string-append
			 (map
			  (lambda (x)
			    (cond ((string? x) x)
				  ((number? x) (number->string x))
				  ((symbol? x) (symbol->string x))
				  ((not x) "")
				  (else (slib:error
					 'wrong-type-to 'symbol-append x))))
			  args))))

(define (pascal:note-undeclared-type type)
  ;;(pascal:warn 'undeclared-type type)
  (let ((pair (assq type *pascal:undeclared-types*)))
    (if (not pair)
	(set! *pascal:undeclared-types*
	      (cons (list type) *pascal:undeclared-types*))))
  '???)
(define (pascal:note-undeclared-type-field type field)
  (if (not type) (pascal:warn 'undeclared-type-field type field))
  (let ((pair (assq type *pascal:undeclared-types*)))
    (cond ((not pair)
	   (set! pair (list type))
	   (set! *pascal:undeclared-types*
		 (cons pair *pascal:undeclared-types*))))
    (set-cdr! pair (adjoin field (cdr pair)))))

(define *pascal:type-counter* 100)
(define (genint)
  (set! *pascal:type-counter* (+ 1 *pascal:type-counter*))
  *pascal:type-counter*)

(define (gen-type-ids set-spec)
  (set! set-spec (cadr set-spec))
  (map list
       (cdr set-spec)
       (do ((j (+ -2 (length set-spec)) (+ -1 j))
	    (lst '() (cons (genint) lst)))
	   ((negative? j) (reverse lst)))))

(define (gen-type-maker spec)
  `(,(symbol-append 'make- (car spec))
    (lambda ()
      ,(gen-obj (cadr spec) #f))))

(define (gen-obj spec init)
  ;;(if init (print 'gen-obj spec ':= init))
  (cond ((symbol? spec)
	 (case spec
	   ((REAL DOUBLE) (or init 0.0))
	   ((INTEGER LINTEGER INTEGER32 INTEGER16 WORD) (or init 0))
	   ((BOOLEAN) #f)
	   ((STRING) (or init ""))
	   ((CHAR) (or init #\?))
	   (else
	    (let ((def (assq spec *pascal:types*)))
	      (cond ((not def)
		     (pascal:note-undeclared-type spec)
		     `(,(symbol-append 'make- spec)
		       ,@(cond ((list? init) init)
			       ((not init) '())
			       (else (list init)))))
		    ((not init)
		     (cond ((not (and (pair? def) (pair? (cdr def))))
			    (slib:error def))
			   ((pair? (cadr def))
			    (case (caadr def)
			      ((set-of) #f)
			      ;;((array-of) (gen-type-maker def))
			      (else `(,(symbol-append 'make- spec)))))
			   (else `(,(symbol-append 'make- spec)))))
		    ((list? init)
		     (if def (gen-obj (cadr def) init)
			 `(,(symbol-append 'make- spec) ,@init)))
		    (else `(,(symbol-append 'make- spec) ,init)))))))
	((not (pair? spec))
	 (pascal:warn 'strange 'type-spec spec))
	(else
	 (case (car spec)
	   ((RECORD)
	    `(list ,@(cond ((not (list? init))
			    (map (lambda (spec)
				   (gen-obj (cadr spec) init))
				 (cdr spec)))
			   ((= (length (cdr spec)) (length init))
			    (map (lambda (spec init)
				   (gen-obj (cadr spec) init))
				 (cdr spec)
				 init))
			   (else
			    (pascal:warn 'initializer-length
					 (list (length init))
					 'does-not-match
					 'spec
					 (list (length (cdr spec))))
			    (print 'spec '= spec)
			    (print 'init '= init)
			    (map (lambda (spec)
				   (gen-obj (cadr spec) init))
				 (cdr spec))))))
	   ((ARRAY-OF)
	    `(make-pascal-array
	      ,(gen-obj (cadr spec) (and init (car init)))
	      (list ,@(cddr spec))))
	   ((SET-OF)
	    `',(cond ((memq init spec) init)
		     ((not init) (cadr spec))
		     ((pascal:warn init 'not 'in spec)
		      (cadr spec))))
	   (else (pascal:warn 'unknown 'type-spec spec))))))

(define (gen-idxs record-spec)
  (let ((rec-spec (cdadr record-spec)))
    (cons (gen-type-maker record-spec)
	  (map list
	       (map (lambda (def) (symbol-append '@ (car def)))
		    rec-spec)
	       (do ((j (+ -1 (length rec-spec)) (+ -1 j))
		    (lst '() (cons j lst)))
		   ((negative? j) lst))))))

(define (read-type-defs)
  (let ((id (read-identifier)))
    (must-read #\=)
    (let ((type (read-type)))
      (must-read #\;)
      `((,id ,type)))))

(define (read-var-bindings)
  (let* ((ids (read-identifiers #\:))
	 (type (read-type))
	 (tok (read-token)))
    (case tok
      ((#\;) (map (lambda (id) (list id type #f)) ids))
      ((:=) (let ((value (read-expression)))
	      (must-read #\;)
	      (map (lambda (id) (list id type value)) ids))))))

(define (read-defs proc)
  (do ((defs (list (proc)) (cons (proc) defs)))
      ((case (peek-token)
	 ((LABEL CONST TYPE VAR PROCEDURE FUNCTION BEGIN END
		 %INCLUDE %LIST %NOLIST %VAR %EJECT) #t)
	 (else #f))
       (reverse defs))))

(define (glue . args)
  (beginify (apply append (map unbeginify args))))

(define (bind-using construct bindings block)
  (if (null? bindings)
      block
      (case construct
	((define) (glue (beginify (map (lambda (binding) (cons 'define binding))
				       bindings))
			block))
	(else				;(let let* letrec)
	 `(,construct ,bindings ,@(unbeginify block))))))

(define (process-include-file? filename)
  (cond ((file-exists? filename)
	 (divert-input filename)
	 #t)
	(else #f)))

(define (read-block)
  (define token (read-token))
  (case token
    ((%LIST %NOLIST %VAR %EJECT)
     (read-through! #\;)
     (read-block))
    ((%INCLUDE)
     (let ((filename (read-token)))
       (read-through! #\;)
       (cond ((process-include-file? filename))
	     ((and (string-reverse-index filename #\/)
		   (process-include-file?
		    (substring filename
			       (+ 1 (string-reverse-index filename #\/))
			       (string-length filename)))))
	     (else (pascal:warn
		    (string-append "Skipping %INCLUDE '" filename "'"))))
       (read-block)))
    ((LABEL)
     (fluid-let ((*pascal:labels*
		  (append (read-identifiers #\;) *pascal:labels*)))
       (read-block)))
    ((CONST) (let ((defs (read-defs read-const-def)))
	       (bind-using
		'let* defs
		(fluid-let ((*pascal:constants*
			     (append (map cdr defs) *pascal:constants*)))
		  (read-block)))))
    ((TYPE)
     (let* ((defs (apply append (read-defs read-type-defs))))
       (fluid-let ((*pascal:types* (append defs *pascal:types*)))
	 (bind-using
	  'let (apply append
		      (map (lambda (def)
			     (cond ((not (and (pair? def) (pair? (cdr def))))
				    (slib:error def))
				   ((pair? (cadr def))
				    (case (caadr def)
				      ((RECORD) (gen-idxs def))
				      ((SET-OF) (gen-type-ids def))
				      ((ARRAY-OF) (list (gen-type-maker def)))
				      (else (list def))))
				   (else (list def))))
			   defs))
	  (read-block)))))
    ((VAR)   (let ((bindings (apply append (read-defs read-var-bindings))))
	       (fluid-let ((*pascal:variables*
			    (append bindings *pascal:variables*)))
		 (bind-using
		  'let (map (lambda (binding) ;(print 'binding binding)
			      (list (car binding)
				    (gen-obj (cadr binding) (caddr binding))))
			    bindings)
		  (read-block)))))
    ((PROCEDURE)
     (let* ((id (read-token))
	    (parameters (read-parameter-list #\;)))
       ;;(print 'parameters parameters)
       (fluid-let ((*pascal:procedures* (cons id *pascal:procedures*))
		   (*pascal:variables* (append parameters *pascal:variables*)))
	 (let ((ans `(define (,(symbol-append id '!) ,@(map car parameters))
		       ,@(copy-parameters parameters)
		       ,@(unbeginify (read-block)))))
	   (must-read #\;)
	   (glue ans (read-block))))))
    ((FUNCTION)
     (let* ((id (read-token))
	    (parameters (read-parameter-list #\:)))
       (read-identifier)
       (must-read #\;)
       (fluid-let ((*pascal:functions* (cons id *pascal:functions*))
		   (*pascal:variables* (append parameters *pascal:variables*)))
	 (let ((ans `(define (,(symbol-append id '?) ,@(map car parameters))
		       (define ,id #f)
		       ,@(copy-parameters parameters)
		       ,@(unbeginify (read-block))
		       ,id)))
	   (must-read #\;)
	   (glue ans (read-block))))))
    ((BEGIN) (statements->letrec (case (peek-token)
				   ((end) (advance!) '())
				   (else (read-statements 'end)))))
    (else (pascal:warn "unknown block element" token)
	  (if (eof-object? token) 'end-of-file token))))

(define (statements->letrec statements)
  (define bnds '())
  (case (length statements)
    ((1) (car statements))
    (else
     (do ((stms statements (cdr stms)))
	 ((null? stms)
	  (if (null? bnds)
	      `(begin ,@statements)
	      `(letrec ,(reverse bnds) ,@statements)))
       (if (not (list? (car stms)))
	   (let ((label (labelfy (car stms)))
		 (new-stms (cons 'error (cdr stms))))
	     (set! bnds (cons `(,label (lambda () ,@(cdr stms))) bnds))
	     (set-car! stms (list label))
	     (set-cdr! stms '())
	     (set! stms new-stms)))))))

(define (read-program)
  (advance!)
  (must-read '(program module unit))
  (set! *program-name* (read-identifier))
  (read-through! #\;)
  (let ((ans (read-block)))
    (must-read #\.)
    ans))

;;;; Manage files and filenames.

(define *input-vicinity* (user-vicinity))
(define *output-vicinity* (user-vicinity))

(define (check-program-end iport)
  (do ((chr (read-char iport) (read-char iport)))
      ((or (eof-object? chr) (not (char-whitespace? chr)))
       (if (not (eof-object? chr))
	   (pascal:warn 'process-pascal-file
			'ended-prematurely
			(string-append (string chr) (read-line iport)))))))
(define (process-pascal-file filename)
  (fluid-let ((*input-filename* filename))
    (fprintf (current-error-port) "Translating \"%s\"" filename)
    (newline (current-error-port))
    (call-with-input-file
	(in-vicinity *input-vicinity* filename)
      (lambda (iport)
	(fluid-let ((*pascal-input-port* iport)
		    (*line* 1)
		    (*column* 0))
	  (let ((ans (read-program)))
	    (check-program-end iport)
	    ans))))))
(define pascal:pas? (filename:match-ci?? "*.pas"))
(define (pascal->scheme . optargs)
  (cond ((null? optargs)
	 (set! *pascal-input-port* (current-input-port))
	 (let ((program (read-program)))
	   (print-header "<stdin>")
	   (denest-print program)))
	(else
	 (cond ((not (null? (cdr optargs)))
		(set! *input-vicinity* (car optargs))
		(set! optargs (cdr optargs))))
	 (cond ((not (null? (cdr optargs)))
		(set! *output-vicinity* (cadr optargs))))
	 (let* ((filename (if (pascal:pas? (car optargs))
			      (car optargs)
			      (replace-suffix (car optargs) "" ".pas")))
		(program (process-pascal-file filename)))
	   (report-undeclareds "")
	   (call-with-output-file
	       (in-vicinity *output-vicinity*
			    (replace-suffix filename "pas" "sch"))
	     (lambda (oport)
	       (print-header filename oport)
	       (newline oport)
	       (pretty-print program oport)))
	   (call-with-output-file
	       (in-vicinity *output-vicinity*
			    (replace-suffix filename "pas" "sc"))
	     (lambda (oport)
	       (print-header filename oport)
	       (denest-print program oport)
	       (newline)))
	   (set! *pascal:undeclared-types* '())))))
(define (print-header filename . oport)
  (set! oport (if (null? oport) (current-output-port) (car oport)))
  (fprintf oport ";; \"%s\" %20s\\n" *program-name* "-*-scheme-*-")
  (newline oport)
  (fprintf oport ";; Translated from \"%s\" by SLIB pascal->scheme.\\n"
	   filename)
  (fprintf oport ";; http://swissnet.ai.mit.edu/~jaffer/SLIB.html\\n")
  (newline oport)
  (report-undeclareds ";;" oport)
  (newline oport)
  (for-each (lambda (feature) (fprintf oport "(require '%s)\\n" feature))
	    '(tree array array-for-each pascal-runtime))
  (newline oport))
(define (report-undeclareds prefix . oport)
  (set! oport (if (null? oport) (current-output-port) (car oport)))
  (cond ((not (null? *pascal:undeclared-types*))
	 (fprintf oport "%s%25s %10s\\n" prefix "Undeclared TYPE" "fields")
	 (fprintf oport "%s%25s %10s\\n" prefix "===============" "======")
	 (for-each (lambda (typ-flds)
		     (fprintf oport "%s%25s" prefix (car typ-flds))
		     (for-each (lambda (fld) (fprintf oport " %10s" fld))
			       (cdr typ-flds))
		     (newline oport))
		   *pascal:undeclared-types*))))
(define (denest-print program oport)
  (newline oport)
  (if (pair? program)
      (case (car program)
	((BEGIN) (for-each (lambda (expr) (denest-print expr oport))
			   (cdr program)))
	((LET LET* LETREC)
	 (cond ((symbol? (cadr program))
		(pretty-print program oport))
	       (else
		(for-each
		 (lambda (bind) (denest-print (cons 'define bind) oport))
		 (cadr program))
		(for-each
		 (lambda (expr) (denest-print expr oport))
		 (cddr program)))))
	(else (pretty-print program oport)))
      (pretty-print program oport)))

;;; Local Variables:
;;; mode:scheme
;;; End:
(if *script* (exit (pas2scm.script (list-tail *argv* *optind*))))