[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-hackers] [PATCH] Add 'a shorthand for forall types
|
From: |
Peter Bex |
|
Subject: |
Re: [Chicken-hackers] [PATCH] Add 'a shorthand for forall types |
|
Date: |
Fri, 8 Jun 2018 20:46:43 +0200 |
|
User-agent: |
NeoMutt/20170113 (1.7.2) |
Hi all,
In the interest of moving forward with CHICKEN 5, I propose
that we postpone all the below changes to 5.1.
On Tue, May 29, 2018 at 01:18:02PM +0300, megane wrote:
> Hello,
>
> This adds support for declaring forall types in more compact manner.
>
> It supports syntax like ('a -> 'a) to declare the type
> (forall (a) (a -> a)).
>
> diff --git a/manual/Types b/manual/Types
> index 6d5de10..cab029d 100644
> --- a/manual/Types
> +++ b/manual/Types
> @@ -158,6 +158,12 @@ or {{:}} should follow the syntax given below:
>
> (*) Note: no type-variables are bound inside {{(not TYPE)}}.
>
> +You can use a shorthand {{'SYMBOL}} for introducing free variables in
> +{{forall}} types, examples:
> +
> + ('a -> 'a) is translated to (forall (a) (a -> a))
> + (forall (a) ('a -> a)) is translated to (forall (a) (a -> a))
> +
> Note that type-variables in {{forall}} types may be given "constraint"
> types, i.e.
>
> (: sort (forall (e (s (or (vector-of e) (list-of e))))
> diff --git a/scrutinizer.scm b/scrutinizer.scm
> index ece07ed..6d4a0c8 100644
> --- a/scrutinizer.scm
> +++ b/scrutinizer.scm
> @@ -1967,6 +1967,16 @@
> (second t))
> constraints))
> (validate (third t) rec)))))
> + ((and (eq? 'quote (car t))
> + (pair? (cdr t))
> + (symbol? (second t))
> + (null? (cddr t))
> + (second t))
> + =>
> + (lambda (v)
> + (unless (memq v typevars)
> + (set! typevars (cons v typevars)))
> + v))
> ((eq? 'or (car t))
> (and (list? t)
> (let ((ts (map validate (cdr t))))
> diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
> index 44c6c32..8a01094 100644
> --- a/tests/typematch-tests.scm
> +++ b/tests/typematch-tests.scm
> @@ -3,6 +3,7 @@
>
> (import chicken.blob chicken.condition chicken.memory chicken.locative)
>
> +(define something)
>
> (define (make-list n x)
> (list-tabulate n (lambda _ x)))
> @@ -394,3 +395,22 @@
> (compiler-typecase #x7fffffffffffffff
> (fixnum #f)
> (bignum #t)))
> +
> +(assert
> + (compiler-typecase 1
> + ('a #t)))
> +
> +(assert
> + (compiler-typecase (the (list fixnum string string) something)
> + ((list 'a 'a 'b) #f)
> + ((list 'a 'b 'b) #t)))
> +
> +(assert
> + (compiler-typecase (the (list fixnum string string) something)
> + ((forall (a) (list a 'a 'b)) #f)
> + ((forall (b) (list 'a 'b b)) #t)))
> +
> +(assert
> + (compiler-typecase (the (list string (list string fixnum)) something)
> + ((list 'a (forall (a) (list 'b a))) #f)
> + ((list 'b (forall (b) (list b 'a))) #t)))
> _______________________________________________
> Chicken-hackers mailing list
> address@hidden
> https://lists.nongnu.org/mailman/listinfo/chicken-hackers
On Tue, May 29, 2018 at 10:51:37AM +0300, megane wrote:
> Hi,
>
> There were cases in match-types which essentially duplicated what
> expand-type was doing. This is a simple refactoring to remove that
> duplication.
>
> diff --git a/scrutinizer.scm b/scrutinizer.scm
> index ece07ed..c89bd60 100644
> --- a/scrutinizer.scm
> +++ b/scrutinizer.scm
> @@ -138,6 +138,15 @@
> s64vector f32vector f64vector thread queue environment time
> continuation lock mmap condition hash-table tcp-listener))
>
> +(define-constant type-expansions
> + '((pair . (pair * *))
> + (list . (list-of *))
> + (vector . (vector-of *))
> + (boolean . (or true false))
> + (integer . (or fixnum bignum))
> + (number . (or fixnum float bignum ratnum cplxnum))
> + (procedure . (procedure (#!rest *) . *))))
> +
> (define-inline (struct-type? t)
> (and (pair? t) (eq? (car t) 'struct)))
>
> @@ -1042,18 +1051,8 @@
> ((eq? t2 'undefined) #f)
> ((eq? t1 'noreturn))
> ((eq? t2 'noreturn))
> - ((eq? t1 'boolean) (match1 '(or true false) t2))
> - ((eq? t2 'boolean) (match1 t1 '(or true false)))
> - ((eq? t1 'integer) (match1 '(or fixnum bignum) t2))
> - ((eq? t2 'integer) (match1 t1 '(or fixnum bignum)))
> - ((eq? t1 'number) (match1 '(or fixnum float bignum ratnum cplxnum)
> t2))
> - ((eq? t2 'number) (match1 t1 '(or fixnum float bignum ratnum
> cplxnum)))
> - ((eq? t1 'pair) (match1 '(pair * *) t2))
> - ((eq? t2 'pair) (match1 t1 '(pair * *)))
> - ((eq? t1 'list) (match1 '(list-of *) t2))
> - ((eq? t2 'list) (match1 t1 '(list-of *)))
> - ((eq? t1 'vector) (match1 '(vector-of *) t2))
> - ((eq? t2 'vector) (match1 t1 '(vector-of *)))
> + ((maybe-expand-type t1) => (cut match1 <> t2))
> + ((maybe-expand-type t2) => (cut match1 t1 <>))
> ((and (pair? t1) (eq? 'not (car t1)))
> (fluid-let ((all (not all)))
> (let* ((trail0 trail)
> @@ -1356,17 +1355,9 @@
> (dd "simplify: ~a -> ~a" t t2)
> t2)))
>
> -(define (expand-type t)
> - (case t
> - ((pair) '(pair * *))
> - ((list) '(list-of *))
> - ((vector) '(vector-of *))
> - ((boolean) '(or true false))
> - ((integer) '(or fixnum bignum))
> - ((number) '(or fixnum float bignum ratnum cplxnum))
> - ((procedure) '(procedure (#!rest *) . *))
> - (else t)))
> -
> +(define (maybe-expand-type t)
> + (and (symbol? t)
> + (alist-ref t type-expansions eq?)))
>
> ;;; Merging types
>
> @@ -1432,10 +1423,8 @@
> (define (refine t1 t2 te)
> (let loop ((t1 t1) (t2 t2))
> (cond
> - ((and (symbol? t1) (memq t1 '(pair list vector boolean integer number)))
> - (loop (expand-type t1) t2))
> - ((and (symbol? t2) (memq t2 '(pair list vector boolean integer number)))
> - (loop t1 (expand-type t2)))
> + ((maybe-expand-type t1) => (cut loop <> t2))
> + ((maybe-expand-type t2) => (cut loop t1 <>))
> ((and (pair? t1) (memq (car t1) '(forall refine)))
> (let ((t1* (loop (third t1) t2)))
> (and t1* (list (car t1) (second t1) t1*))))
> _______________________________________________
> Chicken-hackers mailing list
> address@hidden
> https://lists.nongnu.org/mailman/listinfo/chicken-hackers
On Tue, May 29, 2018 at 06:42:33PM +1200, Evan Hanson wrote:
> Hello fellow hackers,
>
> Here is a big, gnarly patch that finishes the work I started in Bergen,
> which was to change the way we handle library dependencies so that units
> can be loaded conditionally. This was inspired by Peter's changes to
> make import expressions lexically-scoped, so that you can write a
> program like the following and have it work like you'd expect:
>
> (if (some-condition)
> (let () (import (foo)) ...)
> (let () (import (bar)) ...))
>
> With Peter's changes, those imports will only affect the syntactic
> environments of their respective branches. However, when the libraries
> "foo" and "bar" are compiled in (for example when "-static" is used),
> they'll both be loaded unconditionally. This patch changes things so
> that those libraries will only be loaded when program execution reaches
> the corresponding import expression.
>
> I'm sorry about the size of the diff, but I needed to rework quite a bit
> of bookkeeping for this to work. I also took the opportunity to clean up
> some related bits of code and rip out some provisional things that were
> left over from my last round of library loading changes. The commit
> message is exhaustive, and probably exhausting too.
>
> Note that I've taken care to preserve the current behaviour of the
> "-uses" flag and "(uses ...)" declaration, which "hoist" the named units
> to the top level and call them at the start of the program. This makes
> the code slightly more complex than it would otherwise be, but I wanted
> to preserve the idea that declarations have unit-global effect. The
> correct way to link a program with a unit that may *or may not* be
> loaded during program execution is to use the "-link" flag.
>
> Another complicating factor was static libraries containing modules that
> export syntax, which contain those now-infamous "(eval '(import-syntax
> ...))" forms. Previously, such `eval' expressions would never cause an
> [unsuccessful] attempt to load a dynamic library into a static program
> because the imported module's implementing library would have already
> been loaded (at the start of the program, thanks to the aforementioned
> unit hoisting), indicating that the module is already provided. Now,
> however, that library's top level is only entered when the "culpable"
> import expression is reached, but the `eval' form will always precede
> that point in the program. Luckily, the compiler knows exactly what
> libraries need to be loaded before the `eval' expression to avoid this
> situation, because it can consult the module's import forms. So, we now
> inject the necessary library entrypoints into the program just before
> the `eval' (this is the `compiled-module-dependencies' bit of the patch
> that does this, in modules.scm). This is only done when necessary, i.e.
> for statically compiled modules that export syntax.
>
> I've tested this pretty extensively, but I also know that it's nasty in
> terms of sheer size (15 files changed, 266 insertions, 309 deletions),
> so please just let me know if you have any questions and I'll do my best
> to help clarify what's going on.
>
> Cheers,
>
> Evan
> >From 7a4622bfcf1c727c05b6a6bf5cbfb754914d289b Mon Sep 17 00:00:00 2001
> From: Evan Hanson <address@hidden>
> Date: Tue, 29 May 2018 18:33:00 +1200
> Subject: [PATCH] Rework library loading to support conditional unit entry
>
> This makes a handful of changes to the way library dependencies are
> processed in order to support conditional unit loading, i.e. not calling
> a unit's entry procedure unless its code path is really visited:
>
> Drop the `file-requirements' hash table in favour of two "lset" globals,
> `library-requirements' and `unit-requirements', the first of which is a
> superset of the second. The `unit-requirements' list includes everything
> that needs to be linked with the program statically (i.e. as a unit),
> and everything else is a runtime dependency (i.e. loaded as a shared
> object or source file). Remove the "M" debug option.
>
> Introduce a new `uses-declarations' global to keep track of units that
> are specified with "-uses" or `(declare (uses))'. These are hoisted to
> the top level and called at the start of the program. Construct the list
> of `used-units', which is used to generate prototypes for external unit
> toplevels in the C backend, by simply remembering all `##core#callunit'
> nodes as they're encounted during canonicalisation.
>
> Split the batch driver's `initforms' list into two separate values, one
> for import forms (which must be included within the program's wrapper
> module's body, if one is used) and one for compiler-introduced
> initialisation forms (which must precede the profiling-related
> expressions that are inserted into the program when profiling is
> enabled, since they're responsible for loading the "profiler" unit).
> Move all "forms" bindings together in the `let' that introduces them.
>
> Simplify `##sys#process-require' so that it expects just a library name
> and compilation flag as arguments, and returns just a single value. Get
> rid of the `provided' list, which is no longer necessary.
>
> For modules that export syntax in static libraries (where module
> information is compiled into the libraries themselves), emit code that
> will load the module's library dependencies *before* the code for
> runtime evaluation of the module's import forms, that is, "(scheme#eval
> '(import-syntax ...))". This ensures that static programs do not attempt
> to dynamically load the named import libraries dynamically, since
> dlopen(3) et al. are specifically disabled by static compilation. We
> communicate this situation to `##sys#compiled-module-registration' with
> a compile mode flag, for consistency with `##sys#process-require'.
>
> Only include a library name in emitted import libraries when the program
> under compilation is actually a library. When it's an executable, it
> can't be loaded anyway, so including a library name in the import
> library isn't useful and only complicates the handling of later import
> forms.
>
> Do away with requirement identifiers for modules, which were always a
> hack. They muddy the runtime's require/provide mechanics, and they were
> only added to support the corner case where an import library is emitted
> for a dynamic library that is only accessible under a different name. We
> can do without this, given the above changes. A different approach to
> this problem may be developed under ticket #1463.
>
> Avoid inserting unnecessary `##core#callunit' forms into the program
> prelude by using `import-syntax' for all implicitly-available imports
> (rather than the standard `import' form, which will generate a
> corresponding `##core#require').
>
> Remove "files" from the list of core units in eval.scm, since it no
> longer exists. Add "profiler", "scheduler", and "debugger-client", which
> do exist and should be considered core units.
>
> Change the meaning of the "-link" option so that it indicates libraries
> that should be linked iff they're required, rather than always
> generating a call to their entrypoints (thus requiring them to be linked
> unconditionally, as is the case with "-uses"). This option now also
> needs to be plumbed through to the "chicken" program, which handles the
> differentiation between static and (potentially) dynamic requirements.
>
> There is also some only-very-slightly-related refactoring in this patch:
>
> Simplify some of the internal procedures in eval.scm. The
> `load-library/internal' and `##sys#load-library' procedures can be
> combined, as can `load-extension/internal' and `load-extension'. Rename
> the internal version of the `load-library' procedure to `load-unit',
> since that's really what it does, and use it in the expansion of
> `##core#require'.
>
> Refactor the `##core#module' canonicalisation code for better
> readability. It was previously unclear what values really needed to be
> parameterised over what, which these changes hope to clarify.
>
> Reconstruct import forms using the literal import prefix symbols in
> `##sys#decompose-import', to make clear that they are indeed stored on
> their modules sans aliasing in `module-import-forms' et al.
>
> Fix a latent bug in `##sys#decompose-import' where "spec" (a list) was
> used to issue a warning rather than "name" (a symbol). This led to an
> invalid argument error arising from `symbol->string'.
>
> Reindent two cond arrows that were aligned too far to the right in
> `##sys#decompose-import'.
>
> Drop the `stripu' alias from `process-declaration' and simply call
> `strip-syntax' directly instead. `stripu' was only used in two places.
>
> Mark `##sys#register-profile-info` and `##sys#set-profile-info-vector!'
> as always `bound-to-procedure' in the declarations that are inserted
> into profiled programs.
> ---
> batch-driver.scm | 144 ++++++++++++++-------------
> c-platform.scm | 8 +-
> chicken-syntax.scm | 2 +-
> core.scm | 214
> ++++++++++++++++-------------------------
> csc.scm | 2 +-
> eval.scm | 140 ++++++++++++---------------
> expand.scm | 2 +-
> modules.scm | 40 +++++---
> support.scm | 1 -
> tests/compiler-tests.scm | 7 ++
> tests/import-library-test2.scm | 2 -
> tests/runtests.bat | 2 +-
> tests/runtests.sh | 4 +-
> tests/scrutiny.expected | 4 +-
> tests/test-chained-modules.scm | 3 +-
> 15 files changed, 266 insertions(+), 309 deletions(-)
>
> diff --git a/batch-driver.scm b/batch-driver.scm
> index fc7afb04..0b84a1b5 100644
> --- a/batch-driver.scm
> +++ b/batch-driver.scm
> @@ -186,29 +186,31 @@
> (when (memq 'static options)
> (set! static-extensions #t)
> (register-feature! 'chicken-compile-static))
> - (let* ((dynamic (memq 'dynamic options))
> - (unit (memq 'unit options))
> - (initforms `((import-for-syntax ,@default-syntax-imports)
> - (##core#declare
> - ,@(append
> - default-declarations
> - (if emit-debug-info
> - '((uses debugger-client))
> - '())
> - (if explicit-use-flag
> - '()
> - `((uses ,@default-units)))
> - (if (and static-extensions
> - enable-module-registration
> - (not dynamic)
> - (not unit)
> - (not explicit-use-flag))
> - '((uses eval-modules))
> - '())))
> - ,@(if explicit-use-flag
> - '()
> - `((import ,@default-imports)))))
> - (verbose (memq 'verbose options))
> + (let* ((unit (memq 'unit options))
> + (dynamic (memq 'dynamic options))
> + (forms '())
> + (init-forms `((import-for-syntax ,@default-syntax-imports)
> + (##core#declare
> + ,@(append
> + default-declarations
> + (if emit-debug-info
> + '((uses debugger-client))
> + '())
> + (if explicit-use-flag
> + '()
> + `((uses ,@default-units)))
> + (if (and static-extensions
> + enable-module-registration
> + (not dynamic)
> + (not unit)
> + (not explicit-use-flag))
> + '((uses eval-modules))
> + '())))))
> + (import-forms `((import-for-syntax ,@default-syntax-imports)
> + ,@(if explicit-use-flag
> + '()
> + `((import-syntax ,@default-imports)))))
> + (cleanup-forms '(((chicken.base#implicit-exit-handler))))
> (outfile (cond ((memq 'output-file options)
> => (lambda (node)
> (let ((oname (option-arg node)))
> @@ -224,10 +226,8 @@
> (opasses (default-optimization-passes))
> (time0 #f)
> (time-breakdown #f)
> - (forms '())
> (inline-output-file #f)
> (type-output-file #f)
> - (cleanup-forms '(((chicken.base#implicit-exit-handler))))
> (profile (or (memq 'profile options)
> (memq 'accumulate-profile options)
> (memq 'profile-name options)))
> @@ -345,8 +345,9 @@
> (when (memq 'b debugging-chicken) (set! time-breakdown #t))
> (when (memq 'raw options)
> (set! explicit-use-flag #t)
> - (set! cleanup-forms '())
> - (set! initforms '()) )
> + (set! init-forms '())
> + (set! import-forms '())
> + (set! cleanup-forms '()))
> (when (memq 'no-lambda-info options)
> (set! emit-closure-info #f) )
> (when (memq 'no-compiler-syntax options)
> @@ -356,7 +357,8 @@
> (when (memq 'inline-global options)
> (set! enable-inline-files #t)
> (set! inline-locally #t))
> - (when verbose
> + (when (memq 'verbose options)
> + (set! verbose-mode #t)
> (set! ##sys#notices-enabled #t))
> (when (memq 'strict-types options)
> (set! strict-variable-types #t)
> @@ -413,7 +415,6 @@
> (keyword-style #:none)
> (parentheses-synonyms #f)
> (symbol-escape #f) )
> - (set! verbose-mode verbose)
> (set! ##sys#read-error-with-line-number #t)
> (set! ##sys#include-pathnames
> (append (map chop-separator (collect-options 'include-path))
> @@ -466,18 +467,23 @@
> (set! ##sys#features (cons '#:compiling ##sys#features))
> (set! upap (user-post-analysis-pass))
>
> + ;; Mark linked extensions as static requirements.
> + (let ((units (append-map
> + (lambda (l) (map string->symbol (string-split l ", ")))
> + (collect-options 'link))))
> + (set! unit-requirements (lset-union/eq? unit-requirements units)))
> +
> ;; Handle units added with the "-uses" flag.
> - (let ((uses (append-map
> - (lambda (u) (map string->symbol (string-split u ", ")))
> - (collect-options 'uses))))
> - (unless (null? uses)
> - (set! forms
> - (cons `(##core#declare (uses . ,uses)) forms))))
> + (let ((units (append-map
> + (lambda (u) (map string->symbol (string-split u ", ")))
> + (collect-options 'uses))))
> + (set! init-forms
> + (append init-forms `((##core#declare (uses . ,units))))))
>
> ;; Append required extensions to initforms:
> - (set! initforms
> + (set! import-forms
> (append
> - initforms
> + import-forms
> (map (lambda (r) `(import ,(string->symbol r)))
> (collect-options 'require-extension))))
>
> @@ -509,9 +515,9 @@
> "you need to specify -profile-name if using accumulated profiling
> runs"))
> (set! emit-profile #t)
> (set! profiled-procedures 'all)
> - (set! initforms
> + (set! init-forms
> (append
> - initforms
> + init-forms
> default-profiling-declarations
> (if acc
> '((set! ##sys#profile-append-mode #t))
> @@ -584,18 +590,22 @@
> (print-expr "source" '|1| forms)
> (begin-time)
> ;; Canonicalize s-expressions
> - (let* ((exps0 (map (lambda (x)
> + (let* ((init0 (map canonicalize-expression init-forms))
> + (exps0 (map (lambda (x)
> (fluid-let ((##sys#current-source-filename
> filename))
> (canonicalize-expression x)))
> - (let ((forms (append initforms forms)))
> + (let ((forms (append import-forms forms)))
> (if (not module-name)
> forms
> - `((##core#module
> - ,(string->symbol module-name) ()
> + `((##core#module ,(string->symbol
> module-name) ()
> ,@forms))))))
> + (uses0 (map (lambda (u)
> + (canonicalize-expression `(##core#require ,u)))
> + (##sys#fast-reverse uses-declarations)))
> (exps (append
> (map (lambda (ic) `(set! ,(cdr ic) ',(car ic)))
> immutable-constants)
> - (map (lambda (uu) `(##core#callunit ,uu)) used-units)
> + init0
> + uses0
> (if unit-name `((##core#provide ,unit-name)) '())
> (if emit-profile
> (profiling-prelude-exps (and (not unit-name)
> @@ -614,18 +624,6 @@
> (map (lambda (il) (->string (car il)))
> import-libraries) ", ")))
>
> - (and-let* ((reqs (hash-table-ref file-requirements 'dynamic))
> - (missing (remove (cut
> chicken.load#find-dynamic-extension <> #f) reqs)))
> - (when (null? (lset-intersection/eq? '(eval repl) used-units))
> - (notice ; XXX only issued when "-verbose" is used
> - (sprintf "~A has dynamic requirements but doesn't load
> (chicken eval): ~A"
> - (cond (unit-name "unit") (dynamic "library") (else
> "program"))
> - (string-intersperse (map ->string reqs) ", "))))
> - (when (pair? missing)
> - (warning
> - (sprintf "the following extensions are not currently
> installed: ~A"
> - (string-intersperse (map ->string missing) ", ")))))
> -
> (when (pair? compiler-syntax-statistics)
> (with-debugging-output
> 'S
> @@ -664,10 +662,17 @@
> (initialize-analysis-database)
>
> ;; collect requirements and load inline files
> - (let* ((req (concatenate (vector->list file-requirements)))
> - (mreq (concatenate (map cdr req))))
> - (when (debugging 'M "; requirements:")
> - (pp req))
> + (let* ((required-extensions
> + (remove chicken.load#core-unit? library-requirements))
> + (missing-extensions
> + (remove (lambda (id)
> + (or (chicken.load#find-static-extension id)
> + (chicken.load#find-dynamic-extension id
> #f)))
> + required-extensions)))
> + (when (pair? missing-extensions)
> + (warning
> + (sprintf "the following extensions are not currently
> installed: ~A"
> + (string-intersperse (map ->string
> missing-extensions) ", "))))
> (when enable-inline-files
> (for-each
> (lambda (id)
> @@ -675,7 +680,7 @@
> (symbol->string id) '(".inline") #t
> #f)))
> (dribble "Loading inline file ~a ..." ifile)
> (load-inline-file ifile)))
> - mreq))
> + required-extensions))
> (let ((ifs (collect-options 'consult-inline-file)))
> (unless (null? ifs)
> (set! inline-locally #t)
> @@ -702,7 +707,7 @@
> (load-type-database
> (make-pathname #f (symbol->string id) "types")
> enable-specialization))
> - mreq)
> + required-extensions)
> (begin-time)
> (set! first-analysis #f)
> (set! db (analyze 'scrutiny node0))
> @@ -831,12 +836,15 @@
> (begin-time)
>
> ;; generate link file
> - (when emit-link-file
> - (dribble "generating link file `~a' ..."
> emit-link-file)
> - (with-output-to-file
> - emit-link-file
> - (cut pp linked-static-extensions)))
> -
> + (when emit-link-file
> + (let ((objs (filter-map
> + (lambda (id)
> + (and-let* ((o
> (chicken.load#find-static-extension id)))
> + (pathname-strip-directory o)))
> + (remove chicken.load#core-unit?
> library-requirements))))
> + (dribble "generating link file `~a' ..."
> emit-link-file)
> + (with-output-to-file emit-link-file (cut pp
> objs))))
> +
> ;; Code generation
> (let ((out (if outfile (open-output-file outfile)
> (current-output-port))) )
> (dribble "generating `~A' ..." outfile)
> diff --git a/c-platform.scm b/c-platform.scm
> index 35a327cc..99cdae1e 100644
> --- a/c-platform.scm
> +++ b/c-platform.scm
> @@ -72,8 +72,10 @@
> (define default-profiling-declarations
> '((##core#declare
> (uses profiler)
> - (bound-to-procedure
> - ##sys#profile-entry ##sys#profile-exit) ) ) )
> + (bound-to-procedure ##sys#profile-entry
> + ##sys#profile-exit
> + ##sys#register-profile-info
> + ##sys#set-profile-info-vector!))))
>
> (define default-units '(library eval))
>
> @@ -105,7 +107,7 @@
> setup-mode no-module-registration) )
>
> (define valid-compiler-options-with-argument
> - '(debug emit-link-file
> + '(debug link emit-link-file
> output-file include-path heap-size stack-size unit uses module
> keyword-style require-extension inline-limit profile-name
> prelude postlude prologue epilogue nursery extend feature no-feature
> diff --git a/chicken-syntax.scm b/chicken-syntax.scm
> index 2451075e..3801ba20 100644
> --- a/chicken-syntax.scm
> +++ b/chicken-syntax.scm
> @@ -541,7 +541,7 @@
> (let-values (((name lib _ _ _ _) (##sys#decompose-import x r c
> 'import)))
> (if (not lib)
> '(##core#undefined)
> - `(##core#require ,lib ,(module-requirement name)))))
> + `(##core#require ,lib))))
> (cdr x))))))
>
> (##sys#extend-macro-environment
> diff --git a/core.scm b/core.scm
> index f0c88f76..c29f3699 100644
> --- a/core.scm
> +++ b/core.scm
> @@ -138,8 +138,8 @@
> ; (##core#foreign-callback-wrapper '<name> <qualifiers> '<type> '({<type>})
> <exp>)
> ; (##core#define-external-variable <name> <type> <bool> [<symbol>])
> ; (##core#check <exp>)
> -; (##core#require-for-syntax <id> ...)
> -; (##core#require <id> <id> ...)
> +; (##core#require-for-syntax <id>)
> +; (##core#require <id>)
> ; (##core#app <exp> {<exp>})
> ; (##core#define-syntax <symbol> <expr>)
> ; (##core#define-compiler-syntax <symbol> <expr>)
> @@ -276,10 +276,6 @@
> initialize-compiler perform-closure-conversion perform-cps-conversion
> prepare-for-code-generation build-toplevel-procedure
>
> - ;; These are both exported for use in eval.scm (which is a bit of
> - ;; a hack). file-requirements is also used by batch-driver
> - process-declaration file-requirements
> -
> ;; Various ugly global boolean flags that get set by the (batch) driver
> all-import-libraries bootstrap-mode compiler-syntax-enabled
> emit-closure-info emit-profile enable-inline-files explicit-use-flag
> @@ -293,14 +289,16 @@
> disable-stack-overflow-checking emit-trace-info external-protos-first
> external-variables insert-timer-checks no-argc-checks
> no-global-procedure-checks no-procedure-checks emit-debug-info
> - linked-static-extensions
>
> ;; Other, non-boolean, flags set by (batch) driver
> profiled-procedures import-libraries inline-max-size
> extended-bindings standard-bindings
>
> + ;; Non-booleans set and read by the (batch) driver
> + library-requirements unit-requirements uses-declarations
> +
> ;; non-booleans set by the (batch) driver, and read by the (c) backend
> - target-heap-size target-stack-size unit-name used-units provided
> + target-heap-size target-stack-size unit-name used-units
>
> ;; bindings, set by the (c) platform
> default-extended-bindings default-standard-bindings internal-bindings
> @@ -360,7 +358,6 @@
> (define-constant default-line-number-database-size 997)
> (define-constant inline-table-size 301)
> (define-constant constant-table-size 301)
> -(define-constant file-requirements-size 301)
> (define-constant default-inline-max-size 20)
>
>
> @@ -429,9 +426,9 @@
> (define callback-names '())
> (define toplevel-scope #t)
> (define toplevel-lambda-id #f)
> -(define file-requirements #f)
> -(define provided '())
> -(define linked-static-extensions '())
> +(define library-requirements '())
> +(define unit-requirements '())
> +(define uses-declarations '())
>
> (define unlikely-variables '(unquote unquote-splicing))
>
> @@ -454,9 +451,6 @@
> (set! constant-table (make-vector constant-table-size '())) )
> (reset-profile-info-vector-name!)
> (clear-real-name-table!)
> - (if file-requirements
> - (vector-fill! file-requirements '())
> - (set! file-requirements (make-vector file-requirements-size '())) )
> (clear-foreign-type-table!) )
>
>
> @@ -584,11 +578,11 @@
> ((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
> (else x))))
>
> - (define (emit-import-lib name il)
> + (define (emit-import-lib mod name il)
> (let* ((fname (if all-import-libraries
> (string-append (symbol->string name) ".import.scm")
> (cdr il)))
> - (imps (##sys#compiled-module-registration (##sys#current-module)))
> + (imps (##sys#compiled-module-registration mod #f))
> (oldimps
> (and (file-exists? fname)
> (call-with-input-file fname read-expressions))))
> @@ -682,12 +676,7 @@
> (hide-variable var)
> var) ] ) ) )
>
> - ((##core#callunit ##core#primitive ##core#undefined) x)
> -
> - ((##core#provide)
> - (let ((id (cadr x)))
> - (set! provided (lset-adjoin/eq? provided id))
> - `(##core#provide ,id)))
> + ((##core#provide ##core#primitive ##core#undefined) x)
>
> ((##core#inline_ref)
> `(##core#inline_ref
> @@ -699,24 +688,23 @@
> ,(walk (caddr x) e dest ldest h ln #f)))
>
> ((##core#require-for-syntax)
> - (chicken.load#load-extension (cadr x) '() 'require)
> + (chicken.load#load-extension (cadr x) 'require)
> '(##core#undefined))
>
> + ((##core#callunit)
> + (let ((id (cadr x)))
> + (set! used-units (lset-adjoin/eq? used-units id))
> + `(##core#callunit ,id)))
> +
> ((##core#require)
> - (let ((id (cadr x))
> - (alternates (cddr x)))
> - (let-values (((exp type)
> - (##sys#process-require
> - id #t
> - alternates provided
> - static-extensions
> - register-static-extension)))
> - (unless (not type)
> - (hash-table-update!
> - file-requirements type
> - (cut lset-adjoin/eq? <> id)
> - (cut list id)))
> - (walk exp e dest ldest h ln #f))))
> + (let ((id (cadr x)))
> + (set! library-requirements (lset-adjoin/eq?
> library-requirements id))
> + (walk (##sys#process-require
> + id
> + (if (or (memq id unit-requirements)
> static-extensions)
> + 'static
> + 'dynamic))
> + e dest ldest h ln #f)))
>
> ((##core#let)
> (let* ((bindings (cadr x))
> @@ -964,90 +952,72 @@
>
> ((##core#module)
> (let* ((name (strip-syntax (cadr x)))
> - (lib (or unit-name name))
> - (req (module-requirement name))
> - (exports
> - (or (eq? #t (caddr x))
> - (map (lambda (exp)
> - (cond ((symbol? exp) exp)
> - ((and (pair? exp)
> - (let loop ((exp exp))
> - (or (null? exp)
> - (and (symbol? (car
> exp))
> - (loop (cdr
> exp))))))
> - exp)
> - (else
> - (##sys#syntax-error-hook
> - 'module
> - "invalid export syntax" exp
> name))))
> - (strip-syntax (caddr x)))))
> + (il (or (assq name import-libraries)
> all-import-libraries))
> + (lib (and (not standalone-executable) il (or
> unit-name name)))
> + (mod (##sys#register-module
> + name lib
> + (or (eq? #t (caddr x))
> + (map (lambda (exp)
> + (cond ((symbol? exp) exp)
> + ((and (pair? exp)
> + (let loop ((exp
> exp))
> + (or (null? exp)
> + (and (symbol?
> (car exp))
> + (loop
> (cdr exp))))))
> + exp)
> + (else
> + (##sys#syntax-error-hook
> + 'module
> + "invalid export syntax"
> exp name))))
> + (strip-syntax (caddr x))))))
> (csyntax compiler-syntax))
> (when (##sys#current-module)
> (##sys#syntax-error-hook
> 'module "modules may not be nested" name))
> - (let-values (((body module-registration)
> - (parameterize ((##sys#current-module
> - (##sys#register-module
> name lib exports))
> -
> (##sys#current-environment '())
> - (##sys#macro-environment
> -
> ##sys#initial-macro-environment)
> -
> (##sys#module-alias-environment
> -
> (##sys#module-alias-environment)))
> - (##sys#with-property-restore
> - (lambda ()
> - (let loop ((body (cdddr x)) (xs
> '()))
> - (cond
> - ((null? body)
> + (let ((body (parameterize ((##sys#current-module mod)
> + (##sys#current-environment
> '())
> + (##sys#macro-environment
> +
> ##sys#initial-macro-environment)
> +
> (##sys#module-alias-environment
> +
> (##sys#module-alias-environment)))
> + (##sys#with-property-restore
> + (lambda ()
> + (let loop ((body (cdddr x)) (xs '()))
> + (if (null? body)
> (handle-exceptions ex
> (begin
> ;; avoid backtrace
> (print-error-message ex
> (current-error-port))
> (exit 1))
> - (##sys#finalize-module
> (##sys#current-module)))
> - (cond ((or (assq name
> import-libraries) all-import-libraries)
> - => (lambda (il)
> - (emit-import-lib
> name il)
> - ;; Remove from
> list to avoid error
> - (when (pair? il)
> - (set!
> import-libraries
> - (delete il
> import-libraries equal?)))
> - (values (reverse
> xs) '())))
> - ((not
> enable-module-registration)
> - (values (reverse xs)
> '()))
> - (else
> - (values
> - (reverse xs)
> -
> (##sys#compiled-module-registration
> -
> (##sys#current-module))))))
> - (else
> + (##sys#finalize-module mod)
> + (reverse xs))
> (loop
> (cdr body)
> - (cons (walk
> - (car body)
> - e ;?
> - #f #f h ln #t) ; reset
> to toplevel!
> - xs))))))))))
> - (let ((body
> - (canonicalize-begin-body
> - (append
> - (parameterize ((##sys#current-module #f)
> - (##sys#macro-environment
> -
> (##sys#meta-macro-environment))
> - (##sys#current-environment
> ; ???
> -
> (##sys#current-meta-environment)))
> - (map
> - (lambda (x)
> - (walk
> - x
> - e ;?
> - #f #f h ln tl?) )
> - (cons `(##core#provide ,req)
> module-registration)))
> - body))))
> - (do ((cs compiler-syntax (cdr cs)))
> - ((eq? cs csyntax))
> - (##sys#put! (caar cs)
> '##compiler#compiler-syntax (cdar cs)))
> - (set! compiler-syntax csyntax)
> - body))))
> + (cons (walk (car body)
> + e #f #f
> + h ln #t) ; reset
> to toplevel!
> + xs)))))))))
> + (do ((cs compiler-syntax (cdr cs)))
> + ((eq? cs csyntax) (set! compiler-syntax
> csyntax))
> + (##sys#put! (caar cs) '##compiler#compiler-syntax
> (cdar cs)))
> + (when il
> + (emit-import-lib mod name il)
> + (when (pair? il)
> + (set! import-libraries
> + (delete il import-libraries equal?))))
> + (canonicalize-begin-body
> + (append
> + (if (or (not enable-module-registration) il)
> + '()
> + (parameterize ((##sys#macro-environment
> +
> (##sys#meta-macro-environment))
> + (##sys#current-environment ;
> ???
> +
> (##sys#current-meta-environment)))
> + (map (lambda (x) (walk x e #f #f h ln tl?))
> + (##sys#compiled-module-registration
> + mod
> + (if static-extensions 'static
> 'dynamic)))))
> + body)))))
>
> ((##core#loop-lambda) ;XXX is this really needed?
> (let* ((vars (cadr x))
> @@ -1502,7 +1472,6 @@
> (syntax-error "invalid declaration" spec) ) ) )
> (define (stripa x) ; global aliasing
> (##sys#globalize x se))
> - (define stripu strip-syntax)
> (define (globalize-all syms)
> (filter-map
> (lambda (var)
> @@ -1520,17 +1489,12 @@
> (syntax-error "invalid declaration specification" spec) )
> (case (strip-syntax (car spec)) ; no global aliasing
> ((uses)
> - (let ((us (lset-difference/eq? (stripu (cdr spec)) used-units)))
> - (when (pair? us)
> - (set! provided (append provided us))
> - (set! used-units (append used-units us))
> - (hash-table-update!
> - file-requirements 'static
> - (cut lset-union/eq? us <>)
> - (lambda () us)))))
> + (let ((units (strip-syntax (cdr spec))))
> + (set! unit-requirements (lset-union/eq? unit-requirements units))
> + (set! uses-declarations (lset-union/eq? uses-declarations units))))
> ((unit)
> (check-decl spec 1 1)
> - (let ((u (stripu (cadr spec))))
> + (let ((u (strip-syntax (cadr spec))))
> (when (and unit-name (not (eq? unit-name u)))
> (warning "unit was already given a name (new name is ignored)"))
> (set! unit-name u)
> @@ -1764,14 +1728,6 @@
> '(##core#undefined) ) ) )
>
>
> -;;; Register statically linked extension
> -
> -(define (register-static-extension id path)
> - (set! linked-static-extensions
> - (cons (pathname-strip-directory path)
> - linked-static-extensions)))
> -
> -
> ;;; Create entry procedure:
>
> (define (build-toplevel-procedure node)
> diff --git a/csc.scm b/csc.scm
> index c9d7c969..be5fe6bc 100644
> --- a/csc.scm
> +++ b/csc.scm
> @@ -643,7 +643,7 @@ EOF
> (set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]
> [(-link)
> (check s rest)
> - (t-options "-uses" (car rest))
> + (t-options "-link" (car rest))
> (set! linked-extensions
> (append linked-extensions (string-split (car rest) ", ")))
> (set! rest (cdr rest))]
> diff --git a/eval.scm b/eval.scm
> index a615fa72..dc8043da 100644
> --- a/eval.scm
> +++ b/eval.scm
> @@ -563,7 +563,6 @@
> (if (null? body)
> (let ((xs (reverse xs)))
> (##sys#finalize-module
> (##sys#current-module))
> - (##sys#provide (module-requirement
> name))
> (lambda (v)
> (let loop2 ((xs xs))
> (if (null? xs)
> @@ -589,14 +588,11 @@
> (compile `(##sys#provide (##core#quote ,(cadr x))) e
> #f tf cntr #f)]
>
> [(##core#require-for-syntax)
> - (chicken.load#load-extension (cadr x) '() 'require)
> + (chicken.load#load-extension (cadr x) #f)
> (compile '(##core#undefined) e #f tf cntr #f)]
>
> [(##core#require)
> - (let ((id (cadr x))
> - (alternates (cddr x)))
> - (let-values (((exp _) (##sys#process-require id #f
> alternates)))
> - (compile exp e #f tf cntr #f)))]
> + (compile (##sys#process-require (cadr x) #f) e #f tf
> cntr #f)]
>
> [(##core#elaborationtimeonly
> ##core#elaborationtimetoo) ; <- Note this!
> (##sys#eval/meta (cadr x))
> @@ -910,9 +906,10 @@
> (##core#require library)))))
>
> (define-constant core-units
> - '(chicken-syntax chicken-ffi-syntax continuation data-structures eval
> - expand extras file files internal irregex library lolevel pathname
> - port posix srfi-4 tcp repl read-syntax))
> + '(chicken-syntax chicken-ffi-syntax continuation data-structures
> + debugger-client eval eval-modules expand extras file internal
> + irregex library lolevel pathname port posix profiler scheduler
> + srfi-4 tcp repl read-syntax))
>
> (define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
> (define-constant macosx-load-library-extension ".dylib")
> @@ -937,6 +934,10 @@
>
> (define ##sys#load-dynamic-extension default-load-library-extension)
>
> +(define (chicken.load#core-unit? id) ; used by batch-driver.scm
> + (or (memq id core-units)
> + (assq id core-unit-requirements)))
> +
> ; these are actually in unit extras, but that is used by default
>
> (define-constant builtin-features
> @@ -1125,36 +1126,31 @@
> (##sys#check-list x)
> x) ) ) )
>
> -(define load-library/internal
> - (let ((display display))
> - (lambda (uname lib loc)
> - (let ((libs
> - (if lib
> - (##sys#list lib)
> - (cons (##sys#string-append (##sys#slot uname 1)
> load-library-extension)
> - (dynamic-load-libraries))))
> - (top
> - (c-toplevel uname loc)))
> - (when (load-verbose)
> - (display "; loading library ")
> - (display uname)
> - (display " ...\n") )
> - (let loop ((libs libs))
> - (cond ((null? libs)
> - (##sys#error loc "unable to load library" uname _dlerror))
> - ((##sys#dload (##sys#make-c-string (##sys#slot libs 0)
> 'load-library) top))
> - (else
> - (loop (##sys#slot libs 1)))))))))
> -
> -(define (##sys#load-library uname #!optional lib loc)
> - (unless (##sys#provided? uname)
> - (load-library/internal uname lib loc)
> - (##core#undefined)))
> -
> -(define (load-library uname #!optional lib)
> - (##sys#check-symbol uname 'load-library)
> +(define (load-unit unit-name lib loc)
> + (unless (##sys#provided? unit-name)
> + (let ((libs
> + (if lib
> + (##sys#list lib)
> + (cons (##sys#string-append (##sys#slot unit-name 1)
> load-library-extension)
> + (dynamic-load-libraries))))
> + (top
> + (c-toplevel unit-name loc)))
> + (when (load-verbose)
> + (display "; loading library ")
> + (display unit-name)
> + (display " ...\n"))
> + (let loop ((libs libs))
> + (cond ((null? libs)
> + (##sys#error loc "unable to load library" unit-name (or _dlerror
> "library not found")))
> + ((##sys#dload (##sys#make-c-string (##sys#slot libs 0)
> 'load-library) top)
> + (##core#undefined))
> + (else
> + (loop (##sys#slot libs 1))))))))
> +
> +(define (load-library unit-name #!optional lib)
> + (##sys#check-symbol unit-name 'load-library)
> (unless (not lib) (##sys#check-string lib 'load-library))
> - (##sys#load-library uname lib 'load-library))
> + (load-unit unit-name lib 'load-library))
>
> (define ##sys#include-forms-from-file
> (let ((with-input-from-file with-input-from-file)
> @@ -1266,25 +1262,20 @@
> (or (check pa)
> (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
>
> -(define (load-extension/internal id alternates loc)
> - (cond ((##sys#provided? id))
> - ((any ##sys#provided? alternates))
> - ((memq id core-units)
> - (load-library/internal id #f loc))
> +(define (load-extension id loc)
> + (cond ((##sys#provided? id) (##core#undefined))
> + ((memq id core-units) (load-unit id #f loc))
> ((find-dynamic-extension id #f) =>
> (lambda (ext)
> (load/internal ext #f #f #f #f id)
> - (##sys#provide id)))
> + (##sys#provide id)
> + (##core#undefined)))
> (else
> (##sys#error loc "cannot load extension" id))))
>
> -(define (chicken.load#load-extension id alternates loc)
> - (load-extension/internal id alternates loc)
> - (##core#undefined))
> -
> (define (require . ids)
> (for-each (cut ##sys#check-symbol <> 'require) ids)
> - (for-each (cut chicken.load#load-extension <> '() 'require) ids))
> + (for-each (cut load-extension <> 'require) ids))
>
> (define (provide . ids)
> (for-each (cut ##sys#check-symbol <> 'provide) ids)
> @@ -1299,42 +1290,29 @@
> (find-file (##sys#string-append p object-file-extension)
> (repository-path))))
>
> -;; Export for internal use in csc, modules and batch-driver:
> -(define chicken.load#find-file find-file)
> -(define chicken.load#find-static-extension find-static-extension)
> -(define chicken.load#find-dynamic-extension find-dynamic-extension)
> -
> -;;
> -;; Given a library specification, returns three values:
> -;;
> -;; - an expression for loading the library, if required
> -;; - a requirement type (e.g. 'dynamic) or #f if provided in core
> -;;
> -(define (##sys#process-require lib #!optional compiling? (alternates '())
> (provided '()) static? mark-static)
> +;; Do the right thing with a `##core#require' form.
> +(define (##sys#process-require lib compile-mode)
> (let ((id (library-id lib)))
> (cond
> - ((assq id core-unit-requirements) =>
> - (lambda (x) (values (cdr x) #f)))
> - ((memq id builtin-features)
> - (values '(##core#undefined) #f))
> - ((memq id provided)
> - (values '(##core#undefined) #f))
> - ((any (cut memq <> provided) alternates)
> - (values '(##core#undefined) #f))
> + ((assq id core-unit-requirements) => cdr)
> + ((memq id builtin-features) '(##core#undefined))
> ((memq id core-units)
> - (if compiling?
> - (values `(##core#declare (uses ,id)) #f)
> - (values `(##sys#load-library (##core#quote ,id)) #f)))
> - ((and compiling? static? (find-static-extension id)) =>
> - (lambda (path)
> - (mark-static id path)
> - (values `(##core#declare (uses ,id)) 'static)))
> + (if compile-mode
> + `(##core#callunit ,id)
> + `(chicken.load#load-unit (##core#quote ,id) #f #f)))
> + ((eq? compile-mode 'static)
> + `(##core#callunit ,id))
> (else
> - (values `(chicken.load#load-extension
> - (##core#quote ,id)
> - (##core#quote ,alternates)
> - (##core#quote require))
> - 'dynamic)))))
> + `(chicken.load#load-extension (##core#quote ,id) #f)))))
> +
> +;; Export for internal use in the expansion of `##core#require':
> +(define chicken.load#load-unit load-unit)
> +(define chicken.load#load-extension load-extension)
> +
> +;; Export for internal use in csc, modules and batch-driver:
> +(define chicken.load#find-file find-file)
> +(define chicken.load#find-static-extension find-static-extension)
> +(define chicken.load#find-dynamic-extension find-dynamic-extension)
>
> ;;; Find included file:
>
> diff --git a/expand.scm b/expand.scm
> index b2f97d4b..6021efde 100644
> --- a/expand.scm
> +++ b/expand.scm
> @@ -976,7 +976,7 @@
> ##sys#current-environment ##sys#macro-environment #f #f
> 'import))
> (if (not lib)
> '(##core#undefined)
> - `(##core#require ,lib ,(module-requirement name)))))
> + `(##core#require ,lib))))
> (cdr x)))))))
>
> (##sys#extend-macro-environment
> diff --git a/modules.scm b/modules.scm
> index 73e89474..06c6e1dd 100644
> --- a/modules.scm
> +++ b/modules.scm
> @@ -33,9 +33,9 @@
> (disable-interrupts)
> (fixnum)
> (not inline ##sys#alias-global-hook)
> - (hide check-for-redef find-export find-module/import-library
> - match-functor-argument merge-se module-indirect-exports
> - module-rename register-undefined))
> + (hide check-for-redef compiled-module-dependencies find-export
> + find-module/import-library match-functor-argument merge-se
> + module-indirect-exports module-rename register-undefined))
>
> (import scheme
> chicken.base
> @@ -304,14 +304,24 @@
> ((assq (caar se) rest) (fwd (cdr se) rest))
> (else (cons (car se) (fwd (cdr se) rest)))))))))
>
> -(define (##sys#compiled-module-registration mod)
> +(define (compiled-module-dependencies mod)
> + (let ((libs (filter-map ; extract library names
> + (lambda (x) (nth-value 1 (##sys#decompose-import x o eq?
> 'module)))
> + (module-import-forms mod))))
> + (map (lambda (lib) `(##core#require ,lib))
> + (delete-duplicates libs eq?))))
> +
> +(define (##sys#compiled-module-registration mod compile-mode)
> (let ((dlist (module-defined-list mod))
> (mname (module-name mod))
> (ifs (module-import-forms mod))
> (sexports (module-sexports mod))
> (mifs (module-meta-import-forms mod)))
> - `(,@(if (and (pair? ifs) (pair? sexports))
> - `((scheme#eval '(import-syntax ,@(strip-syntax ifs))))
> + `(,@(if (and (eq? compile-mode 'static) (pair? ifs) (pair? sexports))
> + (compiled-module-dependencies mod)
> + '())
> + ,@(if (and (pair? ifs) (pair? sexports))
> + `((scheme#eval '(import-syntax ,@(strip-syntax ifs))))
> '())
> ,@(if (and (pair? mifs) (pair? sexports))
> `((import-syntax ,@(strip-syntax mifs)))
> @@ -614,9 +624,9 @@
> (cond ((null? ids)
> (for-each
> (lambda (id)
> - (warn "imported identifier doesn't
> exist" spec id))
> + (warn "imported identifier doesn't
> exist" name id))
> missing)
> - (values name lib `(,head ,spec ,@imports) v
> s impi))
> + (values name lib `(only ,spec ,@imports) v
> s impi))
> ((assq (car ids) impv) =>
> (lambda (a)
> (loop (cdr ids) (cons a v) s missing)))
> @@ -637,15 +647,15 @@
> (lambda (id)
> (warn "excluded identifier
> doesn't exist" name id))
> ids)
> - (values name lib `(,head ,spec
> ,@imports) v s impi))
> + (values name lib `(except ,spec
> ,@imports) v s impi))
> ((memq (caar imps) ids) =>
> - (lambda (id)
> - (loop
> (cdr imps) s (delete (car id) ids eq?))))
> + (lambda (id)
> + (loop (cdr imps) s (delete (car
> id) ids eq?))))
> (else
> (loop (cdr imps) (cons (car imps)
> s) ids)))))
> ((memq (caar impv) ids) =>
> - (lambda (id)
> - (loop (cdr impv) v
> (delete (car id) ids eq?))))
> + (lambda (id)
> + (loop (cdr impv) v (delete (car id) ids
> eq?))))
> (else
> (loop (cdr impv) (cons (car impv) v)
> ids))))))
> ((c %rename head)
> @@ -660,7 +670,7 @@
> (lambda (id)
> (warn "renamed identifier
> doesn't exist" name id))
> (map car ids))
> - (values name lib `(,head ,spec
> ,@renames) v s impi))
> + (values name lib `(rename ,spec
> ,@renames) v s impi))
> ((assq (caar imps) ids) =>
> (lambda (a)
> (loop (cdr imps)
> @@ -684,7 +694,7 @@
> (##sys#string->symbol
> (##sys#string-append (tostr prefix)
> (##sys#symbol->string (car imp))))
> (cdr imp)))
> - (values name lib `(,head ,spec ,prefix) (map rename
> impv) (map rename imps) impi)))
> + (values name lib `(prefix ,spec ,prefix) (map rename
> impv) (map rename imps) impi)))
> (else
> (module-imports (strip-syntax x))))))))))))
>
> diff --git a/support.scm b/support.scm
> index 8d9baac2..fa5f1442 100644
> --- a/support.scm
> +++ b/support.scm
> @@ -1834,7 +1834,6 @@ Available debugging options:
> x display information about experimental features
> D when printing nodes, use node-tree output
> I show inferred type information for unexported globals
> - M show syntax-/runtime-requirements
> N show the real-name mapping table
> P show expressions after specialization
> S show applications of compiler syntax
> diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
> index b3ab13ed..338ada24 100644
> --- a/tests/compiler-tests.scm
> +++ b/tests/compiler-tests.scm
> @@ -436,3 +436,10 @@
> (let ((v0 ((foreign-lambda* c-string () "C_return(\"str\");")))
> (v1 ((foreign-lambda* (const c-string) () "C_return(\"str\");"))))
> (assert (equal? v0 v1)))
> +
> +; libraries are only loaded when entry point is called
> +(let ()
> + (if #f (require-library (chicken repl)))
> + (assert (not (##sys#symbol-has-toplevel-binding? 'chicken.repl#repl)))
> + (if #t (require-library (chicken repl)))
> + (assert (##sys#symbol-has-toplevel-binding? 'chicken.repl#repl)))
> diff --git a/tests/import-library-test2.scm b/tests/import-library-test2.scm
> index fb61aee5..32bba424 100644
> --- a/tests/import-library-test2.scm
> +++ b/tests/import-library-test2.scm
> @@ -1,5 +1,3 @@
> -(require-library import-library-test1)
> -
> (module bar (xcase)
> (import scheme (chicken base) foo)
> (assert (equal? '(123) (foo)))
> diff --git a/tests/runtests.bat b/tests/runtests.bat
> index 100e2f48..5bf3026e 100644
> --- a/tests/runtests.bat
> +++ b/tests/runtests.bat
> @@ -397,7 +397,7 @@ if errorlevel 1 exit /b 1
> if errorlevel 1 exit /b 1
> %interpret% -bn test-chained-modules.so
> if errorlevel 1 exit /b 1
> -%interpret% -bn test-chained-modules.so -e "(import m3) (s3)"
> +%interpret% -bn test-chained-modules.so -e "(import-syntax m3) (s3)"
> if errorlevel 1 exit /b 1
>
> echo ======================================== module tests (ec) ...
> diff --git a/tests/runtests.sh b/tests/runtests.sh
> index 35cd9920..e4a99f1d 100755
> --- a/tests/runtests.sh
> +++ b/tests/runtests.sh
> @@ -309,7 +309,7 @@ $compile module-tests-compiled.scm
> ./a.out
> $compile module-static-eval-compiled.scm
> ./a.out
> -$compile -static module-static-eval-compiled.scm
> +$compile -static -uses lolevel module-static-eval-compiled.scm -debug 2M
> ./a.out
>
> echo "======================================== module tests (chained) ..."
> @@ -318,7 +318,7 @@ $interpret -bnq test-chained-modules.scm
> $compile_s test-chained-modules.scm -j m3
> $compile_s m3.import.scm
> $interpret -bn test-chained-modules.so
> -$interpret -bn test-chained-modules.so -e '(import m3) (s3)'
> +$interpret -bn test-chained-modules.so -e '(import-syntax m3) (s3)'
>
> echo "======================================== module tests (ec) ..."
> rm -f ec.so ec.import.*
> diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
> index 44afef85..07b6e21e 100644
> --- a/tests/scrutiny.expected
> +++ b/tests/scrutiny.expected
> @@ -43,10 +43,10 @@ Warning: at toplevel:
> assignment of value of type `fixnum' to toplevel variable `scheme#car'
> does not match declared type `(forall (a) (procedure scheme#car ((pair a *))
> a))'
>
> Warning: at toplevel:
> - expected a single result in `let' binding of `g19', but received 2 results
> + expected a single result in `let' binding of `g24', but received 2 results
>
> Warning: at toplevel:
> - in procedure call to `g19', expected a value of type `(procedure () *)'
> but was given a value of type `fixnum'
> + in procedure call to `g24', expected a value of type `(procedure () *)'
> but was given a value of type `fixnum'
>
> Note: in toplevel procedure `foo':
> expected a value of type boolean in conditional, but was given a value of
> type `(procedure bar () *)' which is always true:
> diff --git a/tests/test-chained-modules.scm b/tests/test-chained-modules.scm
> index c278f3bd..ce1f3be8 100644
> --- a/tests/test-chained-modules.scm
> +++ b/tests/test-chained-modules.scm
> @@ -17,6 +17,5 @@
> (syntax-rules ()
> ((_) (s2)))))
>
> -(import m3)
> +(import-syntax m3)
> (s3)
> -
> --
> 2.11.0
>
> _______________________________________________
> Chicken-hackers mailing list
> address@hidden
> https://lists.nongnu.org/mailman/listinfo/chicken-hackers
On Fri, May 25, 2018 at 05:06:42PM +0300, megane wrote:
>
> This is totally wrong.
>
> The tests should be something more like this (use < instead of <=):
> (test (< (procedure (#!rest x) *)
> (procedure (x x) *)))
> (test (< (procedure (x #!rest x) *)
> (procedure (x x) *)))
> (test (< (procedure (x x #!rest x) *)
> (procedure (x x) *)))
> (test (not (< (procedure (#!rest x) *)
> (procedure (x y) *))))
> (test (< (procedure (#!rest (or x y)) *)
> (procedure (x y) *)))
> (test (< (procedure (x #!rest y) *)
> (procedure (x y) *)))
>
> (test (= (procedure (#!rest x) *)
> (procedure (#!rest x) *)))
> (test (< (procedure (#!rest x) *)
> (procedure (x #!rest x) *)))
> (test (< (procedure (#!rest (or x y)) *)
> (procedure (#!rest x) *)))
> (test (< (procedure (#!rest (or x y)) *)
> (procedure (y #!rest x) *)))
>
> I'm trying to find a better fix.
>
> megane <address@hidden> writes:
>
> > Hi,
> >
> > Currently this doesn't compile:
> > (compiler-typecase (the (#!rest fixnum -> *) 1)
> > ((fixnum fixnum -> *) 1))
> >
> > Error: at toplevel:
> > (rest.scm:7) no clause applies in `compiler-typecase' for expression of
> > type `(procedure (#!rest fixnum) *)':
> > (procedure (fixnum fixnum) *)
> >
> > Here's a more concrete case where this happens. The warning only appears
> > when the procedure contravariant patch is applied:
> >
> > (: foo ((number number -> number) number number -> number))
> > (define (foo f a b)
> > (f a b))
> >
> > (print (foo max 1 2))
> >
> > Warning: at toplevel:
> > (rest.scm:14) in procedure call to `foo', expected argument #1 of type
> > `(procedure (number number) number)' but was given an argument of type
> > `(procedure max (#!rest number) number)'
> >
> > diff --git a/scrutinizer.scm b/scrutinizer.scm
> > index ece07ed..5fc6524 100644
> > --- a/scrutinizer.scm
> > +++ b/scrutinizer.scm
> > @@ -969,7 +969,9 @@
> > (or (eq? '#!optional t)
> > (match1 rtype t)))
> > head)
> > - (match1 rtype (if (pair? tail) (rest-type (cdr tail)) '*)))))
> > + (if (pair? tail)
> > + (match1 rtype (rest-type (cdr tail)))
> > + #t))))
> >
> > (define (optargs? a)
> > (memq a '(#!rest #!optional)))
> > diff --git a/tests/scrutinizer-tests.scm b/tests/scrutinizer-tests.scm
> > index ed313a4..da4fa4f 100644
> > --- a/tests/scrutinizer-tests.scm
> > +++ b/tests/scrutinizer-tests.scm
> > @@ -240,6 +240,26 @@
> >
> > (test (! (procedure () x) (procedure ())))
> > (test (! (procedure () x) (procedure () x y)))
> > +
> > +(test (<= (procedure (#!rest x) *)
> > + (procedure (x x) *)))
> > +(test (<= (procedure (x #!rest x) *)
> > + (procedure (x x) *)))
> > +(test (<= (procedure (x x #!rest x) *)
> > + (procedure (x x) *)))
> > +(test (not (<= (procedure (#!rest x) *)
> > + (procedure (x y) *))))
> > +(test (<= (procedure (#!rest (or x y)) *)
> > + (procedure (x y) *)))
> > +(test (<= (procedure (x #!rest y) *)
> > + (procedure (x y) *)))
> > +
> > +(test (<= (procedure (#!rest x) *)
> > + (procedure (#!rest x) *)))
> > +(test (<= (procedure (#!rest x) *)
> > + (procedure (x #!rest x) *)))
> > +(test (<= (procedure (#!rest (or x y)) *)
> > + (procedure (y #!rest x) *)))
> > ;; s.a.
> > ;(test (? (procedure () x) (procedure () x . y)))
> >
>
>
> _______________________________________________
> Chicken-hackers mailing list
> address@hidden
> https://lists.nongnu.org/mailman/listinfo/chicken-hackers
On Thu, May 24, 2018 at 02:11:42PM +0300, megane wrote:
> Hi,
>
> Currently this doesn't compile:
> (compiler-typecase (the (#!rest fixnum -> *) 1)
> ((fixnum fixnum -> *) 1))
>
> Error: at toplevel:
> (rest.scm:7) no clause applies in `compiler-typecase' for expression of type
> `(procedure (#!rest fixnum) *)':
> (procedure (fixnum fixnum) *)
>
> Here's a more concrete case where this happens. The warning only appears
> when the procedure contravariant patch is applied:
>
> (: foo ((number number -> number) number number -> number))
> (define (foo f a b)
> (f a b))
>
> (print (foo max 1 2))
>
> Warning: at toplevel:
> (rest.scm:14) in procedure call to `foo', expected argument #1 of type
> `(procedure (number number) number)' but was given an argument of type
> `(procedure max (#!rest number) number)'
>
> diff --git a/scrutinizer.scm b/scrutinizer.scm
> index ece07ed..5fc6524 100644
> --- a/scrutinizer.scm
> +++ b/scrutinizer.scm
> @@ -969,7 +969,9 @@
> (or (eq? '#!optional t)
> (match1 rtype t)))
> head)
> - (match1 rtype (if (pair? tail) (rest-type (cdr tail)) '*)))))
> + (if (pair? tail)
> + (match1 rtype (rest-type (cdr tail)))
> + #t))))
>
> (define (optargs? a)
> (memq a '(#!rest #!optional)))
> diff --git a/tests/scrutinizer-tests.scm b/tests/scrutinizer-tests.scm
> index ed313a4..da4fa4f 100644
> --- a/tests/scrutinizer-tests.scm
> +++ b/tests/scrutinizer-tests.scm
> @@ -240,6 +240,26 @@
>
> (test (! (procedure () x) (procedure ())))
> (test (! (procedure () x) (procedure () x y)))
> +
> +(test (<= (procedure (#!rest x) *)
> + (procedure (x x) *)))
> +(test (<= (procedure (x #!rest x) *)
> + (procedure (x x) *)))
> +(test (<= (procedure (x x #!rest x) *)
> + (procedure (x x) *)))
> +(test (not (<= (procedure (#!rest x) *)
> + (procedure (x y) *))))
> +(test (<= (procedure (#!rest (or x y)) *)
> + (procedure (x y) *)))
> +(test (<= (procedure (x #!rest y) *)
> + (procedure (x y) *)))
> +
> +(test (<= (procedure (#!rest x) *)
> + (procedure (#!rest x) *)))
> +(test (<= (procedure (#!rest x) *)
> + (procedure (x #!rest x) *)))
> +(test (<= (procedure (#!rest (or x y)) *)
> + (procedure (y #!rest x) *)))
> ;; s.a.
> ;(test (? (procedure () x) (procedure () x . y)))
>
> _______________________________________________
> Chicken-hackers mailing list
> address@hidden
> https://lists.nongnu.org/mailman/listinfo/chicken-hackers
signature.asc
Description: PGP signature
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- Re: [Chicken-hackers] [PATCH] Add 'a shorthand for forall types,
Peter Bex <=