From 625239220b10f1980759ec3a920fd7113872949c Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Sun, 30 Oct 1988 14:31:20 +0000 Subject: [PATCH] Add sf/usual-integrations-default-deletions. --- v7/src/sf/pardec.scm | 42 ++++++++++++++++++++++-------------------- v7/src/sf/toplev.scm | 11 ++++++++++- v8/src/sf/toplev.scm | 11 ++++++++++- 3 files changed, 42 insertions(+), 22 deletions(-) diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm index 987f6dbc9..5166dde5d 100644 --- a/v7/src/sf/pardec.scm +++ b/v7/src/sf/pardec.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 4.1 1988/06/13 12:29:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 4.2 1988/10/30 14:31:20 jinx Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -193,25 +193,27 @@ MIT in each case. |# (define-declaration 'USUAL-INTEGRATIONS true (lambda (block table/cons table deletions) block ;ignored - (let ((finish - (lambda (table operation names vals) - (with-values - (lambda () - (if (null? deletions) - (values names vals) - (let deletion-loop ((names names) (vals vals)) - (cond ((null? names) (values '() '())) - ((memq (car names) deletions) - (deletion-loop (cdr names) (cdr vals))) - (else - (with-values - (lambda () - (deletion-loop (cdr names) (cdr vals))) - (lambda (names* vals*) - (values (cons (car names) names*) - (cons (car vals) vals*))))))))) - (lambda (names vals) - (bind/values table/cons table operation false names vals)))))) + (let* ((deletions (append sf/usual-integrations-default-deletions + deletions)) + (finish + (lambda (table operation names vals) + (with-values + (lambda () + (if (null? deletions) + (values names vals) + (let deletion-loop ((names names) (vals vals)) + (cond ((null? names) (values '() '())) + ((memq (car names) deletions) + (deletion-loop (cdr names) (cdr vals))) + (else + (with-values + (lambda () + (deletion-loop (cdr names) (cdr vals))) + (lambda (names* vals*) + (values (cons (car names) names*) + (cons (car vals) vals*))))))))) + (lambda (names vals) + (bind/values table/cons table operation false names vals)))))) (finish (finish table 'INTEGRATE usual-integrations/constant-names usual-integrations/constant-values) diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 8de895da1..5bf3cfd16 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.2 1988/10/29 00:07:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.3 1988/10/30 14:27:50 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -72,6 +72,12 @@ Currently only the 68000 implementation needs this." (pathname/normalize pathname) syntax-table)) +(define (sf/set-usual-integrations-default-deletions! del-list) + (if (not (list-of-symbols? del-list)) + (error "sf/set-usual-integrations-default-deletions!: Bad deletion list" + del-list)) + (set! sf/usual-integrations-default-deletions del-list)) + (define (sf/add-file-declarations! pathname declarations) (let ((pathname (pathname/normalize pathname))) (pathname-map/insert! file-info/declarations @@ -109,6 +115,9 @@ Currently only the 68000 implementation needs this." (define sf/top-level-definitions '()) +(define sf/usual-integrations-default-deletions + '()) + (define (list-of-symbols? object) (or (null? object) (and (pair? object) diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index b48a5edaf..36b052620 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.2 1988/10/29 00:07:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.3 1988/10/30 14:27:50 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -72,6 +72,12 @@ Currently only the 68000 implementation needs this." (pathname/normalize pathname) syntax-table)) +(define (sf/set-usual-integrations-default-deletions! del-list) + (if (not (list-of-symbols? del-list)) + (error "sf/set-usual-integrations-default-deletions!: Bad deletion list" + del-list)) + (set! sf/usual-integrations-default-deletions del-list)) + (define (sf/add-file-declarations! pathname declarations) (let ((pathname (pathname/normalize pathname))) (pathname-map/insert! file-info/declarations @@ -109,6 +115,9 @@ Currently only the 68000 implementation needs this." (define sf/top-level-definitions '()) +(define sf/usual-integrations-default-deletions + '()) + (define (list-of-symbols? object) (or (null? object) (and (pair? object) -- 2.25.1