Changeset 35227 in project


Ignore:
Timestamp:
03/01/18 03:11:06 (8 months ago)
Author:
kon
Message:

re-flow, add types, deprecation notes

Location:
release/4/macosx/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/macosx/trunk/macosx-env.scm

    r26570 r35227  
    11;;;; macosx-env.scm
    22;;;; Kon Lovett, Mar '09
     3;;;; Kon Lovett, Feb '18
    34
    45;; Issues
     
    1011;; - No CFStringGetCStringPtr use since memory allocation is not performed.
    1112;; This is sub-par but makes the Scheme invocation more complex.
     13;;
     14;; - Deprecated:
     15;; (10.8 CSCopyMachineName CSCopyUserName ReadLocation Gestalt Delay TickCount)
     16;; (10.7 IsMetric)
     17
     18;;;
     19
     20(module macosx-env
     21
     22(;export
     23  session-info
     24  machine-name
     25  short-user-name
     26  long-user-name
     27  machine-location
     28  metric?
     29  computer-name
     30  console-user
     31  local-host-name
     32  location-name
     33  main-bundle-path
     34  tick-count
     35  delay-for-ticks
     36  gestalt)
     37
     38(import scheme chicken foreign)
     39(use
     40  dollar
     41  (only type-checks check-number)
     42  macosx-errors)
     43
     44(declare
     45  (bound-to-procedure ##sys#check-syntax))
    1246
    1347;;;
     
    6397machine_location( double *lat, double *lon, int *dls, long *gmt )
    6498{
    65 #       define ROUNDN( v, p ) (round( (v ) * ((p) * 10.0)) / ((p) * 10.0))
     99#       define ROUNDN( v, p ) (round( (v) * (p) ) / (p))
    66100
    67101        MachineLocation machloc;
     
    69103        ReadLocation( &machloc );
    70104
    71         *lat = ROUNDN( ((double) FractToFloat( machloc.latitude )) * 90.0, 4);
    72         *lon = ROUNDN( ((double) FractToFloat( machloc.longitude )) * 90.0, 4);
     105        *lat = ROUNDN( ((double) FractToFloat( machloc.latitude )) * 90.0, 4 * 10.0);
     106        *lon = ROUNDN( ((double) FractToFloat( machloc.longitude )) * 90.0, 4 * 10.0);
    73107        *dls = 0 < machloc.u.dls.Delta ? 3600 : (0 > machloc.u.dls.Delta ? -3600 : 0);
    74108        *gmt = ((machloc.u.gmtDelta & 0x00FFFFFF) << 8) >> 8;
     
    168202}
    169203
     204/* sessionInfo bitmasks */
    170205#define session_LoginCompleted  0x0001
    171206#define session_UserIsActive    0x0010
     207/* via include: "sessionIsRoot" "sessionHasGraphicAccess" "sessionHasTTY" "sessionIsRemote" */
    172208
    173209static void
     
    197233;;;
    198234
    199 (module macosx-env
    200 
    201   (;export
    202     session-info
    203     machine-name
    204     short-user-name
    205     long-user-name
    206     machine-location
    207     metric?
    208     computer-name
    209     console-user
    210     local-host-name
    211     location-name
    212     main-bundle-path
    213     tick-count
    214     delay-for-ticks
    215     gestalt
    216     ;;
    217     osstatus-condition?
    218     oserr-condition?)
    219 
    220   (import scheme chicken foreign
    221     dollar
    222     (only type-checks check-number)
    223     (only macosx-errors
    224       exception-osstatus osstatus-condition?  exception-oserr oserr-condition?))
    225 
    226   (require-library dollar type-checks macosx-errors)
    227 
    228   (declare (bound-to-procedure ##sys#check-syntax))
    229 
    230 ;;
    231 
    232235(define-syntax $/string:out#1
    233236  (er-macro-transformer
    234237    (lambda (frm rnm cmp)
    235238      (##sys#check-syntax '$/string:out#1 frm '(_ symbol . #(_ 0)))
    236       (let ((_$ (rnm '$))
    237             (_void (rnm 'void))
    238             (_unsigned-c-string* (rnm 'unsigned-c-string*))
    239             (_location (rnm 'location))
    240             (_let-location (rnm 'let-location)))
    241         (let ((c-nam (cadr frm))
    242               (args (cddr frm))
    243               (tmp (rnm (gensym))) )
     239      (let (
     240        (_$ (rnm '$))
     241        (_void (rnm 'void))
     242        (_unsigned-c-string* (rnm 'unsigned-c-string*))
     243        (_location (rnm 'location))
     244        (_let-location (rnm 'let-location)) )
     245        (let (
     246          (cnam (cadr frm))
     247          (args (cddr frm))
     248          (tmp (rnm (gensym))) )
    244249          `(,_let-location ((,tmp ,_unsigned-c-string*))
    245              (,_$ void ,c-nam (,_location ,tmp) ,@args)
     250             (,_$ void ,cnam (,_location ,tmp) ,@args)
    246251             ,tmp) ) ) ) ) )
    247252
    248253(define-syntax bitwise-test?/foreign-mask
    249254  (syntax-rules ()
    250     ((_ ?bits ?c-nam)
    251      (not (zero? (bitwise-and ?bits (foreign-value ?c-nam unsigned-integer32)))) ) ) )
    252 
    253 ;;
    254 
     255    ((_ ?bits ?cnam)
     256      (not
     257        (zero?
     258          (bitwise-and
     259            ?bits
     260            (foreign-value ?cnam unsigned-integer32)))) ) ) )
     261
     262;;
     263
     264(: session-info ( -> (vector number boolean boolean boolean boolean void string number number boolean boolean)))
     265;
    255266(define (session-info)
    256   (let-location ((sid unsigned-integer32)
    257                  (sab unsigned-integer32))
    258     (let ((sta ($ int sessionInfo #$sid #$sab)))
    259       (if (not (fx= 0 sta))
    260           (exception-osstatus 'session-info "SessionGetInfo failed" sta)
    261           (let-location ((uid unsigned-integer32)
    262                          (con unsigned-integer32)
    263                          (bits unsigned-integer32))
    264             (let ((nam ($/string:out#1 sessionInfoProperties #$uid #$con #$bits)))
    265               (if (not nam)
    266                   (exception-osstatus 'session-info "CGSessionCopyCurrentDictionary failed" 0)
    267                   (vector
    268                     sid
    269                     (bitwise-test?/foreign-mask sab "sessionIsRoot")
    270                     (bitwise-test?/foreign-mask sab "sessionHasGraphicAccess")
    271                     (bitwise-test?/foreign-mask sab "sessionHasTTY")
    272                     (bitwise-test?/foreign-mask sab "sessionIsRemote")
    273                     ; sessionWasInitialized removed by MacOS 10.7 so concept is
    274                     ; not useful.
    275                     (void) #;(bitwise-test?/foreign-mask sab "sessionWasInitialized")
    276                     nam
    277                     uid
    278                     con
    279                     (bitwise-test?/foreign-mask bits "session_LoginCompleted")
    280                     (bitwise-test?/foreign-mask bits "session_UserIsActive")) ) ) ) ) ) ) )
    281 
    282 ;;
    283 
    284 (define (machine-name) ($/string:out#1 machine_name))
    285 
    286 (define (short-user-name) ($/string:out#1 short_user_name))
    287 
    288 (define (long-user-name) ($/string:out#1 long_user_name))
    289 
     267  (let-location (
     268    (sessionId unsigned-integer32)
     269    (sessionAttributes unsigned-integer32) )
     270    (let (
     271      (status
     272        ($ int sessionInfo #$sessionId #$sessionAttributes)) )
     273      (if (not (zero? status))
     274        (exception-osstatus 'session-info "SessionGetInfo failed" status)
     275        (let-location (
     276          (userId unsigned-integer32)
     277          (consoleSet unsigned-integer32)
     278          (sessionProperties unsigned-integer32) )
     279          (let (
     280            (shortUserName
     281              ($/string:out#1
     282                sessionInfoProperties
     283                #$userId #$consoleSet #$sessionProperties)) )
     284            (if (not shortUserName)
     285              (exception-osstatus 'session-info "CGSessionCopyCurrentDictionary failed" 0)
     286              (vector
     287                sessionId
     288                (bitwise-test?/foreign-mask sessionAttributes "sessionIsRoot")
     289                (bitwise-test?/foreign-mask sessionAttributes "sessionHasGraphicAccess")
     290                (bitwise-test?/foreign-mask sessionAttributes "sessionHasTTY")
     291                (bitwise-test?/foreign-mask sessionAttributes "sessionIsRemote")
     292                ;sessionWasInitialized removed by macOS 10.7 so concept is
     293                ;not useful.
     294                (void) ;(bitwise-test?/foreign-mask sessionAttributes "sessionWasInitialized")
     295                shortUserName
     296                userId
     297                consoleSet
     298                (bitwise-test?/foreign-mask sessionProperties "session_LoginCompleted")
     299                (bitwise-test?/foreign-mask sessionProperties "session_UserIsActive")) ) ) ) ) ) ) )
     300
     301;;
     302
     303(: machine-name ( -> string))
     304;
     305(define (machine-name)
     306  ($/string:out#1 machine_name))
     307
     308(: short-user-name ( -> string))
     309;
     310(define (short-user-name)
     311  ($/string:out#1 short_user_name))
     312
     313(: long-user-name ( -> string))
     314;
     315(define (long-user-name)
     316  ($/string:out#1 long_user_name))
     317
     318(: machine-location ( -> (vector number number number number)))
     319;
    290320(define (machine-location)
    291         (let-location ((lat double) (lon double) (dls int) (gmt long))
     321        (let-location (
     322          (lat double)
     323          (lon double)
     324          (dls int)
     325          (gmt long) )
    292326                ($ void machine_location #$lat #$lon #$dls #$gmt)
    293327                (vector lat lon dls gmt) ) )
    294328
    295 (define (metric?) ($ bool IsMetric))
    296 
    297 ;;
    298 
     329(: metric? ( -> boolean))
     330;
     331(define (metric?)
     332  ($ bool IsMetric))
     333
     334;;
     335
     336(define-type c-pointer *)
     337
     338(: computer-name (#!optional (or boolean c-pointer) -> string))
     339;
    299340(define (computer-name #!optional (store #f))
    300341  ($/string:out#1 computer_name (c-pointer store)) )
    301342
     343(: console-user (#!optional (or boolean c-pointer) -> (vector string number number)))
     344;
    302345(define (console-user #!optional (store #f))
    303         (let-location ((uid unsigned-integer32) (gid unsigned-integer32))
    304           (let ((nam ($/string:out#1 console_user #$uid #$gid (c-pointer store))))
    305             (and nam
    306                       (vector nam uid gid) ) ) ) )
    307 
     346        (let-location (
     347          (userId unsigned-integer32)
     348          (groupId unsigned-integer32) )
     349          (let (
     350            (userShortName ($/string:out#1 console_user #$userId #$groupId (c-pointer store))) )
     351            (and
     352              userShortName
     353        (vector userShortName userId groupId) ) ) ) )
     354
     355(: local-host-name (#!optional (or boolean c-pointer) -> string))
     356;
    308357(define (local-host-name #!optional (store #f))
    309358  ($/string:out#1 local_host_name (c-pointer store)) )
    310359
     360(: location-name (#!optional (or boolean c-pointer) -> string))
     361;
    311362(define (location-name #!optional (store #f))
    312363  ($/string:out#1 location_name (c-pointer store)) )
     
    314365;;
    315366
    316 (define (main-bundle-path) ($/string:out#1 main_bundle_path))
    317 
    318 ;;
    319 
    320 (define (tick-count) ($ unsigned-integer32 TickCount))
    321 
     367(: main-bundle-path ( -> string))
     368;
     369(define (main-bundle-path)
     370  ($/string:out#1 main_bundle_path))
     371
     372;;
     373
     374(: tick-count ( -> number))
     375;
     376(define (tick-count)
     377  ($ unsigned-integer32 TickCount))
     378
     379(: delay-for-ticks (number -> number))
     380;
    322381(define (delay-for-ticks ticks)
    323         (let-location ((fticks unsigned-long))
     382        (let-location (
     383          (fticks unsigned-long) )
    324384    ($ void Delay (unsigned-long ticks) #$fticks)
    325385    fticks ) )
     
    327387;;
    328388
     389(: gestalt ((or number string symbol) -> number))
     390;
    329391(define (gestalt sel)
    330   (when (symbol? sel) (set! sel (symbol->string sel)))
    331   (when (string? sel) (set! sel ($ unsigned-integer32 stringToOSType (nonnull-c-string sel))))
    332   (check-number 'gestalt sel)
    333         (let-location ((resp long))
    334     (let ((err ($ short Gestalt (unsigned-integer32 sel) #$resp)))
    335       (if (fx= 0 err) resp
    336         (exception-oserr 'gestalt "Gestalt failed" err) ) ) ) )
     392  (let (
     393    (sel (gestalt-selector sel)) )
     394    (check-number 'gestalt sel)
     395    (let-location (
     396      (resp long) )
     397      (let (
     398        (err ($ short Gestalt (unsigned-integer32 sel) #$resp)) )
     399        (if (zero? err)
     400          resp
     401          (exception-oserr 'gestalt "Gestalt failed" err) ) ) ) ) )
     402
     403(: gestalt-selector ((or number string symbol) -> number))
     404;
     405(define (gestalt-selector sel)
     406  (cond
     407    ((symbol? sel)
     408      (gestalt-selector (symbol->string sel)) )
     409    ((string? sel)
     410      ($ unsigned-integer32 stringToOSType (nonnull-c-string sel)))
     411    (else ;(number? sel)
     412      sel ) ) )
    337413
    338414) ;module macosx-env
  • release/4/macosx/trunk/macosx-errors.scm

    r19864 r35227  
    11;;;; macosx-errors.scm
    22;;;; Kon Lovett, Mar '09
     3;;;; Kon Lovett, Feb '18
    34
    45;;;
     
    67(module macosx-errors
    78
    8   (;export
    9     exception-osstatus
    10     exception-oserr
    11     osstatus-condition?
    12     oserr-condition?)
     9(;export
     10  exception-osstatus
     11  exception-oserr
     12  ;
     13  osstatus-condition?
     14  oserr-condition?)
    1315
    14   (import scheme chicken condition-utils)
    15   (require-library condition-utils)
     16(import scheme chicken)
     17(use condition-utils)
    1618
    1719;;
     
    2325  (make-exn-condition+ loc msg args `(oserr code ,cod)) )
    2426
     27;;
     28
    2529(define (exception-osstatus loc msg code . args)
    2630  (abort (apply make-exn-osstatus-condition loc msg code args)) )
     
    2933  (abort (apply make-exn-oserr-condition loc msg code args)) )
    3034
    31 (define osstatus-condition? (make-condition-predicate osstatus))
     35(: osstatus-condition? (* -> boolean : condition))
     36;
     37(define osstatus-condition?
     38  (make-condition-predicate osstatus) )
    3239
    33 (define oserr-condition? (make-condition-predicate oserr))
     40(: oserr-condition? (* -> boolean : condition))
     41;
     42(define oserr-condition?
     43  (make-condition-predicate oserr) )
    3444
    3545) ;module macosx-errors
  • release/4/macosx/trunk/macosx-url.scm

    r17429 r35227  
    11;;;; macosx-url.scm
    22;;;; Kon Lovett, Mar '09
     3;;;; Kon Lovett, Feb '18
     4
     5;; Issues
     6;;
     7
     8(module macosx-url
     9
     10(;export
     11  open-url)
     12
     13(import scheme chicken foreign)
     14(use
     15  dollar
     16  (only type-checks check-string)
     17  macosx-errors)
    318
    419;;;
     
    1126open_url( const char *urlstr, int len )
    1227{
    13         OSStatus sta = EXIT_FAILURE;
    14         CFURLRef url
    15           = CFURLCreateWithBytes( NULL, (const UInt8 *) urlstr, len, kCFStringEncodingASCII, NULL );
     28        OSStatus status = EXIT_FAILURE;
     29        CFURLRef url = CFURLCreateWithBytes( NULL,
     30    (const UInt8 *) urlstr, len,
     31    kCFStringEncodingASCII, NULL );
    1632        if (NULL != url) {
    17                 sta = LSOpenCFURLRef( url, NULL );
     33                status = LSOpenCFURLRef( url, NULL );
    1834                CFRelease( url );
    1935        }
    20         return sta;
     36        return status;
    2137}
    2238<#
     
    2440;;;
    2541
    26 (module macosx-url
    27 
    28   (;export
    29     open-url
    30     ;;
    31     osstatus-condition?)
    32 
    33   (import scheme chicken foreign
    34     dollar
    35     (only type-checks check-string)
    36     (only macosx-errors exception-osstatus osstatus-condition?))
    37 
    38   (require-library dollar type-checks macosx-errors)
    39 
    40 ;;
    41 
    4242(define (open-url url)
    4343  (check-string 'open-url url)
    44         (let ((sta ($ int open_url (c-string url) (int (string-length url)))))
    45           (unless (zero? sta)
    46             (exception-osstatus 'open-url "CFURLCreateWithBytes failed" sta url) ) ) )
     44        (let (
     45          (status ($ int open_url (c-string url) (int (string-length url)))) )
     46          (unless (zero? status)
     47            (exception-osstatus 'open-url "CFURLCreateWithBytes failed" status url) ) ) )
    4748
    4849) ;module macosx-url
  • release/4/macosx/trunk/macosx.setup

    r35226 r35227  
    1919    -framework CoreFoundation -framework ApplicationServices))
    2020
     21(print)
     22(print "*** expect macOS API deprecation warnings (refer errors to the author/maintainer) ***")
     23(print)
     24
    2125(setup-shared-extension-module 'macosx-env (extension-version "2.2.0")
    2226  #:types? #t
Note: See TracChangeset for help on using the changeset viewer.