Changeset 13844 in project


Ignore:
Timestamp:
03/19/09 23:22:51 (11 years ago)
Author:
Kon Lovett
Message:

Added info print to run.scm

Location:
release/4/macosx
Files:
6 edited

Legend:

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

    r13591 r13844  
    210210
    211211(module macosx-env (;export
    212   ;
    213212  session-info
    214213  machine-name
     
    226225  gestalt)
    227226
    228 (import scheme chicken foreign)
    229 (import dollar)
     227(import scheme chicken foreign dollar)
    230228
    231229;;
    232230
    233231(define (make-exn-condition loc msg . args)
    234   (make-property-condition 'exn 'location loc 'message msg 'arguments args))
     232  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
    235233
    236234(define (make-osstatus-condition code)
    237   (make-property-condition 'osstatus 'code code))
     235  (make-property-condition 'osstatus 'code code) )
     236
     237(define (make-oserr-condition code)
     238  (make-property-condition 'oserr 'code code) )
    238239
    239240(define (make-exn-osstatus-condition loc msg code . args)
    240241  (make-composite-condition
    241242   (apply make-exn-condition loc msg args)
    242    (make-osstatus-condition code)))
    243 
    244 (define (make-oserr-condition code)
    245   (make-property-condition 'oserr 'code code))
     243   (make-osstatus-condition code)) )
    246244
    247245(define (make-exn-oserr-condition loc msg code . args)
    248246  (make-composite-condition
    249247   (apply make-exn-condition loc msg args)
    250    (make-oserr-condition code)))
     248   (make-oserr-condition code)) )
    251249
    252250;;
    253251
    254252(define (osstatus-error loc msg code . args)
    255   (abort (apply make-exn-osstatus-condition loc msg code args)))
     253  (abort (apply make-exn-osstatus-condition loc msg code args)) )
    256254
    257255(define (oserr-error loc msg code . args)
    258   (abort (apply make-exn-oserr-condition loc msg code args)))
     256  (abort (apply make-exn-oserr-condition loc msg code args)) )
    259257
    260258;;
     
    273271        `(,$let-location ((,stroutvar ,$unsigned-c-string*))
    274272           (,$$ void ,c-nam (location ,stroutvar) ,@args)
    275            ,stroutvar)))))
     273           ,stroutvar) ) ) ) )
    276274         
    277275(define-syntax bitwise-test?/foreign-mask
    278276  (syntax-rules ()
    279277    ((_ ?bits ?c-nam)
    280      (not (zero? (bitwise-and ?bits (foreign-value ?c-nam unsigned-integer32)))))))
     278     (not (zero? (bitwise-and ?bits (foreign-value ?c-nam unsigned-integer32)))) ) ) )
    281279
    282280;;
     
    302300                          con
    303301                          (bitwise-test?/foreign-mask bits "session_LoginCompleted")
    304                           (bitwise-test?/foreign-mask bits "session_UserIsActive")))))))))
    305 
    306 ;;
    307 
    308 (define (machine-name)
    309         ($/string:out#1 machine_name))
    310 
    311 (define (short-user-name)
    312         ($/string:out#1 short_user_name))
    313 
    314 (define (long-user-name)
    315         ($/string:out#1 long_user_name))
     302                          (bitwise-test?/foreign-mask bits "session_UserIsActive")) ) ) ) ) ) ) )
     303
     304;;
     305
     306(define (machine-name) ($/string:out#1 machine_name))
     307
     308(define (short-user-name) ($/string:out#1 short_user_name))
     309
     310(define (long-user-name) ($/string:out#1 long_user_name))
    316311
    317312(define (machine-location)
    318313        (let-location ((lat double) (lon double) (dls int) (gmt long))
    319314                ($ void machine_location #$lat #$lon #$dls #$gmt)
    320                 (vector lat lon dls gmt)))
    321 
    322 (define (metric?)
    323         ($ bool IsMetric))
    324 
    325 ;;
    326 
    327 (define (computer-name #!optional (store #f))
    328         ($/string:out#1 computer_name (c-pointer store)))
     315                (vector lat lon dls gmt) ) )
     316
     317(define (metric?) ($ bool IsMetric))
     318
     319;;
     320
     321(define (computer-name #!optional (store #f)) ($/string:out#1 computer_name (c-pointer store)))
    329322
    330323(define (console-user #!optional (store #f))
     
    332325          (let ((nam ($/string:out#1 console_user #$uid #$gid (c-pointer store))))
    333326            (and nam
    334                       (vector nam uid gid)))))
    335 
    336 (define (local-host-name #!optional (store #f))
    337         ($/string:out#1 local_host_name (c-pointer store)))
    338 
    339 (define (location-name #!optional (store #f))
    340         ($/string:out#1 location_name (c-pointer store)))
    341 
    342 ;;
    343 
    344 (define (main-bundle-path)
    345   ($/string:out#1 main_bundle_path))
    346 
    347 ;;
    348 
    349 (define (tick-count)
    350   ($ unsigned-integer32 TickCount))
     327                      (vector nam uid gid) ) ) ) )
     328
     329(define (local-host-name #!optional (store #f)) ($/string:out#1 local_host_name (c-pointer store)))
     330
     331(define (location-name #!optional (store #f)) ($/string:out#1 location_name (c-pointer store)))
     332
     333;;
     334
     335(define (main-bundle-path) ($/string:out#1 main_bundle_path))
     336
     337;;
     338
     339(define (tick-count) ($ unsigned-integer32 TickCount))
    351340
    352341(define (delay-for-ticks ticks)
    353342        (let-location ((fticks unsigned-long))
    354343    ($ void Delay (unsigned-long ticks) #$fticks)
    355     fticks))
     344    fticks ) )
    356345
    357346;;
     
    359348(define (gestalt sel)
    360349  (when (symbol? sel) (set! sel (symbol->string sel)))
    361   (when (string? sel) (set! sel ((foreign-lambda unsigned-integer32 "stringToOSType" c-string) sel)))
     350  (when (string? sel) (set! sel ($ unsigned-integer32 stringToOSType (nonnull-c-string sel))))
    362351  (##sys#check-number sel 'gestalt)
    363352        (let-location ((resp long))
    364353    (let ((err ($ short Gestalt (unsigned-integer32 sel) #$resp)))
    365354      (if (fx= 0 err) resp
    366           (oserr-error 'gestalt "Gestalt failed" err)))))
     355          (oserr-error 'gestalt "Gestalt failed" err) ) ) ) )
    367356
    368357) ;module macosx-env
  • release/4/macosx/tags/2.0.0/macosx-url.scm

    r13591 r13844  
    3939(require-library dollar)
    4040
    41 (module macosx-url (;export
    42   open-url)
     41(module macosx-url (open-url)
    4342
    44 (import scheme chicken foreign)
    45 (import dollar)
     43(import scheme chicken foreign dollar)
    4644
    4745;;
  • release/4/macosx/tags/2.0.0/tests/run.scm

    r13591 r13844  
    44(require-extension macosx-env)
    55(require-extension macosx-url)
     6
     7(define (print-info)
     8  (print "     session-info:  " (session-info))
     9  (print "     machine-name:  " (machine-name))
     10  (print "  short-user-name:  " (short-user-name))
     11  (print "   long-user-name:  " (long-user-name))
     12  (print " machine-location:  " (machine-location))
     13  (print "          metric?:  " (metric?))
     14  (print "    computer-name:  " (computer-name))
     15  (print "     console-user:  " (console-user))
     16  (print "  local-host-name:  " (local-host-name))
     17  (print "    location-name:  " (location-name))
     18  (print " main-bundle-path:  " (main-bundle-path))
     19  (print "       tick-count:  " (tick-count))
     20  (print "    gestalt 'addr:  " (gestalt 'addr)) )
     21
     22(define (delay-test ticks)
     23  (print* "* Delaying for " ticks " ticks ...")
     24  (delay-for-ticks ticks)
     25  (print " Done *")
     26  (newline) )
    627
    728(test-group "macosx-env"
     
    1132  (test-assert (long-user-name))
    1233  (test-assert (machine-location))
    13   #; ;works in 'csi' but as 'test-assert' causes "Illegal instruction"
    14   (test-assert (metric?))
     34  (test-assert (boolean? (metric?)))
    1535  (test-assert (computer-name))
    1636  (test-assert (console-user))
     
    1939  (test-assert (main-bundle-path))
    2040  (test-assert (tick-count))
    21   (delay-for-ticks 5)
    2241  (test-assert (gestalt 'addr))
    2342)
     43
     44(delay-test 50)
     45
     46(print-info)
    2447
    2548(test-group "macosx-url - should launch default browser with \"http://www.apple.com/\""
  • release/4/macosx/trunk/macosx-env.scm

    r13589 r13844  
    210210
    211211(module macosx-env (;export
    212   ;
    213212  session-info
    214213  machine-name
     
    226225  gestalt)
    227226
    228 (import scheme chicken foreign)
    229 (import dollar)
     227(import scheme chicken foreign dollar)
    230228
    231229;;
    232230
    233231(define (make-exn-condition loc msg . args)
    234   (make-property-condition 'exn 'location loc 'message msg 'arguments args))
     232  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
    235233
    236234(define (make-osstatus-condition code)
    237   (make-property-condition 'osstatus 'code code))
     235  (make-property-condition 'osstatus 'code code) )
     236
     237(define (make-oserr-condition code)
     238  (make-property-condition 'oserr 'code code) )
    238239
    239240(define (make-exn-osstatus-condition loc msg code . args)
    240241  (make-composite-condition
    241242   (apply make-exn-condition loc msg args)
    242    (make-osstatus-condition code)))
    243 
    244 (define (make-oserr-condition code)
    245   (make-property-condition 'oserr 'code code))
     243   (make-osstatus-condition code)) )
    246244
    247245(define (make-exn-oserr-condition loc msg code . args)
    248246  (make-composite-condition
    249247   (apply make-exn-condition loc msg args)
    250    (make-oserr-condition code)))
     248   (make-oserr-condition code)) )
    251249
    252250;;
    253251
    254252(define (osstatus-error loc msg code . args)
    255   (abort (apply make-exn-osstatus-condition loc msg code args)))
     253  (abort (apply make-exn-osstatus-condition loc msg code args)) )
    256254
    257255(define (oserr-error loc msg code . args)
    258   (abort (apply make-exn-oserr-condition loc msg code args)))
     256  (abort (apply make-exn-oserr-condition loc msg code args)) )
    259257
    260258;;
     
    273271        `(,$let-location ((,stroutvar ,$unsigned-c-string*))
    274272           (,$$ void ,c-nam (location ,stroutvar) ,@args)
    275            ,stroutvar)))))
     273           ,stroutvar) ) ) ) )
    276274         
    277275(define-syntax bitwise-test?/foreign-mask
    278276  (syntax-rules ()
    279277    ((_ ?bits ?c-nam)
    280      (not (zero? (bitwise-and ?bits (foreign-value ?c-nam unsigned-integer32)))))))
     278     (not (zero? (bitwise-and ?bits (foreign-value ?c-nam unsigned-integer32)))) ) ) )
    281279
    282280;;
     
    302300                          con
    303301                          (bitwise-test?/foreign-mask bits "session_LoginCompleted")
    304                           (bitwise-test?/foreign-mask bits "session_UserIsActive")))))))))
    305 
    306 ;;
    307 
    308 (define (machine-name)
    309         ($/string:out#1 machine_name))
    310 
    311 (define (short-user-name)
    312         ($/string:out#1 short_user_name))
    313 
    314 (define (long-user-name)
    315         ($/string:out#1 long_user_name))
     302                          (bitwise-test?/foreign-mask bits "session_UserIsActive")) ) ) ) ) ) ) )
     303
     304;;
     305
     306(define (machine-name) ($/string:out#1 machine_name))
     307
     308(define (short-user-name) ($/string:out#1 short_user_name))
     309
     310(define (long-user-name) ($/string:out#1 long_user_name))
    316311
    317312(define (machine-location)
    318313        (let-location ((lat double) (lon double) (dls int) (gmt long))
    319314                ($ void machine_location #$lat #$lon #$dls #$gmt)
    320                 (vector lat lon dls gmt)))
    321 
    322 (define (metric?)
    323         ($ bool IsMetric))
    324 
    325 ;;
    326 
    327 (define (computer-name #!optional (store #f))
    328         ($/string:out#1 computer_name (c-pointer store)))
     315                (vector lat lon dls gmt) ) )
     316
     317(define (metric?) ($ bool IsMetric))
     318
     319;;
     320
     321(define (computer-name #!optional (store #f)) ($/string:out#1 computer_name (c-pointer store)))
    329322
    330323(define (console-user #!optional (store #f))
     
    332325          (let ((nam ($/string:out#1 console_user #$uid #$gid (c-pointer store))))
    333326            (and nam
    334                       (vector nam uid gid)))))
    335 
    336 (define (local-host-name #!optional (store #f))
    337         ($/string:out#1 local_host_name (c-pointer store)))
    338 
    339 (define (location-name #!optional (store #f))
    340         ($/string:out#1 location_name (c-pointer store)))
    341 
    342 ;;
    343 
    344 (define (main-bundle-path)
    345   ($/string:out#1 main_bundle_path))
    346 
    347 ;;
    348 
    349 (define (tick-count)
    350   ($ unsigned-integer32 TickCount))
     327                      (vector nam uid gid) ) ) ) )
     328
     329(define (local-host-name #!optional (store #f)) ($/string:out#1 local_host_name (c-pointer store)))
     330
     331(define (location-name #!optional (store #f)) ($/string:out#1 location_name (c-pointer store)))
     332
     333;;
     334
     335(define (main-bundle-path) ($/string:out#1 main_bundle_path))
     336
     337;;
     338
     339(define (tick-count) ($ unsigned-integer32 TickCount))
    351340
    352341(define (delay-for-ticks ticks)
    353342        (let-location ((fticks unsigned-long))
    354343    ($ void Delay (unsigned-long ticks) #$fticks)
    355     fticks))
     344    fticks ) )
    356345
    357346;;
     
    359348(define (gestalt sel)
    360349  (when (symbol? sel) (set! sel (symbol->string sel)))
    361   (when (string? sel) (set! sel ((foreign-lambda unsigned-integer32 "stringToOSType" c-string) sel)))
     350  (when (string? sel) (set! sel ($ unsigned-integer32 stringToOSType (nonnull-c-string sel))))
    362351  (##sys#check-number sel 'gestalt)
    363352        (let-location ((resp long))
    364353    (let ((err ($ short Gestalt (unsigned-integer32 sel) #$resp)))
    365354      (if (fx= 0 err) resp
    366           (oserr-error 'gestalt "Gestalt failed" err)))))
     355          (oserr-error 'gestalt "Gestalt failed" err) ) ) ) )
    367356
    368357) ;module macosx-env
  • release/4/macosx/trunk/macosx-url.scm

    r13588 r13844  
    3939(require-library dollar)
    4040
    41 (module macosx-url (;export
    42   open-url)
     41(module macosx-url (open-url)
    4342
    44 (import scheme chicken foreign)
    45 (import dollar)
     43(import scheme chicken foreign dollar)
    4644
    4745;;
  • release/4/macosx/trunk/tests/run.scm

    r13589 r13844  
    44(require-extension macosx-env)
    55(require-extension macosx-url)
     6
     7(define (print-info)
     8  (print "     session-info:  " (session-info))
     9  (print "     machine-name:  " (machine-name))
     10  (print "  short-user-name:  " (short-user-name))
     11  (print "   long-user-name:  " (long-user-name))
     12  (print " machine-location:  " (machine-location))
     13  (print "          metric?:  " (metric?))
     14  (print "    computer-name:  " (computer-name))
     15  (print "     console-user:  " (console-user))
     16  (print "  local-host-name:  " (local-host-name))
     17  (print "    location-name:  " (location-name))
     18  (print " main-bundle-path:  " (main-bundle-path))
     19  (print "       tick-count:  " (tick-count))
     20  (print "    gestalt 'addr:  " (gestalt 'addr)) )
     21
     22(define (delay-test ticks)
     23  (print* "* Delaying for " ticks " ticks ...")
     24  (delay-for-ticks ticks)
     25  (print " Done *")
     26  (newline) )
    627
    728(test-group "macosx-env"
     
    1132  (test-assert (long-user-name))
    1233  (test-assert (machine-location))
    13   #; ;works in 'csi' but as 'test-assert' causes "Illegal instruction"
    14   (test-assert (metric?))
     34  (test-assert (boolean? (metric?)))
    1535  (test-assert (computer-name))
    1636  (test-assert (console-user))
     
    1939  (test-assert (main-bundle-path))
    2040  (test-assert (tick-count))
    21   (delay-for-ticks 5)
    2241  (test-assert (gestalt 'addr))
    2342)
     43
     44(delay-test 50)
     45
     46(print-info)
    2447
    2548(test-group "macosx-url - should launch default browser with \"http://www.apple.com/\""
Note: See TracChangeset for help on using the changeset viewer.