DataMuseum.dk

top - download

    Length: 7526 (0x1d66)
    Types: TextFile
    Names: »xusermd.scm.29«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/xusermd.scm.29« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, 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. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; User Interface to Cross Syntaxer

(declare (usual-integrations))

(define sf)
(define scold)

(let ()
\f


(define wrapping-hook identity-procedure)

;;; Use this only to syntax the cold-load root.

(set! scold
      (lambda arguments
	(fluid-let ((wrapping-hook wrap-with-control-point))
	  (apply sf arguments))))

(define control-point-tail
  '(1 16 #!null #!null #!null #!null #!null #!null #!null
      #!null #!null #!null #!null #!null #!null #!null #!null #!null
      #!null #!null #!null #!null #!null #!null #!null #!null #!null))

(define (wrap-with-control-point scode)
  (system-list-to-vector type-code-control-point
			 `(,return-address-restart-execution
			   ,scode
			   ,system-global-environment
			   ,return-address-non-existent-continuation
			   ,@control-point-tail)))

(define type-code-control-point
  (microcode-type 'CONTROL-POINT))

(define return-address-restart-execution
  (make-return-address (microcode-return 'RESTART-EXECUTION)))

(define return-address-non-existent-continuation
  (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))

(set! sf
      (lambda (filename . optional)
	(if (list? filename)
	    (mapc (lambda (filename)
		    (eval-sf-expression filename
					(first optional)
					(second optional)))
		  filename)
	    (eval-sf-expression filename
				(first optional)
				(second optional)))
	*the-non-printing-object*))

(define (eval-sf-expression input-path bin-path spec-path)
  (let ((bin-name (merge-pathnames (if (null? bin-path) "" bin-path)
				   (merge-pathnames ".bin" input-path))))
    (let ((spec-name (merge-pathnames (if (null? spec-path) "" spec-path)
				      (merge-pathnames ".spc" bin-name))))
      (print `(SYNTAX-FILE ,input-path ,bin-name ,spec-name))
      (syntax-file input-path bin-name spec-name))))
\f


(define spec-channel)

(define (syntax-file input-fname output-fname spec-fname)
  (with-open-output-stream spec-fname
    (lambda (spec-file)
      (fluid-let ((spec-channel spec-file))
	(prin1 (list input-fname output-fname spec-fname (date) (time))
	       spec-channel)
	(apply (lambda (references side-effects expression)
		 (with-output-to-stream spec-channel
		   (lambda ()
		     (define (print-spec string names)
		       (newline) (newline) (princ "(") (prin1 string)
		       (print-loop (sort names symbol-less?))
		       (princ ")"))

		     (define (print-loop names)
		       (if (not (null? names))
			   (sequence (tyo #\CR)
				     (prin1 (car names))
				     (print-loop (cdr names)))))

		     (print-spec "Free references" references)
		     (print-spec "Free side-effects" side-effects)
		     (scan-defines expression
		       (lambda (auxiliary body)
			 (print-spec "Defined names" auxiliary)))
		     (close-output-stream spec-channel)))
		 (fasdump (wrapping-hook expression) output-fname))
	       (timed 'INTEGRATE integrate-expression
		      (timed 'SYNTAX syntax*
			     (timed 'READ read-file
				    input-fname))
		      list))))))

(define (timed string operator . operands)
  (measure-interval
   #!TRUE
   (lambda (start-time)
     (let ((value (apply operator operands)))
       (lambda (finish-time)
	 (with-output-to-stream spec-channel
	   (lambda ()
	     (newline)
	     (prin1 `(,string (RUNTIME ,(- finish-time start-time))))))
	 value)))))

(define (symbol-less? x y)
  (string-less? (symbol-print-name x)
		(symbol-print-name y)))
\f


;;;; Pathname Stuff

(define (make-pathname device directory name type version)
  (string-join device ":"
	       (string-join directory "/"
			    (string-join name "."
					 (string-join type "."
						      version)))))

(define (pathname-components pathname receiver)
  (string-split-right pathname (string-index pathname #/:)
    (lambda (device rest)
      (string-split-right rest (last-string-index rest #//)
	(lambda (directory rest)
	  (string-split-left rest (string-index rest #/.)
	    (lambda (name rest)
	      (string-split-left rest (string-index rest #/.)
		(lambda (type version)
		  (receiver device directory name type version))))))))))

(define (merge-pathnames pathname pathname*)
  (pathname-components pathname
    (lambda (device directory name type version)
      (pathname-components pathname*
	(lambda (device* directory* name* type* version*)
	  (make-pathname (merge-pathname-component device device*)
			 (merge-pathname-component directory directory*)
			 (merge-pathname-component name name*)
			 (merge-pathname-component type type*)
			 (merge-pathname-component version version*)))))))

(define (merge-pathname-component component component*)
  (if (null-string? component)
      component*
      component))
\f


;;;; String Stuff

(define (string-join string1 infix string2)
  (cond ((null-string? string1) string2)
	((null-string? string2) string1)
	(else (string-append string1 infix string2))))

(define (string-split-right string index receiver)
  (if index
      (receiver (substring string 0 index)
		(let ((size (string-size string)))
		  (if (= index size)
		      ""
		      (substring string (1+ index) size))))
      (receiver ""
		string)))

(define (string-split-left string index receiver)
  (if index
      (receiver (substring string 0 index)
		(let ((size (string-size string)))
		  (if (= index size)
		      ""
		      (substring string (1+ index) size))))
      (receiver string
		"")))

(define (last-string-index string character)
  (let ((index (string-index string character)))
    (conjunction index
		 (let ((size (string-size string)))
		   (if (= index size)
		       index
		       (let ((next-index 
			      (last-string-index (substring string
							    (1+ index)
							    size)
						 character)))
			 (if next-index
			     (+ next-index index 1)
			     index)))))))

(define (string-index string character)
  (string-position string #o177 character))

(define (null-string? string)
  (string-equal? string ""))

)
\f


;;; Local Modes:
;;; Scheme PATHNAME-COMPONENTS Indent: 1
;;; Scheme STRING-SPLIT Indent: 2
;;; End: