suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: add (system-type 'machine)

Browse Source 
Closes #2343
This commit is contained in:
Matthew Flatt 2018-10-29 19:51:51 -06:00
parent 842c6b5a3f
commit 063fa65872
8 changed files with 130 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
racket/src/cs/io.sls
View File

@ -385,6 +385,51 @@
;; ----------------------------------------
;; `#%windows-version-instance` is used for `(system-type 'machine)`
;; (via `get-machine-info`) on Windows
(meta-cond
[(#%memq (machine-type) '(a6nt ta6nt i3nt ti3nt))
(define |#%windows-version-instance|
(hash 'get-windows-version
(lambda ()
(define-ftype DWORD integer-32)
(define-ftype BOOL int)
(define-ftype OSVERSIONINFOA
(|struct|
[dwOSVersionInfoSize DWORD]
[dwMajorVersion DWORD]
[dwMinorVersion DWORD]
[dwBuildNumber DWORD]
[dwPlatformId DWORD]
[szCSDVersion (array 128 unsigned-8)]))
(define GetVersionEx
(begin
(load-shared-object "Kernel32.dll")
(foreign-procedure "GetVersionExA" ((* OSVERSIONINFOA)) BOOL)))
(define v (make-ftype-pointer OSVERSIONINFOA
(foreign-alloc (ftype-sizeof OSVERSIONINFOA))))
(ftype-set! OSVERSIONINFOA (dwOSVersionInfoSize) v (ftype-sizeof OSVERSIONINFOA))
(cond
[(GetVersionEx v)
(values (ftype-ref OSVERSIONINFOA (dwMajorVersion) v)
(ftype-ref OSVERSIONINFOA (dwMinorVersion) v)
(ftype-ref OSVERSIONINFOA (dwBuildNumber) v)
(list->bytes
(let loop ([i 0])
(define b (ftype-ref OSVERSIONINFOA (szCSDVersion i) v))
(cond
[(fx= b 0) '()]
[else (cons b (loop (fx+ i 1)))]))))]
[else
(values 0 0 0 #vu8())]))))]
[else
(define |#%windows-version-instance|
(hash 'get-windows-version
(lambda () (raise-arguments-error 'get-windows-version
"not on Windows"))))])
;; ----------------------------------------
(export system-library-subpath)
(define system-library-subpath
(case-lambda
@ -410,6 +455,7 @@
[(|#%pthread|) (hasheq)]
[(|#%thread|) |#%thread-instance|]
[(|#%rktio|) |#%rktio-instance|]
[(|#%windows-version|) |#%windows-version-instance|]
[else #f]))
(include "include.ss")
@ -423,4 +469,5 @@
(set-error-display-eprintf! (lambda (fmt . args)
(apply 1/fprintf (|#%app| 1/current-error-port) fmt args)))
(set-ffi-get-lib-and-obj! ffi-get-lib ffi-get-obj ptr->address)
(set-async-callback-poll-wakeup! 1/unsafe-signal-received))
(set-async-callback-poll-wakeup! 1/unsafe-signal-received)
(set-get-machine-info! get-machine-info))

1
racket/src/cs/rumble.sls
View File

@ -477,6 +477,7 @@
system-type
system-path-convention-type
system-library-subpath-string ; not exported to Racket
set-get-machine-info! ; not exported to Racket
unsafe-car
unsafe-cdr

6
racket/src/cs/rumble/system.ss
View File

@ -22,7 +22,7 @@
[(word) (if (> (fixnum-width) 32) 64 32)]
[(gc) 'cs]
[(link) 'framework]
[(machine) "localhost info..."]
[(machine) (get-machine-info)]
[(so-suffix) (case (machine-type)
[(a6osx ta6osx i3osx ti3osx) (string->utf8 ".dylib")]
[(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")]
@ -61,3 +61,7 @@
[(a6s2 ta6s2) "x86_64-solaris"]
[(i3s2 ti3s2) "i386-solaris"]
[else "unix"]))
(define get-machine-info (lambda () "localhost info..."))
(define (set-get-machine-info! proc)
(set! get-machine-info proc))

3
racket/src/io/demo.rkt
View File

@ -15,6 +15,9 @@
(current-directory (host:path->string (host:current-directory)))
(set-string->number?! string->number)
(get-machine-info)
(exit)
(define-syntax-rule (test expect rhs)
(let ([e expect]
[v rhs])

7
racket/src/io/host/bootstrap.rkt
View File

@ -140,3 +140,10 @@
'unsafe-add-pre-poll-callback! (lambda (proc) (void))
'set-get-subprocesses-time! void
'prop:place-message prop:place-message))
(primitive-table '#%windows-version
(hasheq 'get-windows-version (lambda ()
(values 'major
'minor
'build-number
#"CSDVersion (possibly empty)"))))

11
racket/src/io/host/windows-version.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/base
(require (only-in '#%linklet primitive-table))
(provide get-windows-version)
(define windows-version-table
(or (primitive-table '#%windows-version)
(error '#%windows-version "windows-version not supported by host")))
(define get-windows-version
(hash-ref windows-version-table 'get-windows-version))

53
racket/src/io/machine/main.rkt Normal file
View File

@ -0,0 +1,53 @@
#lang racket/base
(require "../subprocess/main.rkt"
"../security/main.rkt"
"../file/main.rkt"
"../port/main.rkt"
"../locale/main.rkt"
"../format/main.rkt"
"../host/windows-version.rkt")
(provide get-machine-info)
(define uname-paths
(list "/bin/uname"
"/usr/bin/uname"
"/sbin/uname"
"/usr/sbin/uname"
"/usr/local/bin/uname"
"/usr/local/uname"))
(define (get-machine-info)
(case (system-type)
[(windows)
(define-values (major minor build-number CSD-vers) (get-windows-version))
(format "Windows NT ~a.~a (Build ~a)~a~a"
major minor build-number
(if (equal? CSD-vers #"") "" " ")
CSD-vers)]
[else
(let/ec done
(parameterize ([current-security-guard
(unsafe-make-security-guard-at-root)])
(for ([uname (in-list uname-paths)])
(when (file-exists? uname)
(with-handlers (#;[exn:fail? void])
(define-values (subproc stdout stdin stderr) (subprocess #f #f #f uname "-a"))
(close-output-port stdin)
(close-input-port stderr)
(define bstr (read-bytes 1024 stdout))
(close-input-port stdout)
(subprocess-wait subproc)
(when (bytes? bstr)
;; Strip trailing whitespace, especially newlines
(let loop ([i (bytes-length bstr)])
(cond
[(zero? i) (done "")]
[(char-whitespace? (integer->char (bytes-ref bstr (sub1 i))))
(loop (sub1 i))]
[else
(done (bytes->string/locale (subbytes bstr 0 i)))])))))))
"<unknown machine>")]))

2
racket/src/io/main.rkt
View File

@ -20,6 +20,7 @@
"network/main.rkt"
"foreign/main.rkt"
"unsafe/main.rkt"
"machine/main.rkt"
"run/main.rkt"
"port/parameter.rkt"
(only-in "host/rktio.rkt"
@ -46,6 +47,7 @@
(all-from-out "network/main.rkt")
(all-from-out "foreign/main.rkt")
(all-from-out "unsafe/main.rkt")
(all-from-out "machine/main.rkt")
(all-from-out "run/main.rkt")
make-place-ports+fds
io-place-init!)