(define (integrate/primitive-operator expression operations environment
block operator operands)
- (let ((integration-failure
- (lambda ()
- (combination/optimizing-make expression block operator operands))))
- (operations/lookup operations (constant/value operator)
- (lambda (operation info)
- (case operation
- ((#F) (integration-failure))
- ((EXPAND)
- (info expression
- operands
- (lambda (expression)
- (integrate/expression operations environment expression))
- integration-failure
- block))
- (else (error "Unknown operation" operation))))
- integration-failure)))
+ (declare (ignore operations environment))
+ (combination/optimizing-make expression block operator operands))
\f
;;; ((let ((a (foo)) (b (bar)))
;;; (lambda (receiver)
(warn "Unable to integrate" (variable/name variable))
(if-not))))
\f
-(define *unknown-value "Unknown Value")
-
-(define (simulate-unknown-application environment procedure)
- (define (bind-required environment required)
- (if (null? required)
- (bind-optional environment (procedure/optional procedure))
- (bind-required
- (environment/bind environment (car required) *unknown-value)
- (cdr required))))
-
- (define (bind-optional environment optional)
- (if (null? optional)
- (bind-rest environment (procedure/rest procedure))
- (bind-optional
- (environment/bind environment (car optional) *unknown-value)
- (cdr optional))))
-
- (define (bind-rest environment rest)
- (if (null? rest)
- environment
- (environment/bind environment rest *unknown-value)))
-
- (bind-required environment (procedure/required procedure)))
(define (integrate/hack-apply? operands)
(define (check operand)
(append (except-last-pair operands)
tail)))))
\f
-(define (simulate-application environment block procedure operands)
- (define (procedure->pretty procedure)
- (if (procedure/scode procedure)
- (unsyntax (procedure/scode procedure))
- (let ((arg-list (append (procedure/required procedure)
- (if (null? (procedure/optional procedure))
- '()
- (cons lambda-tag:optional
- (procedure/optional procedure)))
- (if (not (procedure/rest procedure))
- '()
- (procedure/rest procedure)))))
- (if (procedure/name procedure)
- `(named-lambda (,(procedure/name procedure) ,@arg-list)
- ...)
- `(lambda ,arg-list
- ...)))))
-
- (define (match-required environment required operands)
- (cond ((null? required)
- (match-optional environment
- (procedure/optional procedure)
- operands))
- ((null? operands)
- (error "Too few operands in call to procedure"
- procedure
- (procedure->pretty procedure)))
- (else
- (match-required (environment/bind environment
- (car required)
- (car operands))
- (cdr required)
- (cdr operands)))))
-
- (define (match-optional environment optional operands)
- (cond ((null? optional)
- (match-rest environment (procedure/rest procedure) operands))
- ((null? operands)
- (match-rest environment (procedure/rest procedure) '()))
- (else
- (match-optional (environment/bind environment
- (car optional)
- (car operands))
- (cdr optional)
- (cdr operands)))))
-
- (define (listify-tail operands)
- (let ((const-null (constant/make #f '())))
- (if (null? operands)
- const-null
- (let ((const-cons (constant/make #f (ucode-primitive cons))))
- (let walk ((operands operands))
- (if (null? operands)
- const-null
- (combination/make #f
- block
- const-cons
- (list (car operands)
- (walk (cdr operands))))))))))
-
- (define (match-rest environment rest operands)
- (cond (rest
- (environment/bind environment rest (listify-tail operands)))
- ((null? operands)
- environment)
- (else
- (error "Too many operands in call to procedure"
- procedure
- (procedure->pretty procedure)))))
-
- (match-required environment (procedure/required procedure) operands))
-\f
-(define (environment/make)
- '())
-
-(define-integrable (environment/bind environment variable value)
- (cons (cons variable value) environment))
-
-(define-integrable (environment/bind-multiple environment variables values)
- (map* environment cons variables values))
-
-(define (environment/lookup environment variable if-found if-unknown if-not)
- (let ((association (assq variable environment)))
- (if association
- (if (eq? (cdr association) *unknown-value)
- (if-unknown)
- (if-found (cdr association)))
- (if-not))))
(define (delayed-integration/in-progress? delayed-integration)
(eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED))
(declare (usual-integrations)
(integrate-external "object"))
\f
+;;;; Environment
+
+;; An environment is implemented as an alist mapping a variable
+;; to one of three things, a value, an unknown-value marker, or
+;; a delayed integration.
+
+(define (environment/make)
+ '())
+
+(define (environment/bind environment variable value)
+ (guarantee-variable variable 'environment/bind)
+ (alist-cons variable value environment))
+
+(define-integrable (environment/bind-multiple environment variables values)
+ (map* environment cons variables values))
+
+(define (environment/lookup environment variable if-found if-unknown if-not)
+ (let ((association (assq variable environment)))
+ (if association
+ (if (eq? (cdr association) *unknown-value)
+ (if-unknown)
+ (if-found (cdr association)))
+ (if-not))))
+
+(define *unknown-value (string-copy "Unknown Value"))
+
+;; Extend the environment with bindings for the formal parameters.
+;; Each binding is given the *unknown-value object.
+(define (simulate-unknown-application environment procedure)
+ (define (bind-required environment required)
+ (if (null? required)
+ (bind-optional environment (procedure/optional procedure))
+ (bind-required
+ (environment/bind environment (car required) *unknown-value)
+ (cdr required))))
+
+ (define (bind-optional environment optional)
+ (if (null? optional)
+ (bind-rest environment (procedure/rest procedure))
+ (bind-optional
+ (environment/bind environment (car optional) *unknown-value)
+ (cdr optional))))
+
+ (define (bind-rest environment rest)
+ (if rest
+ (environment/bind environment rest *unknown-value)
+ environment))
+
+ (bind-required environment (procedure/required procedure)))
+
+;; Extend the environment with actual bindings for the formal
+;; parameters. If the arity does not match, issue a warning
+;; and fall back to the unknown case.
+(define (simulate-application base-environment block procedure operands)
+ (define (procedure->pretty procedure)
+ (if (procedure/scode procedure)
+ (unsyntax (procedure/scode procedure))
+ (let ((arg-list (append (procedure/required procedure)
+ (if (null? (procedure/optional procedure))
+ '()
+ (cons lambda-tag:optional
+ (procedure/optional procedure)))
+ (if (not (procedure/rest procedure))
+ '()
+ (procedure/rest procedure)))))
+ (if (procedure/name procedure)
+ `(named-lambda (,(procedure/name procedure) ,@arg-list)
+ ...)
+ `(lambda ,arg-list
+ ...)))))
+
+ (define (fail message . irritants)
+ (apply warn message irritants)
+ (simulate-unknown-application base-environment procedure))
+
+ (define (match-required environment required remaining-operands)
+ (cond ((pair? required)
+ (cond ((pair? remaining-operands)
+ (match-required (environment/bind environment
+ (car required)
+ (car remaining-operands))
+ (cdr required)
+ (cdr remaining-operands)))
+ ((null? remaining-operands)
+ (fail "Too few operands in call to procedure"
+ procedure
+ (procedure->pretty procedure)))
+ (else
+ (fail "Improper list of operands in application"
+ procedure
+ (procedure->pretty procedure)
+ operands))))
+
+ ((null? required)
+ (match-optional environment
+ (procedure/optional procedure)
+ remaining-operands))
+
+ ;; impossible?
+ (else (error "INTERNAL ERROR: Required argument list is improper"
+ required))))
+
+ (define (match-optional environment optional remaining-operands)
+ (cond ((pair? optional)
+ (cond ((pair? remaining-operands)
+ (match-optional (environment/bind environment
+ (car optional)
+ (car remaining-operands))
+ (cdr optional)
+ (cdr remaining-operands)))
+ ((null? remaining-operands)
+ (match-rest environment (procedure/rest procedure) '()))
+ (else
+ (fail "Improper list of operands in application"
+ procedure
+ (procedure->pretty procedure)
+ operands))))
+
+ ((null? optional)
+ (match-rest environment (procedure/rest procedure) remaining-operands))
+ ;; impossible?
+ (else (error "INTERNAL ERROR: Required argument list is improper"
+ required))))
+
+ (define (listify-tail operands)
+ (fold-right
+ (lambda (operand tail)
+ (combination/make #f
+ block
+ (constant/make #f (ucode-primitive cons))
+ (list operand tail)))
+ (constant/make #f '())
+ operands))
+
+ (define (match-rest environment rest remaining-operands)
+ (cond (rest
+ (environment/bind environment rest (listify-tail remaining-operands)))
+ ((null? remaining-operands)
+ environment)
+ (else
+ (fail "Too many operands in call to procedure"
+ procedure
+ (procedure->pretty procedure)
+ operands))))
+
+ (match-required base-environment (procedure/required procedure) operands))
+
;;;; Operations
+;; An operations table is a cons of two alists. The first alist
+;; contains the lexically visible operations, the second contains
+;; the global operations.
+
(define (operations/make)
(cons '() '()))
(define (operations/lookup operations variable if-found if-not)
+ (guarantee-variable variable 'operations/lookup)
(let ((entry (assq variable (car operations))))
(if entry
(if (cdr entry)
(if-found (cadr entry) (cddr entry))
(if-not))))))
+;; When processing a global reference, we only have a name.
+(define (operations/lookup-global operations name if-found if-not)
+ (guarantee-symbol name 'operations/lookup-global)
+ (let ((probe (find (lambda (entry)
+ (eq? (variable/name (car entry)) name))
+ (cdr operations))))
+ (if probe
+ (if-found (cadr probe) (cddr probe))
+ (if-not))))
+
(define (operations/shadow operations variables)
(cons (map* (car operations)
- (lambda (variable) (cons variable false))
+ (lambda (variable)
+ (guarantee-variable variable 'operations/shadow)
+ (cons variable false))
variables)
(cdr operations)))
(define (operations/bind operations operation variable value)
+ (guarantee-known-declaration operation 'operations/bind)
+ (guarantee-variable variable 'operations/bind)
(cons (cons (cons* variable operation value)
(car operations))
(cdr operations)))
(define (operations/bind-global operations operation variable value)
+ (guarantee-known-declaration operation 'operations/bind-global)
+ (guarantee-variable variable 'operations/bind-global)
(cons (car operations)
(cons (cons* variable operation value)
(cdr operations))))
(cons (procedure (cadar elements) (caar elements) (cddar elements))
(loop (cdr elements))))
(else
- (loop (cdr elements))))))
\ No newline at end of file
+ (loop (cdr elements))))))
projects / mit-scheme.git / commitdiff