Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

snow: extract feature list for cond-expand

Browse source 
Currently a package's cond-expand contains the symbol of the target
implementation and optionally more from config file. Execute a
command (once) on target implementation to add their full feature list,
making it available for each package to use.

All of these Schemes are tested. Larceny is just too annoying to get the
feature list (no one-liner, and it could take a while) so Larceny stays
the current behavior.

There is a small unrelated change here: the gosh command to get
version. We don't need to call (exit), if stdin is closed properly (it
should) then gosh should exit regardless.
This commit is contained in:
Nguyễn Thái Ngọc Duy 2020-08-26 19:07:58 +07:00
parent a7a115323c
commit b52b2024f8
5 changed files with 80 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
lib/chibi/snow/commands.scm
View file

@ -3,31 +3,10 @@
;; This code was written by Alex Shinn in 2014 and placed in the
;; Public Domain. All warranties are disclaimed.
(define known-implementations
'((chibi "chibi-scheme" (chibi-scheme -V) "0.7.3")
(chicken "chicken" (csi -release) "4.9.0")
(cyclone "cyclone" (icyc -vn) "0.5.3")
(foment "foment")
(gauche "gosh" (gosh -E "print (gauche-version)" -E exit) "0.9.4")
(kawa "kawa" (kawa --version) "2.0")
(larceny "larceny" (larceny --version) "v0.98")
(sagittarius "sagittarius")))
(define (impl->version impl cmd)
(let* ((lines (process->string-list cmd))
(line (and (pair? lines) (string-split (car lines)))))
(and (pair? line)
(if (and (pair? (cdr line))
(let ((x (string-downcase (car line)))
(name (symbol->string impl)))
(or (equal? x name)
(equal? x (string-append name "-scheme")))))
(cadr line)
(car line)))))
(define (impl-available? cfg spec confirm?)
(if (find-in-path (cadr spec))
(or (null? (cddr spec))
(not (third spec))
(conf-get cfg 'skip-version-checks?)
(let ((version (impl->version (car spec) (third spec))))
(or (and version (version>=? version (fourth spec)))

6
lib/chibi/snow/package.scm
View file

@ -443,8 +443,10 @@
#t)
(cond
((symbol? test)
(or (eq? 'else test) (eq? impl test)
(memq test (conf-get-list config 'features))))
(or (eq? test 'else)
(eq? test impl)
(memq test (conf-get-list config 'features))
(memq test (impl->features impl))))
((pair? test)
(case (car test)
((not) (not (check-cond-expand impl config (cadr test))))

2
lib/chibi/snow/package.sld
View file

@ -30,12 +30,14 @@
(srfi 1)
(srfi 115)
(chibi snow interface)
(chibi snow utils)
(chibi bytevector)
(chibi config)
(chibi crypto md5)
(chibi crypto rsa)
(chibi crypto sha2)
(chibi pathname)
(chibi process)
(chibi string)
(chibi tar)
(chibi uri)

72
lib/chibi/snow/utils.scm
View file

@ -1,3 +1,72 @@
(define (write-to-string x)
(call-with-output-string (lambda (out) (write x out))))
(define known-implementations
`((chibi "chibi-scheme" (chibi-scheme -V) "0.7.3"
,(delay
(process->sexp
'(chibi-scheme -p "(features)"))))
(chicken "chicken" (csi -release) "4.9.0"
;; work around Chicken's write() not quoting 64bit and
;; 32bit properly
,(delay
(process->sexp
`(csi -R r7rs -R srfi-1 -e ,(write-to-string
'(write
(filter (lambda (x)
(not (or (eq? x '|64bit|)
(eq? x '|32bit|))))
(features))))))))
(cyclone "cyclone" (icyc -vn) "0.5.3"
,(delay
(process->sexp
'(icyc -p "(features)"))))
(foment "foment" #f #f
,(delay
(process->sexp
'(foment -e "(write (features))"))))
(gauche "gosh" (gosh -E "print (gauche-version)") "0.9.4"
,(delay
(process->sexp
'(gosh -uscheme.base -e "(write (features))"))))
(kawa "kawa" (kawa --version) "2.0"
,(delay
(process->sexp
'(kawa -e "(write (features))"))))
(larceny "larceny" (larceny --version) "v0.98"
,(delay '()))
(sagittarius "sagittarius" #f #f
,(delay
(process->sexp
'(sagittarius -I "(scheme base)" -e "(write (features))"))))))
(define (impl->version impl cmd)
(let* ((lines (process->string-list cmd))
(line (and (pair? lines) (string-split (car lines)))))
(and (pair? line)
(if (and (pair? (cdr line))
(let ((x (string-downcase (car line)))
(name (symbol->string impl)))
(or (equal? x name)
(equal? x (string-append name "-scheme")))))
(cadr line)
(car line)))))
(define (target-is-host? impl)
(case impl
((chibi) (cond-expand (chibi #t) (else #f)))
((gauche) (cond-expand (gauche #t) (else #f)))
((sagittarius) (cond-expand (sagittarius #t) (else #f)))
(else #f)))
(define (impl->features impl)
(cond
((target-is-host? impl)
(features))
((assq impl known-implementations)
=> (lambda (impl)
(force (fifth impl))))
(else '())))
(define (find-in-path file . o)
(any (lambda (dir)
@ -17,9 +86,6 @@
(and (pred x) x))))))
dirs)))
(define (write-to-string x)
(call-with-output-string (lambda (out) (write x out))))
(define (display-to-string x)
(call-with-output-string
(lambda (out)

5
lib/chibi/snow/utils.sld
View file

@ -4,9 +4,12 @@
write-to-string display-to-string
resource->bytevector uri-normalize uri-directory
version-split version-compare version>? version>=?
topological-sort)
topological-sort
known-implementations impl->version impl->features)
(import (scheme base)
(scheme char)
(scheme file)
(scheme lazy)
(scheme read)
(scheme write)
(scheme process-context)