scsh-0.5/bcomp/scan.scm

; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.

; Added really-scan-structures, which gives you noise control.
; 	-Olin 6/95.



; Macro-expand and process top-level forms.
;
; Main entry points are:
;    scan-forms (suitable for use by eval)
;    scan-file (suitable for use by load or compile-file)
; These both return lists of nodes.
; DEFINE and DEFINE-SYNTAX forms cause side effects to the package.
; Forms are macro-expanded as necessary in order to locate all definitions.
;
; Entry points supporting the package system are:
;    scan-structures
;    scan-package
; These both return lists of (filename . node-list).
;
; Also defined here is SCAN-BODY, which scans a lambda-body for
; internal definitions.  This is an independent mechanism.


(define $note-file-package (make-fluid list)) ;Hook


; Scan a set of forms for definitions.

(define (scan-forms forms p filename . env-option)
  (let ((env (if (null? env-option)
		 (package->environment p)
		 (car env-option))))
    (if filename ((fluid $note-file-package) filename p))
    (scan-form-list forms p (bind-source-file-name filename env))))

; Read a file, scanning it for definitions.

(define (scan-file pathname p . env-option)
  (apply really-scan-file pathname p (current-output-port) env-option))

(define (really-scan-port port p . env-option)	; For scsh
  (let* ((env (if (null? env-option)
		  (package->environment p)
		  (car env-option)))
	 (reader (environment-reader env)))
    (let recur ()
      (let ((form (reader port)))
	(if (eof-object? form)
	    '()
	    (append (scan-form form p env)
		    (recur)))))))

