mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-29 08:20:20 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
There are a some failures currently:
FAIL: tree-il.test: warnings: format: non-literal format string with forward declaration
ERROR: srfi-18.test: current-exception-handler: current handler returned at top level - arguments: ((wrong-type-arg "car" "Wrong type argument in position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>) (#<unspecified>)))
ERROR: srfi-18.test: current-exception-handler: multiple levels of handler nesting - arguments: ((wrong-type-arg "car" "Wrong type argument in position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>) (#<unspecified>)))
ERROR: srfi-18.test: current-exception-handler: exception handler installation is thread-safe - arguments: ((wrong-type-arg "car" "Wrong type argument in position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>) (#<unspecified>)))
Conflicts:
module/language/tree-il/peval.scm
module/language/tree-il/primitives.scm
test-suite/tests/tree-il.test
This commit is contained in:
Andy Wingo
commit
d489998364
11 changed files with 535 additions and 449 deletions
|
|
@ -1360,7 +1360,8 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
|
|||
(($ <toplevel-ref> _ name)
|
||||
(let ((var (false-if-exception (module-variable env name))))
|
||||
(if var
|
||||
(eq? (variable-ref var) proc)
|
||||
(eq? (false-if-exception (variable-ref var)) ; VAR may be unbound
|
||||
proc)
|
||||
(eq? name special-name)))) ; special hack to support local aliases
|
||||
(($ <module-ref> _ module name public?)
|
||||
(let ((m (false-if-exception (if public?
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Tree-il canonicalizer
|
||||
|
||||
;; Copyright (C) 2011 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
|
||||
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -48,10 +48,10 @@
|
|||
(define (escape-only? handler)
|
||||
(match handler
|
||||
(($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
|
||||
(tree-il-any (lambda (x)
|
||||
(not (tree-il-any (lambda (x)
|
||||
(and (lexical-ref? x)
|
||||
(eq? (lexical-ref-gensym x) cont)))
|
||||
body))
|
||||
body)))
|
||||
(else #f)))
|
||||
(define (thunk-application? x)
|
||||
(match x
|
||||
|
|
|
|||
|
|
@ -1221,12 +1221,27 @@ top-level bindings from ENV and return the resulting expression."
|
|||
exp
|
||||
(make-lambda src meta (for-values body))))))
|
||||
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
|
||||
(define (lift-applied-lambda body gensyms)
|
||||
(and (not opt) rest (not kw)
|
||||
(match body
|
||||
(($ <primcall> _ '@apply
|
||||
(($ <lambda> _ _ lcase)
|
||||
($ <lexical-ref> _ _ sym)
|
||||
...))
|
||||
(and (equal? sym gensyms)
|
||||
(not (lambda-case-alternate lcase))
|
||||
lcase))
|
||||
(_ #f))))
|
||||
(let* ((vars (map lookup-var gensyms))
|
||||
(new (fresh-gensyms vars))
|
||||
(env (fold extend-env env gensyms
|
||||
(make-unbound-operands vars new)))
|
||||
(new-sym (lambda (old)
|
||||
(operand-sym (cdr (vhash-assq old env))))))
|
||||
(operand-sym (cdr (vhash-assq old env)))))
|
||||
(body (loop body env counter ctx)))
|
||||
(or
|
||||
;; (lambda args (apply (lambda ...) args)) => (lambda ...)
|
||||
(lift-applied-lambda body new)
|
||||
(make-lambda-case src req opt rest
|
||||
(match kw
|
||||
((aok? (kw name old) ...)
|
||||
|
|
@ -1234,8 +1249,8 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(_ #f))
|
||||
(map (cut loop <> env counter 'value) inits)
|
||||
new
|
||||
(loop body env counter ctx)
|
||||
(and alt (for-tail alt)))))
|
||||
body
|
||||
(and alt (for-tail alt))))))
|
||||
(($ <seq> src head tail)
|
||||
(let ((head (for-effect head))
|
||||
(tail (for-tail tail)))
|
||||
|
|
|
|||
|
|
@ -544,22 +544,21 @@
|
|||
'call-with-prompt
|
||||
(case-lambda
|
||||
((src tag thunk handler)
|
||||
;; Sigh. Until the inliner does its job, manually inline
|
||||
;; (let ((h (lambda ...))) (prompt k x h))
|
||||
(cond
|
||||
((lambda? handler)
|
||||
(let ((args-sym (gensym)))
|
||||
(let ((handler-sym (gensym))
|
||||
(args-sym (gensym)))
|
||||
(make-let
|
||||
src '(handler) (list handler-sym) (list handler)
|
||||
(make-prompt
|
||||
src tag (make-call #f thunk '())
|
||||
;; If handler itself is a lambda, the inliner can do some
|
||||
;; trickery here.
|
||||
(make-lambda-case
|
||||
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
|
||||
(make-primcall #f 'apply
|
||||
(list handler
|
||||
(make-primcall
|
||||
#f 'apply
|
||||
(list (make-lexical-ref #f 'handler handler-sym)
|
||||
(make-lexical-ref #f 'args args-sym)))
|
||||
#f))))
|
||||
(else #f)))
|
||||
#f)))))
|
||||
(else #f)))
|
||||
|
||||
(hashq-set! *primitive-expand-table*
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
|
||||
|
||||
;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
|
||||
;; 2012 Free Software Foundation, Inc.
|
||||
;;
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -79,7 +80,8 @@
|
|||
(apply make-srfi-4-vector ',tag len fill))
|
||||
(define (,(symbol-append tag 'vector-length) v)
|
||||
(let ((len (* (uniform-vector-length v)
|
||||
(/ ,size (uniform-vector-element-size v)))))
|
||||
(uniform-vector-element-size v)
|
||||
(/ ,size))))
|
||||
(if (integer? len)
|
||||
len
|
||||
(error "fractional length" v ',tag ,size))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Extensions to SRFI-4
|
||||
|
||||
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
;;
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -52,7 +52,8 @@
|
|||
(apply make-srfi-4-vector ',tag len fill))
|
||||
(define (,(symbol-append tag 'vector-length) v)
|
||||
(let ((len (* (uniform-vector-length v)
|
||||
(/ ,size (uniform-vector-element-size v)))))
|
||||
(uniform-vector-element-size v)
|
||||
(/ ,size))))
|
||||
(if (integer? len)
|
||||
len
|
||||
(error "fractional length" v ',tag ,size))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; pmatch, a simple matcher
|
||||
|
||||
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc
|
||||
;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
|
||||
;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
|
||||
;;; Copyright (C) 2007 Daniel P. Friedman
|
||||
;;;
|
||||
|
|
@ -35,22 +35,22 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system base pmatch)
|
||||
#:export (pmatch))
|
||||
#:export-syntax (pmatch))
|
||||
|
||||
(define-syntax pmatch
|
||||
(define-syntax-rule (pmatch e cs ...)
|
||||
(let ((v e)) (pmatch1 v cs ...)))
|
||||
|
||||
(define-syntax pmatch1
|
||||
(syntax-rules (else guard)
|
||||
((_ (op arg ...) cs ...)
|
||||
(let ((v (op arg ...)))
|
||||
(pmatch v cs ...)))
|
||||
((_ v) (if #f #f))
|
||||
((_ v (else e0 e ...)) (let () e0 e ...))
|
||||
((_ v (pat (guard g ...) e0 e ...) cs ...)
|
||||
(let ((fk (lambda () (pmatch v cs ...))))
|
||||
(let ((fk (lambda () (pmatch1 v cs ...))))
|
||||
(ppat v pat
|
||||
(if (and g ...) (let () e0 e ...) (fk))
|
||||
(fk))))
|
||||
((_ v (pat e0 e ...) cs ...)
|
||||
(let ((fk (lambda () (pmatch v cs ...))))
|
||||
(let ((fk (lambda () (pmatch1 v cs ...))))
|
||||
(ppat v pat (let () e0 e ...) (fk))))))
|
||||
|
||||
(define-syntax ppat
|
||||
|
|
|
|||
|
|
@ -314,11 +314,11 @@
|
|||
|
||||
;;; The central testing routine.
|
||||
;;; The idea is taken from Greg, the GNUstep regression test environment.
|
||||
(define run-test #f)
|
||||
(let ((test-running #f))
|
||||
(define (local-run-test name expect-pass thunk)
|
||||
(define run-test
|
||||
(let ((test-running #f))
|
||||
(lambda (name expect-pass thunk)
|
||||
(if test-running
|
||||
(error "Nested calls to run-test are not permitted.")
|
||||
(error "Nested calls to run-test are not permitted."))
|
||||
(let ((test-name (full-name name)))
|
||||
(set! test-running #t)
|
||||
(catch #t
|
||||
|
|
@ -340,8 +340,7 @@
|
|||
(quit))
|
||||
(else
|
||||
(report 'error test-name (cons key args))))))
|
||||
(set! test-running #f))))
|
||||
(set! run-test local-run-test))
|
||||
(set! test-running #f)))))
|
||||
|
||||
;;; A short form for tests that are expected to pass, taken from Greg.
|
||||
(define-syntax pass-if
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
|
||||
;;;; Julian Graham, 2007-10-26
|
||||
;;;;
|
||||
;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2007, 2008, 2012 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -25,15 +25,14 @@
|
|||
(if (provided? 'threads)
|
||||
(use-modules (srfi srfi-18)))
|
||||
|
||||
(and
|
||||
(provided? 'threads)
|
||||
|
||||
(with-test-prefix "current-thread"
|
||||
(cond
|
||||
((provided? 'threads)
|
||||
(with-test-prefix "current-thread"
|
||||
|
||||
(pass-if "current-thread eq current-thread"
|
||||
(eq? (current-thread) (current-thread))))
|
||||
|
||||
(with-test-prefix "thread?"
|
||||
(with-test-prefix "thread?"
|
||||
|
||||
(pass-if "current-thread is thread"
|
||||
(thread? (current-thread)))
|
||||
|
|
@ -41,7 +40,7 @@
|
|||
(pass-if "foo not thread"
|
||||
(not (thread? 'foo))))
|
||||
|
||||
(with-test-prefix "make-thread"
|
||||
(with-test-prefix "make-thread"
|
||||
|
||||
(pass-if "make-thread creates new thread"
|
||||
(let* ((n (length (all-threads)))
|
||||
|
|
@ -49,7 +48,7 @@
|
|||
(r (> (length (all-threads)) n)))
|
||||
(thread-terminate! t) r)))
|
||||
|
||||
(with-test-prefix "thread-name"
|
||||
(with-test-prefix "thread-name"
|
||||
|
||||
(pass-if "make-thread with name binds name"
|
||||
(let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
|
||||
|
|
@ -61,7 +60,7 @@
|
|||
(r (not (thread-name t))))
|
||||
(thread-terminate! t) r)))
|
||||
|
||||
(with-test-prefix "thread-specific"
|
||||
(with-test-prefix "thread-specific"
|
||||
|
||||
(pass-if "thread-specific is initially #f"
|
||||
(let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
|
||||
|
|
@ -74,7 +73,7 @@
|
|||
(let ((r (equal? (thread-specific t) "hello")))
|
||||
(thread-terminate! t) r))))
|
||||
|
||||
(with-test-prefix "thread-start!"
|
||||
(with-test-prefix "thread-start!"
|
||||
|
||||
(pass-if "thread activates only after start"
|
||||
(let* ((started #f)
|
||||
|
|
@ -82,12 +81,12 @@
|
|||
(t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
|
||||
(and (not started) (thread-start! t) (thread-join! t) started))))
|
||||
|
||||
(with-test-prefix "thread-yield!"
|
||||
(with-test-prefix "thread-yield!"
|
||||
|
||||
(pass-if "thread yield suceeds"
|
||||
(thread-yield!) #t))
|
||||
|
||||
(with-test-prefix "thread-sleep!"
|
||||
(with-test-prefix "thread-sleep!"
|
||||
|
||||
(pass-if "thread sleep with time"
|
||||
(let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
|
||||
|
|
@ -101,7 +100,7 @@
|
|||
(let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
|
||||
(unspecified? (thread-sleep! past-time)))))
|
||||
|
||||
(with-test-prefix "thread-terminate!"
|
||||
(with-test-prefix "thread-terminate!"
|
||||
|
||||
(pass-if "termination destroys non-started thread"
|
||||
(let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
|
||||
|
|
@ -134,7 +133,7 @@
|
|||
(lambda () (thread-join! t)))
|
||||
success)))
|
||||
|
||||
(with-test-prefix "thread-join!"
|
||||
(with-test-prefix "thread-join!"
|
||||
|
||||
(pass-if "join receives result of thread"
|
||||
(let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
|
||||
|
|
@ -167,7 +166,7 @@
|
|||
(thread-start! t)
|
||||
(eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
|
||||
|
||||
(with-test-prefix "mutex?"
|
||||
(with-test-prefix "mutex?"
|
||||
|
||||
(pass-if "make-mutex creates mutex"
|
||||
(mutex? (make-mutex)))
|
||||
|
|
@ -175,7 +174,7 @@
|
|||
(pass-if "symbol not mutex"
|
||||
(not (mutex? 'foo))))
|
||||
|
||||
(with-test-prefix "mutex-name"
|
||||
(with-test-prefix "mutex-name"
|
||||
|
||||
(pass-if "make-mutex with name binds name"
|
||||
(let* ((m (make-mutex 'mutex-name-1)))
|
||||
|
|
@ -185,7 +184,7 @@
|
|||
(let* ((m (make-mutex)))
|
||||
(not (mutex-name m)))))
|
||||
|
||||
(with-test-prefix "mutex-specific"
|
||||
(with-test-prefix "mutex-specific"
|
||||
|
||||
(pass-if "mutex-specific is initially #f"
|
||||
(let ((m (make-mutex 'mutex-specific-1)))
|
||||
|
|
@ -196,7 +195,7 @@
|
|||
(mutex-specific-set! m "hello")
|
||||
(equal? (mutex-specific m) "hello"))))
|
||||
|
||||
(with-test-prefix "mutex-state"
|
||||
(with-test-prefix "mutex-state"
|
||||
|
||||
(pass-if "mutex state is initially not-abandoned"
|
||||
(let ((m (make-mutex 'mutex-state-1)))
|
||||
|
|
@ -219,7 +218,7 @@
|
|||
(thread-join! t)
|
||||
(eq? (mutex-state m) 'abandoned))))
|
||||
|
||||
(with-test-prefix "mutex-lock!"
|
||||
(with-test-prefix "mutex-lock!"
|
||||
|
||||
(pass-if "mutex-lock! returns true on successful lock"
|
||||
(let* ((m (make-mutex 'mutex-lock-1)))
|
||||
|
|
@ -280,7 +279,7 @@
|
|||
(lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
|
||||
success)))
|
||||
|
||||
(with-test-prefix "mutex-unlock!"
|
||||
(with-test-prefix "mutex-unlock!"
|
||||
|
||||
(pass-if "unlock changes mutex state"
|
||||
(let* ((m (make-mutex 'mutex-unlock-1)))
|
||||
|
|
@ -313,7 +312,7 @@
|
|||
(mutex-lock! m)
|
||||
(not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
|
||||
|
||||
(with-test-prefix "condition-variable?"
|
||||
(with-test-prefix "condition-variable?"
|
||||
|
||||
(pass-if "make-condition-variable creates condition variable"
|
||||
(condition-variable? (make-condition-variable)))
|
||||
|
|
@ -321,7 +320,7 @@
|
|||
(pass-if "symbol not condition variable"
|
||||
(not (condition-variable? 'foo))))
|
||||
|
||||
(with-test-prefix "condition-variable-name"
|
||||
(with-test-prefix "condition-variable-name"
|
||||
|
||||
(pass-if "make-condition-variable with name binds name"
|
||||
(let* ((c (make-condition-variable 'condition-variable-name-1)))
|
||||
|
|
@ -331,7 +330,7 @@
|
|||
(let* ((c (make-condition-variable)))
|
||||
(not (condition-variable-name c)))))
|
||||
|
||||
(with-test-prefix "condition-variable-specific"
|
||||
(with-test-prefix "condition-variable-specific"
|
||||
|
||||
(pass-if "condition-variable-specific is initially #f"
|
||||
(let ((c (make-condition-variable 'condition-variable-specific-1)))
|
||||
|
|
@ -342,7 +341,7 @@
|
|||
(condition-variable-specific-set! c "hello")
|
||||
(equal? (condition-variable-specific c) "hello"))))
|
||||
|
||||
(with-test-prefix "condition-variable-signal!"
|
||||
(with-test-prefix "condition-variable-signal!"
|
||||
|
||||
(pass-if "condition-variable-signal! wakes up single thread"
|
||||
(let* ((m (make-mutex 'condition-variable-signal-1))
|
||||
|
|
@ -355,7 +354,7 @@
|
|||
(thread-start! t)
|
||||
(mutex-unlock! m c))))
|
||||
|
||||
(with-test-prefix "condition-variable-broadcast!"
|
||||
(with-test-prefix "condition-variable-broadcast!"
|
||||
|
||||
(pass-if "condition-variable-broadcast! wakes up multiple threads"
|
||||
(let* ((sem 0)
|
||||
|
|
@ -393,13 +392,13 @@
|
|||
(dec-sem!)
|
||||
(dec-sem!))))
|
||||
|
||||
(with-test-prefix "time?"
|
||||
(with-test-prefix "time?"
|
||||
|
||||
(pass-if "current-time is time" (time? (current-time)))
|
||||
(pass-if "number is not time" (not (time? 123)))
|
||||
(pass-if "symbol not time" (not (time? 'foo))))
|
||||
|
||||
(with-test-prefix "time->seconds"
|
||||
(with-test-prefix "time->seconds"
|
||||
|
||||
(pass-if "time->seconds makes time into rational"
|
||||
(rational? (time->seconds (current-time))))
|
||||
|
|
@ -408,7 +407,7 @@
|
|||
(let ((t (current-time)))
|
||||
(equal? t (seconds->time (time->seconds t))))))
|
||||
|
||||
(with-test-prefix "seconds->time"
|
||||
(with-test-prefix "seconds->time"
|
||||
|
||||
(pass-if "seconds->time makes rational into time"
|
||||
(time? (seconds->time 123.456)))
|
||||
|
|
@ -417,7 +416,7 @@
|
|||
(let ((t (time->seconds (current-time))))
|
||||
(equal? t (time->seconds (seconds->time t))))))
|
||||
|
||||
(with-test-prefix "current-exception-handler"
|
||||
(with-test-prefix "current-exception-handler"
|
||||
|
||||
(pass-if "current handler returned at top level"
|
||||
(procedure? (current-exception-handler)))
|
||||
|
|
@ -456,7 +455,7 @@
|
|||
(mutex-unlock! m)
|
||||
(thread-join! t)))))
|
||||
|
||||
(with-test-prefix "uncaught-exception-reason"
|
||||
(with-test-prefix "uncaught-exception-reason"
|
||||
|
||||
(pass-if "initial handler captures top level exception"
|
||||
(let ((t (make-thread (lambda () (raise 'foo))))
|
||||
|
|
@ -480,6 +479,4 @@
|
|||
(eq? (uncaught-exception-reason obj) 'foo)
|
||||
(set! success #t)))
|
||||
(lambda () (thread-join! t)))
|
||||
success)))
|
||||
|
||||
)
|
||||
success)))))
|
||||
|
|
@ -515,3 +515,28 @@
|
|||
(pass-if-exception "generalized-vector-set!, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-set! (c64vector 1.0) 1 2.0)))
|
||||
|
||||
(with-test-prefix "accessing uniform vectors of different types"
|
||||
|
||||
(pass-if "u32vector-length of u16vector"
|
||||
(= 2 (u32vector-length (make-u16vector 4))))
|
||||
|
||||
(pass-if "u32vector-length of u8vector"
|
||||
(= 2 (u32vector-length (make-u8vector 8))))
|
||||
|
||||
(pass-if "u8vector-length of u16vector"
|
||||
(= 4 (u8vector-length (make-u16vector 2))))
|
||||
|
||||
(pass-if "u8vector-length of u32vector"
|
||||
(= 8 (u8vector-length (make-u32vector 2))))
|
||||
|
||||
(pass-if "u32vector-set! of u16vector"
|
||||
(let ((v (make-u16vector 4 #xFFFF)))
|
||||
(u32vector-set! v 1 0)
|
||||
(equal? v #u16(#xFFFF #xFFFF 0 0))))
|
||||
|
||||
(pass-if "u16vector-set! of u32vector"
|
||||
(let ((v (make-u32vector 2 #xFFFFFFFF)))
|
||||
(u16vector-set! v 2 0)
|
||||
(u16vector-set! v 3 0)
|
||||
(equal? v #u32(#xFFFFFFFF 0)))))
|
||||
|
|
|
|||
|
|
@ -1549,6 +1549,31 @@
|
|||
(lambda args args)))
|
||||
(const 1))
|
||||
|
||||
;; Handler lambda inlined
|
||||
(pass-if-peval
|
||||
(call-with-prompt tag
|
||||
(lambda () 1)
|
||||
(lambda (k x) x))
|
||||
(prompt (toplevel tag)
|
||||
(const 1)
|
||||
(lambda-case
|
||||
(((k x) #f #f #f () (_ _))
|
||||
(lexical x _)))))
|
||||
|
||||
;; Handler toplevel not inlined
|
||||
(pass-if-peval
|
||||
(call-with-prompt tag
|
||||
(lambda () 1)
|
||||
handler)
|
||||
(let (handler) (_) ((toplevel handler))
|
||||
(prompt (toplevel tag)
|
||||
(const 1)
|
||||
(lambda-case
|
||||
((() #f args #f () (_))
|
||||
(primcall @apply
|
||||
(lexical handler _)
|
||||
(lexical args _)))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; `while' without `break' or `continue' has no prompts and gets its
|
||||
;; condition folded. Unfortunately the outer `lp' does not yet get
|
||||
|
|
@ -1564,7 +1589,16 @@
|
|||
((() #f #f #f () ())
|
||||
(call (lexical loop _))))))
|
||||
(call (lexical loop _)))))))
|
||||
(call (lexical lp _)))))
|
||||
(call (lexical lp _))))
|
||||
|
||||
(pass-if-peval
|
||||
(lambda (a . rest)
|
||||
(apply (lambda (x y) (+ x y))
|
||||
a rest))
|
||||
(lambda _
|
||||
(lambda-case
|
||||
(((x y) #f #f #f () (_ _))
|
||||
_)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -2200,6 +2234,19 @@
|
|||
#:opts %opts-w-format
|
||||
#:to 'assembly)))))
|
||||
|
||||
(pass-if "non-literal format string with forward declaration"
|
||||
(let ((w (call-with-warnings
|
||||
(lambda ()
|
||||
(compile '(begin
|
||||
(define (foo)
|
||||
(format #t (_ "~A ~A!") "hello" "world"))
|
||||
(define _ bar))
|
||||
#:opts %opts-w-format
|
||||
#:to 'assembly)))))
|
||||
(and (= (length w) 1)
|
||||
(number? (string-contains (car w)
|
||||
"non-literal format string")))))
|
||||
|
||||
(pass-if "wrong format string"
|
||||
(let ((w (call-with-warnings
|
||||
(lambda ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue