From: Chris Hanson Date: Sun, 5 Mar 2017 08:48:50 +0000 (-0800) Subject: Eliminate long-obsolete lexpr lambdas. X-Git-Tag: mit-scheme-pucked-9.2.12~195^2~12 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f37c09851aab7528ffefad1a745e25575defffd7;p=mit-scheme.git Eliminate long-obsolete lexpr lambdas. --- diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index e5aef5d8b..6f3c10395 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -34,7 +34,6 @@ USA. (set! special-form-procedure-names `((,lambda-tag:unnamed . LAMBDA) (,lambda-tag:internal-lambda . LAMBDA) - (,lambda-tag:internal-lexpr . LAMBDA) (,lambda-tag:let . LET) (,lambda-tag:fluid-let . FLUID-LET))) (set! directory-rewriting-rules (make-settable-parameter '())) diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm index 78746bd06..d921a8c0a 100644 --- a/src/runtime/lambda-list.scm +++ b/src/runtime/lambda-list.scm @@ -133,7 +133,6 @@ USA. ;; From lambda.scm (eq? object lambda-tag:internal-lambda) - (eq? object lambda-tag:internal-lexpr) ;; From syntax-output.scm (eq? object lambda-tag:fluid-let) diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm index 8d6860da7..d6094da07 100644 --- a/src/runtime/lambda.scm +++ b/src/runtime/lambda.scm @@ -52,16 +52,14 @@ USA. ;;; of a compound lambda. (define (initialize-package!) - (define ((dispatch-0 op-name clambda-op clexpr-op xlambda-op) *lambda) + (define ((dispatch-0 op-name clambda-op xlambda-op) *lambda) ((cond ((slambda? *lambda) clambda-op) - ((slexpr? *lambda) clexpr-op) ((xlambda? *lambda) xlambda-op) (else (error:wrong-type-argument *lambda "SCode lambda" op-name))) *lambda)) - (define ((dispatch-1 op-name clambda-op clexpr-op xlambda-op) *lambda arg) + (define ((dispatch-1 op-name clambda-op xlambda-op) *lambda arg) ((cond ((slambda? *lambda) clambda-op) - ((slexpr? *lambda) clexpr-op) ((xlambda? *lambda) xlambda-op) (else (error:wrong-type-argument *lambda "SCode lambda" op-name))) *lambda arg)) @@ -85,80 +83,58 @@ USA. (set! &lambda-components (dispatch-1 'LAMBDA-COMPONENTS clambda-components - clexpr-components xlambda-components)) (set! has-internal-lambda? (dispatch-0 'HAS-INTERNAL-LAMBDA? clambda-has-internal-lambda? - clexpr-has-internal-lambda? xlambda-has-internal-lambda?)) (set! lambda-arity (dispatch-1 'LAMBDA-ARITY slambda-arity - slexpr-arity xlambda-arity)) (set! lambda-body (dispatch-0 'LAMBDA-BODY clambda-unwrapped-body - clexpr/physical-body xlambda-unwrapped-body)) (set! lambda-bound (dispatch-0 'LAMBDA-BOUND clambda-bound - clexpr-bound xlambda-bound)) (set! lambda-bound? (dispatch-1 'LAMBDA-BOUND? clambda-bound? - clexpr-bound? xlambda-bound?)) (set! lambda-immediate-body (dispatch-0 'LAMBDA-IMMEDIATE-BODY slambda-body - slexpr-body xlambda-body)) (set! lambda-interface (dispatch-0 'LAMBDA-INTERFACE slambda-interface - clexpr-interface xlambda-interface)) (set! lambda-name (dispatch-0 'LAMBDA-NAME slambda-name - slexpr-name xlambda-name)) (set! lambda-names-vector (dispatch-0 'LAMBDA-NAMES-VECTOR slambda-names-vector - slexpr-names-vector xlambda-names-vector)) (set! lambda-unwrap-body! (dispatch-0 'LAMBDA-UNWRAP-BODY! clambda-unwrap-body! - (lambda (*lambda) - *lambda - (error "Cannot advise clexprs.")) xlambda-unwrap-body!)) (set! lambda-wrap-body! (dispatch-1 'LAMBDA-WRAP-BODY! clambda-wrap-body! - (lambda (*lambda transform) - *lambda transform - (error "Cannot advise clexprs.")) xlambda-wrap-body!)) (set! lambda-wrapper-components (dispatch-1 'LAMBDA-WRAPPER-COMPONENTS clambda-wrapper-components - (lambda (*lambda receiver) - *lambda receiver - (error "Cannot advise clexprs.")) xlambda-wrapper-components)) (set! set-lambda-body! (dispatch-1 'SET-LAMBDA-BODY! set-clambda-unwrapped-body! - (lambda (*lambda new-body) - *lambda new-body - (error "Cannot advise clexprs.")) set-xlambda-unwrapped-body!))) ;;;; Hairy Advice Wrappers @@ -296,64 +272,6 @@ USA. (define (clambda/set-physical-body! clambda body) (set-slambda-body! (or (clambda-has-internal-lambda? clambda) clambda) body)) -;;;; Compound Lexpr - -;;; TODO(jrm): I'm removing constructor so new SCode won't contain -;;; these, although given the conditions it is unlikely there were -;;; any. In the next release we can remove the accessors etc. - -(define (clexpr-components clexpr receiver) - (slexpr-components clexpr - (lambda (name required body) - (let ((internal (combination-operator body))) - (let ((auxiliary (slambda-auxiliary internal))) - (receiver name - required - '() - (car auxiliary) - (append (cdr auxiliary) - (lambda-body-auxiliary (slambda-body internal))) - (clexpr/physical-body clexpr))))))) - -(define (clexpr-bound clexpr) - (slexpr-components clexpr - (lambda (name required body) - name - (let ((internal (combination-operator body))) - (append required - (slambda-auxiliary internal) - (lambda-body-auxiliary (slambda-body internal))))))) - -(define (clexpr-bound? clexpr symbol) - (or (slexpr-bound? clexpr symbol) - (clexpr-internal-bound? clexpr symbol))) - -(define (clexpr-interface clexpr) - (slexpr-components clexpr - (lambda (name required body) - name - (let ((internal (combination-operator body))) - (let ((auxiliary (slambda-auxiliary internal))) - (make-lambda-list required '() (car auxiliary) '())))))) - -(define (clexpr-has-internal-lambda? clexpr) - (let ((internal (combination-operator (slexpr-body clexpr)))) - (or (lambda-body-has-internal-lambda? (slambda-body internal)) - internal))) - -(define (clexpr-internal-bound? clexpr symbol) - (let ((body (slexpr-body clexpr))) - (and (combination? body) - (let ((operator (combination-operator body))) - (and (internal-lambda? operator) - (internal-lambda-bound? operator symbol)))))) - -(define (clexpr/physical-body clexpr) - (slambda-body (clexpr-has-internal-lambda? clexpr))) - -(define (clexpr/set-physical-body! clexpr body) - (set-slambda-body! (clexpr-has-internal-lambda? clexpr) body)) - ;;;; Extended Lambda (define (xlambda? object) @@ -486,7 +404,6 @@ USA. (define (lambda? object) (or (slambda? object) - (slexpr? object) (xlambda? object))) (define (make-lambda name required optional rest auxiliary declarations body) @@ -636,54 +553,12 @@ USA. (receiver (%slambda-name slambda) (%slambda-interface slambda) (%slambda-body slambda))) - -;;;; Simple lexpr - -;;; TODO(jrm): I've removed the constructor so new SCode won't -;;; contain these. In the next release we can remove the accessors -;;; etc. - -(define-integrable slexpr-type - (ucode-type lexpr)) - -(define-integrable (slexpr? object) - (object-type? slexpr-type object)) - -(define (slexpr-components slexpr receiver) - (let ((bound (&pair-cdr slexpr))) - (receiver (vector-ref bound 0) - (subvector->list bound 1 (vector-length bound)) - (&pair-car slexpr)))) - -(define (slexpr-interface slexpr) - (let ((bound (&pair-cdr slexpr))) - (subvector->list bound 1 (vector-length bound)))) - -(define (slexpr-arity slexpr offset) - (let ((bound (&pair-cdr slexpr))) - (make-lambda-arity (- (vector-length bound) 2) 0 #t offset))) - -(define (slexpr-names-vector slexpr) - (&pair-cdr slexpr)) - -(define (slexpr-bound? slexpr symbol) - (let ((bound (&pair-cdr slexpr))) - (subvector-find-next-element bound 1 (vector-length bound) symbol))) - -(define-integrable (slexpr-name slexpr) - (vector-ref (&pair-cdr slexpr) 0)) - -(define-integrable (slexpr-body slexpr) - (&pair-car slexpr)) ;;;; Internal Lambda (define-integrable lambda-tag:internal-lambda ((ucode-primitive string->symbol) "#[internal-lambda]")) -(define-integrable lambda-tag:internal-lexpr - ((ucode-primitive string->symbol) "#[internal-lexpr]")) - (define-integrable (%make-internal-lambda names body) (make-slambda lambda-tag:internal-lambda names body)) @@ -695,8 +570,7 @@ USA. (define (internal-lambda? *lambda) (and (slambda? *lambda) - (or (eq? (slambda-name *lambda) lambda-tag:internal-lambda) - (eq? (slambda-name *lambda) lambda-tag:internal-lexpr)))) + (eq? (slambda-name *lambda) lambda-tag:internal-lambda))) (define (internal-lambda-bound? *lambda symbol) (and (slambda? *lambda) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 412d4ced0..3a08d61de 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2770,11 +2770,9 @@ USA. lambda-names-vector make-slambda) (export (runtime compiler-info) - lambda-tag:internal-lambda - lambda-tag:internal-lexpr) + lambda-tag:internal-lambda) (export (runtime lambda-list) - lambda-tag:internal-lambda - lambda-tag:internal-lexpr) + lambda-tag:internal-lambda) (export (runtime unsyntaxer) lambda-immediate-body) (initialization (initialize-package!)))