(define (really-scan-file pathname p noise . env-option)
  (let* ((env (if (null? env-option)
 		  (package->environment p)
 		  (car env-option)))
 	 (filename (namestring pathname #f *scheme-file-type*))
  	 (truename (translate filename)))
    (call-with-input-file truename
      (lambda (port)
 	(if filename ((fluid $note-file-package) filename p))
 	(let ((env (bind-source-file-name filename env))
 	      (reader (environment-reader env)))
 	  (cond (noise (display truename noise)
 		       (force-output noise)))
 	  (let ((result (let recur ()
 			  (let ((form (read port)))
 			    (if (eof-object? form)
 				'()
 				(append (scan-form form p env)
 					(recur)))))))
 	    (cond (noise (display #\space noise)
 			 (force-output noise)))
 	    result))))))

; --------------------
; Process a list of forms.

(define (scan-form-list forms p env)
  (let loop ((forms forms))
    (if (null? forms)
	'()
	;; Force order of evaluation
	(let ((scanned-forms (scan-form (car forms) p env)))
	  (append scanned-forms
		  (loop (cdr forms)))))))

; Process a single top-level form, returning a list of nodes.

(define scan-form
  (let ((begin-node? (node-predicate 'begin syntax-type)))
    (lambda (form p env)
      (let ((node (classify form env)))
	(cond ((begin-node? node)
	       (scan-form-list (cdr (node-form node)) p env))
	      ((define-node? node)
	       (let ((form (node-form node)))
		 (package-define! p (cadr form) usual-variable-type)
		 (list node)))
	      ((define-syntax-node? node)
	       (process-define-syntax (node-form node) p env)
	       (list node))
	      (else
	       (list node)))))))


; Process a single (define-syntax ...) form

(define (process-define-syntax form p env)
  (let ((name (cadr form))
	(source (caddr form)))
    (package-define! p name
		     (process-syntax (if (null? (cdddr form))
					 source
					 `(cons ,source ',(cadddr form))) ;foo
				     env name p))))

; Package system stuff


; Utility for compile-structures and ensure-loaded.

(define (scan-structures structs process-package? package-action)
  (really-scan-structures structs (current-output-port)
			  process-package? package-action))

(define (really-scan-structures structs noise process-package? package-action)
  (let ((p-seen '())
	(s-seen '()))
    (letrec ((recur (lambda (s)
		      (if (not (memq s s-seen))
			  (begin
			    (set! s-seen (cons s s-seen))
			    (let ((p (structure-package s)))
			      (if (and (not (memq p p-seen))
				       (process-package? p))
				  (begin
				    (cond (noise
					   (display "[" noise)
					   (write (structure-name s) noise)
					   (newline noise)))
				    (set! p-seen (cons p p-seen))
				    (for-each recur (package-opens p))
				    (for-each (lambda (name+struct)
						(recur (cdr name+struct)))
					      (package-accesses p))
				    (let ((stuff (really-scan-package p noise)))
				      (really-noting-undefined-variables
				        p noise
				        (lambda () (package-action stuff p))))
				    (check-structure s)
				    (cond (noise
					   (display "]" noise)
					   (newline noise))))
				  (check-structure s))))))))
      (for-each recur structs))))


; Returns a list of pairs (file . (node1 node2 ...)).
(define (scan-package p . env-option)
  (apply really-scan-package p (current-output-port) env-option))

(define (really-scan-package p noise . env-option)
  (let* ((env (if (null? env-option)
		  (package->environment p)
		  (car env-option)))
	 (stuff '())
	 (config-file (package-file-name p))
	 (dir (if config-file
		  (file-name-directory config-file)
		  #f)))

    (for-each (lambda (clause)
		(case (car clause)
		  ((files)
		   (for-each (lambda (file)
			       (let ((file (namestring file
						       dir
						       *scheme-file-type*)))
				 (set! stuff
				       (cons (cons file
						   (really-scan-file file p
								     noise env))
					     stuff))))
			     (cdr clause)))
		  ((begin)
		   (set! stuff
			 (cons (cons config-file
				     ;; We could pass config-file here, but
				     ;; that screws up the emacs interface
				     (scan-forms (cdr clause) p #f env))
			       stuff)))
		  ((integrate)
		   (set-package-integrate?! p (or (null? (cdr clause))
						  (cadr clause))))
		  ((optimize))
		  ((define-all-operators)
		   (set! stuff
			 (cons (define-all-operators p) stuff)))
		  ((usual-transforms)
		   (initialize-usual-transforms! p (cdr clause)))
		  (else
		   (error "unrecognized define-structure keyword"
			  clause))))
	      (package-clauses p))

    (optimize (reverse stuff) p)))

(define (optimize stuff p)
  (if (package-integrate? p)
      (let ((optimizers
	     (apply append
		    (map cdr (filter (lambda (clause)
				       (eq? (car clause) 'optimize))
				     (package-clauses p))))))    
	(if (null? optimizers)
	    stuff
	    (let* ((names (if (memq 'expand optimizers)
			      optimizers
			      (cons 'expand optimizers)))
		   (passes (map get-optimizer names)))
	      (if (every (lambda (x) x) passes)
		  (reduce (lambda (pass stuff)
			    (pass stuff p))
			  stuff
			  (reverse passes))
		  (begin (signal 'note
				 "optional optimization passes not invoked"
				 optimizers)
			 stuff)))))
      stuff))


(define (check-structure s)
  (let ((undefined '()))
    (for-each-export
         (lambda (name want-type binding)
	   (if (binding? binding)
	       (let ((have-type (binding-type binding)))
		 (if (not (compatible-types? have-type want-type))
		     (warn "Type in interface doesn't match binding"
			   name
			   `(binding: ,(type->sexp have-type #t))
			   `(interface: ,(type->sexp want-type #t))
			   s)))
	       (set! undefined (cons name undefined))))
	 s)
    (if (not (null? undefined))
	(warn "Structure has undefined exports"
	      s
	      undefined))))


; The usual transforms

(define (initialize-usual-transforms! p names)
  (for-each (lambda (name)
	      (package-define! p name
			       (make-transform (usual-transform name)
					       p
					       syntax-type
					       `(usual-transform ',name)
					       name)))
	    names))

; Initialization for built-in integrations.

(define (define-all-operators p)
  (let ((procs '()))
    (table-walk (lambda (name op)
		  (let ((type (operator-type op)))
		    (if (not (or (eq? type syntax-type)
				 (memq type '(leaf internal))))
			(set! procs (cons name procs)))))
		operators-table)
    (let ((nodes (scan-forms (map make-define-primitive-node procs)
			     p #f)))
      (table-walk (lambda (name op)
		    (if (not (eq? (operator-type op) 'leaf))
			(package-define! p name op)))
		  operators-table)
      (cons #f nodes))))


(define make-define-primitive-node
  (let ((operator/define (get-operator 'define syntax-type))
	(operator/primitive-procedure
	 (get-operator 'primitive-procedure syntax-type)))
    (lambda (name)
      (make-node operator/define
		 `(define ,name
		    ,(make-node operator/primitive-procedure
				`(primitive-procedure ,name)))))))

; Optimizers

(define optimizers-table (make-table))
(define (get-optimizer name)
  (table-ref optimizers-table name))
(define (set-optimizer! name opt) (table-set! optimizers-table name opt))