#| -*-Scheme-*-
-$Id: alpha.scm,v 1.12 1999/01/02 06:06:43 cph Exp $
+$Id: alpha.scm,v 1.13 1999/05/15 03:15:29 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
(define (alphaconv/rename-lambda-list lambda-list new-names)
(let loop ((ll lambda-list) (nn new-names) (result '()))
(cond ((null? ll) (reverse! result))
- ((memq (car ll) '(#!AUX #!OPTIONAL #!REST))
+ ((or (eq? #!optional (car ll))
+ (eq? #!rest (car ll))
+ (eq? #!aux (car ll)))
(loop (cdr ll) nn (cons (car ll) result)))
(else
(loop (cdr ll) (cdr nn) (cons (car nn) result))))))
#| -*-Scheme-*-
-$Id: cleanup.scm,v 1.32 1999/01/02 06:06:43 cph Exp $
+$Id: cleanup.scm,v 1.33 1999/05/15 03:15:25 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
(define (exit! name) (cleanup/env/exit! env name))
(let ((lambda-list*
(map (lambda (name)
- (if (memq name '(#!AUX #!REST #!OPTIONAL))
+ (if (lambda-list-keyword? name)
name
(cleanup/binding/name (cleanup/env/enter! env name))))
lambda-list)))
#| -*-Scheme-*-
-$Id: coerce.scm,v 1.7 1999/01/02 06:06:43 cph Exp $
+$Id: coerce.scm,v 1.8 1999/05/15 03:15:22 cph Exp $
Copyright (c) 1995, 1999 Massachusetts Institute of Technology
(bds '())
(rands (cons cont rands)))
(cond ((null? ll) bds)
- ((eq? (car ll) '#!optional)
+ ((eq? (car ll) #!optional)
(loop (cdr ll) bds rands))
((or (null? rands)
- (memq (car ll) '(#!aux #!rest)))
+ (eq? #!rest (car ll))
+ (eq? #!aux (car ll)))
(map* bds coerce/binding/make (lambda-list->names ll)))
(else
(loop (cdr ll)
#| -*-Scheme-*-
-$Id: dataflow.scm,v 1.21 1999/01/02 06:06:43 cph Exp $
+$Id: dataflow.scm,v 1.22 1999/05/15 03:15:17 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
(cond ((null? lambda-list)
(if (not (null? args))
(warn "Too many args" whole-lambda-list whole-args)))
- ((eq? (car lambda-list) '#!OPTIONAL)
+ ((eq? (car lambda-list) #!optional)
(optional-loop (cdr lambda-list) formals args))
- ((eq? (car lambda-list) '#!REST)
+ ((eq? (car lambda-list) #!rest)
(rest-loop (cdr lambda-list) formals args))
((null? args)
(warn "Too few arguments" whole-lambda-list whole-args))
(cond ((null? lambda-list)
(if (not (null? args))
(warn "Too many args" whole-lambda-list whole-args)))
- ((eq? (car lambda-list) '#!REST)
+ ((eq? (car lambda-list) #!rest)
(rest-loop (cdr lambda-list) formals args))
((null? args)
(do-optional! (car lambda-list) (car formals) #f)
#| -*-Scheme-*-
-$Id: ea2.scm,v 1.5 1999/01/02 06:06:43 cph Exp $
+$Id: ea2.scm,v 1.6 1999/05/15 03:15:14 cph Exp $
Copyright (c) 1995, 1999 Massachusetts Institute of Technology
env)
((or (null? names) (null? types))
(internal-error "Mismatch" names0 types0))
- ((eq? (car names) '#!optional)
+ ((eq? (car names) #!optional)
(loop (cdr names) types #T))
- ((eq? (car names) '#!aux)
+ ((eq? (car names) #!aux)
(loop (cdr names) types #T))
- ((eq? (car names) '#!rest)
+ ((eq? (car names) #!rest)
(extend! (second names) earlyrew/type/*unknown)
env)
(else
#| -*-Scheme-*-
-$Id: expand.scm,v 1.10 1999/01/02 06:06:43 cph Exp $
+$Id: expand.scm,v 1.11 1999/05/15 03:15:11 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
(expand/remember
(let ((lambda-list (lambda/formals form))
(body (expand/expr (lambda/body form))))
- (cond ((memq '#!AUX lambda-list)
+ (cond ((memq #!aux lambda-list)
=> (lambda (tail)
(let ((rest (list-prefix lambda-list tail))
(auxes (cdr tail)))
#| -*-Scheme-*-
-$Id: fakeprim.scm,v 1.31 1999/01/02 06:06:43 cph Exp $
+$Id: fakeprim.scm,v 1.32 1999/05/15 03:14:42 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
defs)))
(cond ((null? args)
defs)
- ((eq? (car args) '#!REST)
+ ((eq? (car args) #!rest)
(add-def (cadr args) path #F))
((eq? (car args) '#F)
(loop (cdr args) `(CDR ,path) defs))
;; NARGS = number of <value> expressions
;; Introduced by applicat.scm.
(make-operator "#[internal-apply]"))
-(cookie-call %internal-apply cont 'NARGS procedure #!REST values)
+(cookie-call %internal-apply cont 'NARGS procedure #!rest values)
(define-operator %internal-apply-unchecked
;; Like %internal-apply, but assumes that the procedure is compiled and
;; of the correct arity.
(make-operator "#[internal-apply-unchecked]"))
-(cookie-call %internal-apply-unchecked cont 'NARGS procedure #!REST values)
+(cookie-call %internal-apply-unchecked cont 'NARGS procedure #!rest values)
(define-operator %primitive-apply
;; (CALL ',%primitive-apply <continuation>
#| -*-Scheme-*-
-$Id: frag.scm,v 1.6 1999/01/02 06:06:43 cph Exp $
+$Id: frag.scm,v 1.7 1999/05/15 03:14:50 cph Exp $
Copyright (c) 1995, 1999 Massachusetts Institute of Technology
(generate (append new-required
(reverse new-args)
rest-list-args
- (if rest? (list '#!rest new-rest-arg) '()))
+ (if rest? (list #!rest new-rest-arg) '()))
(append (if rest?
(list (bind-ph terminal-ph new-rest-arg))
'())
#| -*-Scheme-*-
-$Id: inlate.scm,v 1.8 1999/01/02 06:06:43 cph Exp $
+$Id: inlate.scm,v 1.9 1999/05/15 03:14:59 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
(append req
(if (null? opt)
'()
- (cons '#!OPTIONAL opt))
+ (cons #!optional opt))
(if (not rest)
'()
- (list '#!REST rest))
+ (list #!rest rest))
(if (null? aux)
'()
- (cons '#!AUX aux))))
+ (cons #!aux aux))))
(new
`(LAMBDA ,(cons (new-continuation-variable) lambda-list)
,(let ((body (inlate/scode sbody #F)))
`(LAMBDA ,(append (cons (new-continuation-variable) req)
(if (null? opt)
'()
- (cons '#!OPTIONAL opt))
+ (cons #!optional opt))
(if (not rest)
'()
- (list '#!REST rest))
+ (list #!rest rest))
(if (null? aux)
'()
- (cons '#!AUX aux)))
+ (cons #!aux aux)))
,(let ((body (inlate/scode sbody)))
(if (null? decls)
body
#| -*-Scheme-*-
-$Id: kmp.scm,v 1.2 1999/01/02 06:06:43 cph Exp $
+$Id: kmp.scm,v 1.3 1999/05/15 03:15:06 cph Exp $
Copyright (c) 1995, 1999 Massachusetts Institute of Technology
defs)))
(cond ((null? args)
defs)
- ((eq? (car args) '#!REST)
+ ((eq? (car args) #!rest)
(add-def (cadr args) path))
((eq? (car args) '#F)
(loop (cdr args) `(CDR ,path) defs))
#| -*-Scheme-*-
-$Id: simplify.scm,v 1.21 1999/01/02 06:06:43 cph Exp $
+$Id: simplify.scm,v 1.22 1999/05/15 03:14:36 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
(cond ((null? ll)
(internal-error "Missing operand" name form))
((eq? name (car ll)) index)
- ((or (eq? (car ll) '#!OPTIONAL)
- (eq? (car ll) '#!REST))
+ ((or (eq? (car ll) #!optional)
+ (eq? (car ll) #!rest))
-1)
(else
(loop (cdr ll) (+ index 1)))))))
;; variables in ENV. Currently it does not update the debugging
;; info, but it should.
(define (rename name)
- (if (memq name '(#!aux #!rest #!optional))
+ (if (lambda-list-keyword? name)
name
(let ((new-name (variable/rename name)))
(dbg-info/remember name `(LOOKUP ,new-name))
#| -*-Scheme-*-
-$Id: synutl.scm,v 1.3 1999/01/02 06:06:43 cph Exp $
+$Id: synutl.scm,v 1.4 1999/05/15 03:14:46 cph Exp $
Copyright (c) 1994, 1999 Massachusetts Institute of Technology
(values (reverse names)
`(let ((,var* ,expr))
(,@prefix ,@(reverse args)))))
- ((eq? (car ll) '#!rest)
+ ((eq? (car ll) #!rest)
(loop '()
(cons (cadr ll) names)
(cons path args)
#| -*-Scheme-*-
-$Id: utils.scm,v 1.33 1999/01/02 06:06:43 cph Exp $
+$Id: utils.scm,v 1.34 1999/05/15 03:14:54 cph Exp $
Copyright (c) 1994-1999 Massachusetts Institute of Technology
\f
;;;; Lambda-list utilities
+(define (lambda-list-keyword? object)
+ (or (eq? #!optional object)
+ (eq? #!rest object)
+ (eq? #!aux object)))
+
(define (lambda-list->names lambda-list)
- (delq* '(#!OPTIONAL #!REST #!AUX) lambda-list))
+ (cond ((null? lambda-list)
+ lambda-list)
+ ((lambda-list-keyword? (car lambda-list))
+ (lambda-list->names (cdr lambda-list)))
+ (else
+ (cons (car lambda-list) (lambda-list->names (cdr lambda-list))))))
(define (lambda-list/count-names lambda-list)
(let loop ((list lambda-list) (count 0))
(cond ((null? list) count)
- ((memq (car list) '(#!OPTIONAL #!REST #!AUX))
+ ((lambda-list-keyword? (car list))
(loop (cdr list) count))
(else
(loop (cdr list) (+ count 1))))))
(define (hairy-lambda-list? lambda-list)
- (there-exists? lambda-list
- (lambda (token)
- (or (eq? token '#!OPTIONAL)
- (eq? token '#!REST)
- (eq? token '#!AUX)))))
+ (there-exists? lambda-list lambda-list-keyword?))
(define (guarantee-simple-lambda-list lambda-list)
(if (hairy-lambda-list? lambda-list)
(internal-error "Wrong number of arguments" len args)))
(define (lambda-list/applicate form lambda-list args)
- ;; If LAMBDA-LIST is to be simplified by removing #!OPTIONAL and #!REST
+ ;; If LAMBDA-LIST is to be simplified by removing #!optional and #!rest
;; markers, then the ARGS must be processed to ensure the lambda
;; bindings are bould to the same values. Returns a list of
- ;; expressions. #!AUX is not allowed. FORM is used only for error
+ ;; expressions. #!aux is not allowed. FORM is used only for error
;; reporting to locate the user's source.
(define (bad message)
(user-error message (form->source-irritant form)))
(if (not (null? ops))
(bad "Too many arguments"))
(reverse! ops*))
- ((eq? (car ll) '#!OPTIONAL)
+ ((eq? (car ll) #!optional)
(loop (if (or (null? (cddr ll))
- (eq? '#!REST (caddr ll)))
+ (eq? #!rest (caddr ll)))
(cddr ll)
- (cons '#!OPTIONAL (cddr ll)))
+ (cons #!optional (cddr ll)))
(if (null? ops)
ops
(cdr ops))
`(QUOTE ,%unassigned)
(car ops))
ops*)))
- ((eq? (car ll) '#!REST)
+ ((eq? (car ll) #!rest)
;; This only works before CPS conversion.
;; By that time, all "lexprs" should have been split.
(reverse!
(let parse ((ll lambda-list))
(cond ((null? ll)
(values '() '() false '()))
- ((eq? (car ll) '#!OPTIONAL)
+ ((eq? (car ll) #!optional)
(call-with-values
(lambda () (parse (cdr ll)))
(lambda (opt opt* rest aux)
(if (not (null? opt*))
- (internal-error "Multiple #!OPTIONAL specifiers"
+ (internal-error "Multiple #!optional specifiers"
lambda-list))
(values '() opt rest aux))))
- ((eq? (car ll) '#!REST)
+ ((eq? (car ll) #!rest)
(call-with-values
(lambda () (parse (cdr ll)))
(lambda (req opt rest aux)
(not (null? (cdr req)))
(not (null? opt))
rest)
- (internal-error "Unexpected stuff after #!REST" lambda-list))
+ (internal-error "Unexpected stuff after #!rest" lambda-list))
(values '() '() (car req) aux))))
- ((eq? (car ll) '#!AUX)
+ ((eq? (car ll) #!aux)
(call-with-values
(lambda () (parse (cdr ll)))
(lambda (req opt rest aux)
(not (null? opt))
rest
(not (null? aux)))
- (internal-error "Unexpected stuff after #!AUX" lambda-list))
+ (internal-error "Unexpected stuff after #!aux" lambda-list))
(values '() '() false req))))
(else
(call-with-values
#| -*-Scheme-*-
-$Id: widen.scm,v 1.10 1999/01/02 06:06:43 cph Exp $
+$Id: widen.scm,v 1.11 1999/05/15 03:14:31 cph Exp $
Copyright (c) 1994, 1999 Massachusetts Institute of Technology
(nodes value-nodes))
(cond ((null? nodes)
(continue name-map (reverse new-names)))
- ((memq (car names) '(#!REST #!OPTIONAL #!AUX))
+ ((lambda-list-keyword? (car names))
(loop name-map (cons (car names) new-names) (cdr names) nodes))
((widen/rewrite? (car nodes))
(let* ((this (car nodes))
projects / mit-scheme.git / commitdiff