DataMuseum.dk

top - download

    Length: 10664 (0x29a8)
    Types: TextFile
    Names: »stackp.scm.16«

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

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

;;;; Stack Parser

(declare (usual-integrations))
\f


(define continuation?)
(define catch)
(define within-continuation)
(define null-continuation?)
(define continuation-expression)
(define continuation-environment)
(define continuation-reductions)
(define continuation-dynamic-state)
(define continuation-return-code)
(define continuation-next-continuation)
(define continuation-annotation)
(define continuation-interrupt-enables)
(define set-continuation-interrupt-enables!)
(define continuation-undefined-environment?)
(define continuation-undefined-expression?)
(define continuation-evaluated-object?)
(define continuation-evaluated-object-value)


(let ((type-code-control-point (microcode-type 'CONTROL-POINT))
      (return-address-restore-history
       (make-return-address (microcode-return 'RESTORE-HISTORY)))
      (return-address-restore-dont-copy-history
       (make-return-address (microcode-return 'RESTORE-DONT-COPY-HISTORY)))
      (call-with-current-continuation
       (make-primitive-procedure 'CALL-WITH-CURRENT-CONTINUATION))
      (within-control-point (make-primitive-procedure 'WITHIN-CONTROL-POINT))

      (evaluated-object-tag '(EVALUATED))
      (undefined-expression '(UNDEFINED-EXPRESSION))
      (undefined-environment '(UNDEFINED-ENVIRONMENT))

      (undefined-reductions '()))

(declare (compilable-primitive-functions call-with-current-continuation
					 within-control-point))

(set! continuation?
      (named-lambda (continuation? object)
	(conjunction (compound-procedure? object)
		     (let ((environment (procedure-environment object)))
		       (conjunction (environment? environment)
				    (eq? (environment-procedure environment)
					 make-continuation))))))
\f


;;;; User Interface

;;***
(define (control-point-offset control-point)
  (system-vector-ref control-point 1))

(set! catch
      (named-lambda (catch receiver)
	(call-with-current-continuation
	 (lambda (control-point)
	   (let ((dynamic-state (current-dynamic-state)))
	     (receiver
	      (make-continuation
	       (delay control-point)
	       dynamic-state
	       (delay (parse-stack (control-point->stack control-point)
				   (access the-empty-history history-package)
				   dynamic-state
				   (control-point-offset
				    control-point))))))))))

(set! within-continuation
      (named-lambda (within-continuation continuation thunk)
	(if (continuation? continuation)
	    (within-control-point (control-point continuation) thunk)
	    (error "Not a continuation" within-continuation continuation))))

(set! null-continuation?
      (named-lambda (null-continuation? continuation)
	(null? (parser-output continuation))))

(set! continuation-expression
      (named-lambda (continuation-expression continuation)
	(parsed-expression (parser-output continuation))))

(set! continuation-environment
      (named-lambda (continuation-environment continuation)
	(parsed-environment (parser-output continuation))))

(set! continuation-reductions
      (named-lambda (continuation-reductions continuation)
	(parsed-reductions (parser-output continuation))))
\f


(set! continuation-dynamic-state
      (named-lambda (continuation-dynamic-state continuation)
	(parsed-dynamic-state (parser-output continuation))))

(set! continuation-next-continuation
      (named-lambda (continuation-next-continuation continuation)
	(let ((parser-output (parser-output continuation)))
	  (make-continuation
	   (delay (stack->control-point
		   (parsed-stack parser-output)
		   ((access history-untransform history-package)
		    (parsed-history parser-output))
		   (parsed-offset-to-restore-history
		    parser-output)))
	   (parsed-dynamic-state parser-output)
	   (delay (parse-stack (parsed-stack parser-output)
			       (parsed-history parser-output)
			       (parsed-dynamic-state parser-output)
			       (parsed-offset-to-restore-history
				parser-output)))))))
\f


(set! continuation-return-code
      (named-lambda (continuation-return-code continuation)
	(parsed-return-code (parser-output continuation))))

(set! continuation-annotation
      (named-lambda (continuation-annotation continuation)
	(parsed-annotation (parser-output continuation))))

(set! continuation-interrupt-enables
      (named-lambda (continuation-interrupt-enables continuation)
	(control-point-interrupt-enables (control-point continuation))))

(set! set-continuation-interrupt-enables!
      (named-lambda (set-continuation-interrupt-enables! continuation ie)
	(set-control-point-interrupt-enables! (control-point continuation)
					      ie)))

;;; Evaluated objects.

(define (make-evaluated-object expression)
  (list evaluated-object-tag expression))

(set! continuation-evaluated-object?
      (named-lambda (continuation-evaluated-object? object)
	(conjunction (pair? object)
		     (eq? (car object) evaluated-object-tag))))

(set! continuation-evaluated-object-value cadr)

;;; Undefined objects.

(set! continuation-undefined-expression?
      (named-lambda (continuation-undefined-expression? object)
	(eq? undefined-expression object)))

(set! continuation-undefined-environment?
      (named-lambda (continuation-undefined-environment? object)
	(eq? undefined-environment object)))
\f


;;;; Stack Parser

(define (parse-stack stack history dynamic-state offset-to-restore)
  (if (return-address? (car stack))
      ((vector-ref stack-parser-table (return-address-code (car stack)))
       stack history dynamic-state offset-to-restore)
      (parse-stack (stack-tail stack (- offset-to-restore 3))
		   history dynamic-state 3)))

(define stack-parser-table
  (vector-cons number-of-microcode-returns
	       (lambda (stack history dynamic-state offset-to-restore)
		 (error "Undefined return address"
			parse-stack
                  	(stack-ref stack 0)))))

(define (define-stack-parser name parser)
  (vector-set! stack-parser-table
	       (disjunction (microcode-return name)
			    (error "Unknown return address name"
				   define-stack-parser
				   name))
	       parser))

(define (define-standard-parser name parser)
  (define-stack-parser name
    (lambda (stack history dynamic-state offset)
      (parser (stack-tail stack 1)
	      history
	      (lambda (expression environment count . annotation)
		(apply make-parser-output
		       (cons* (stack-ref stack 0)
			      expression
			      environment
			      ((access history-reductions history-package)
			       history)
			      (stack-tail stack (1+ count))
			      ((access history-superproblem history-package)
			       history)
			      dynamic-state
			      (monus offset (1+ count))
			      annotation)))))))

(define (parse-standard-frame stack history cont)
  (cont (stack-ref stack 0)
	(stack-ref stack 1)
	2))

(define (parse-expression-only-frame stack history cont)
  (cont (stack-ref stack 0)
        undefined-environment
	1))
\f


;;;; Parser Output Abstraction

(define ((make-continuation promised-control-point
			    dynamic-state
			    promised-parser-output)
         value)
  (translate-to-state-point dynamic-state)
  ((force promised-control-point) value))

(define (control-point continuation)
  (force (access promised-control-point
                 (procedure-environment continuation))))

(define (parser-output continuation)
  (force (access promised-parser-output
                 (procedure-environment continuation))))

(define (make-parser-output return-address expression environment
                            reductions stack history dynamic-state
			    offset
			    . annotation)
  (list->vector
   (cons* expression environment reductions stack history dynamic-state
	  offset
          (if (return-address? return-address)
	      (return-address-code return-address)
	      '())
          annotation)))
\f


(define (parsed-expression parser-output)
  (vector-ref parser-output 0))

(define (parsed-environment parser-output)
  (vector-ref parser-output 1))

(define (parsed-reductions parser-output)
  (vector-ref parser-output 2))

(define (parsed-stack parser-output)
  (vector-ref parser-output 3))

(define (parsed-history parser-output)
  (vector-ref parser-output 4))

(define (parsed-dynamic-state parser-output)
  (vector-ref parser-output 5))

(define (parsed-offset-to-restore-history parser-output)
  (vector-ref parser-output 6))

(define (parsed-return-code parser-output)
  (vector-ref parser-output 7))

(define (parsed-annotation parser-output)
  (subvector->list parser-output 8 (vector-size parser-output)))
\f


;;;; Stack Abstraction

(define (stack-ref stack n)
  (car (stack-tail stack n)))

(define (stack-tail stack n)
  (if (zero? n)
      stack
      (stack-tail (force (cdr stack))
                  (-1+ n))))

(define (stack-list stack n)
  (if (zero? n)
      '()
      (cons (car stack)
            (stack-list (force (cdr stack))
                        (-1+ n)))))

(define (stack-split stack n receiver)
  (if (zero? n)
      (receiver '() stack)
      (stack-split (force (cdr stack)) (-1+ n)
        (lambda (head tail)
          (receiver (cons (car stack) head)
                    tail)))))

(define (monus a b)
  (if (= a 0) 0 (- a b)))

;;; end CONTINUATION package.
)