examples/iOS/intf.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "intf.scm"
   4
   5 ;;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 (##namespace ("intf#"))
  10
  11 (##include "~~lib/gambit#.scm")
  12 (##include "~~lib/_gambit#.scm")
  13
  14 (##include "intf#.scm")
  15 (##include "url#.scm")
  16
  17 (declare
  18  (standard-bindings)
  19  (extended-bindings)
  20  (block)
  21  (fixnum)
  22  ;;(not safe)
  23 )
  24
  25
  26 ;;;============================================================================
  27
  28 ;; Interface with Objective-C.
  29
  30 (c-declare #<<c-declare-end
  31
  32 #include <objc/objc.h>
  33
  34 const char *class_getName(Class cls);
  35 id objc_getClass(const char *name);
  36 id objc_msgSend(id self, SEL op, ...);
  37
  38 id retain_id(id x)
  39 {
  40   if (x != nil)
  41     [x retain];
  42   return x;
  43 }
  44
  45 ___SCMOBJ release_id(void *ptr)
  46 {
  47   id x = ___CAST(id,ptr);
  48   if (x != nil)
  49     [x release];
  50   return ___FIX(___NO_ERR);
  51 }
  52
  53 Class retain_Class(Class x)
  54 {
  55   if (x != nil)
  56     [x retain];
  57   return x;
  58 }
  59
  60 ___SCMOBJ release_Class(void *ptr)
  61 {
  62   Class x = ___CAST(Class,ptr);
  63   if (x != nil)
  64     [x release];
  65   return ___FIX(___NO_ERR);
  66 }
  67
  68 c-declare-end
  69 )
  70
  71 (c-define-type id (pointer (struct "objc_object") (id Class) "release_id"))
  72 (c-define-type Class (pointer (struct "objc_class") (Class id) "release_Class"))
  73 (c-define-type SEL (pointer (struct "objc_selector") (SEL)))
  74
  75 (define string->Class
  76   (c-lambda (nonnull-char-string) Class
  77     "___result = retain_Class(objc_getClass(___arg1));"))
  78
  79 (define Class->string
  80   (c-lambda (Class) nonnull-char-string
  81     "___result = ___CAST(char*,class_getName(___arg1));")) ;;;TODO: remove cast
  82
  83 (define string->SEL
  84   (c-lambda (nonnull-UTF-8-string) SEL
  85     "___result = sel_registerName(___arg1);"))
  86
  87 (define SEL->string
  88   (c-lambda (SEL) nonnull-UTF-8-string
  89     "___result = ___CAST(char*,sel_getName(___arg1));")) ;;;TODO: remove cast
  90
  91 ;; Message sending (with 0, 1 and 2 parameters).
  92
  93 (define send0
  94   (c-lambda (id SEL) id
  95     "___result = retain_id(___CAST(id (*)(id, SEL),objc_msgSend)(___arg1, ___arg2));"))
  96
  97 (define send1
  98   (c-lambda (id SEL id) id
  99     "___result = retain_id(___CAST(id (*)(id, SEL, id),objc_msgSend)(___arg1, ___arg2, ___arg3));"))
 100
 101 (define send2
 102   (c-lambda (id SEL id id) id
 103     "___result = retain_id(___CAST(id (*)(id, SEL, id, id),objc_msgSend)(___arg1, ___arg2, ___arg3, ___arg4));"))
 104
 105 ;; Type conversions.
 106
 107 (define id->string
 108   (c-lambda (id) nonnull-UTF-8-string
 109     "___result = ___CAST(char*,[___CAST(NSString*,___arg1) UTF8String]);")) ;;;TODO: remove cast
 110
 111 (define string->id
 112   (c-lambda (nonnull-UTF-8-string) id
 113     "___result = retain_id([NSString stringWithUTF8String: ___arg1]);"))
 114
 115 (define id->bool
 116   (c-lambda (id) bool
 117     "___result = [___CAST(NSNumber*,___arg1) boolValue];"))
 118
 119 (define bool->id
 120   (c-lambda (bool) id
 121     "___result = retain_id([NSNumber numberWithBool:___arg1]);"))
 122
 123 (define id->int
 124   (c-lambda (id) int
 125     "___result = [___CAST(NSNumber*,___arg1) intValue];"))
 126
 127 (define int->id
 128   (c-lambda (int) id
 129     "___result = retain_id([NSNumber numberWithInt:___arg1]);"))
 130
 131 (define id->float
 132   (c-lambda (id) float
 133     "___result = [___CAST(NSNumber*,___arg1) floatValue];"))
 134
 135 (define float->id
 136   (c-lambda (float) id
 137     "___result = retain_id([NSNumber numberWithFloat:___arg1]);"))
 138
 139 (define id->double
 140   (c-lambda (id) double
 141     "___result = [___CAST(NSNumber*,___arg1) doubleValue];"))
 142
 143 (define double->id
 144   (c-lambda (double) id
 145     "___result = retain_id([NSNumber numberWithDouble:___arg1]);"))
 146
 147 ;;;----------------------------------------------------------------------------
 148
 149 ;; Implement conversions between NSString* and Scheme strings.
 150
 151 (c-declare #<<c-declare-end
 152
 153 #include <Foundation/NSString.h>
 154
 155 ___SCMOBJ SCMOBJ_to_NSStringSTAR(___SCMOBJ src, NSString **dst, int arg_num)
 156 {
 157   /*
 158    * Convert a Scheme string to NSString* .
 159    */
 160
 161   NSString *result;
 162   ___SCMOBJ ___temp;
 163
 164   if (src == ___FAL)
 165     result = nil;
 166   else if (!___STRINGP(src))
 167     return ___FIX(___STOC_WCHARSTRING_ERR+arg_num);
 168   else
 169     {
 170       int i;
 171       int len = ___INT(___STRINGLENGTH(src));
 172       unichar *buf = ___alloc_mem(sizeof(unichar)*len);
 173
 174       if (buf == 0)
 175         return ___FIX(___STOC_HEAP_OVERFLOW_ERR+arg_num);
 176
 177       for (i=0; i<len; i++)
 178         {
 179           ___UCS_4 c = ___INT(___STRINGREF(src,___FIX(i)));
 180           buf[i] = c;
 181         }
 182
 183       result = retain_id([NSString stringWithCharacters:buf length:len]);
 184
 185       ___free_mem(buf);
 186     }
 187
 188   *dst = result;
 189
 190   return ___FIX(___NO_ERR);
 191 }
 192
 193 ___SCMOBJ NSStringSTAR_to_SCMOBJ(NSString *src, ___SCMOBJ *dst, int arg_num)
 194 {
 195   ___SCMOBJ result;
 196
 197   if (src == nil)
 198     result = ___FAL;
 199   else
 200     {
 201       int i;
 202       int len = [src length];
 203
 204       result = ___alloc_scmobj(___sSTRING, len<<___LCS, ___STILL);
 205
 206       if (___FIXNUMP(result))
 207         return ___FIX(___CTOS_HEAP_OVERFLOW_ERR+arg_num);
 208
 209       for (i=0; i<len; i++)
 210         {
 211           ___UCS_4 c = [src characterAtIndex:i];
 212           ___STRINGSET(result,___FIX(i),___CHR(c))
 213         }
 214     }
 215
 216   *dst = result;
 217
 218   return ___FIX(___NO_ERR);
 219 }
 220
 221 #define ___BEGIN_CFUN_SCMOBJ_to_NSStringSTAR(src,dst,i) \
 222 if ((___err = SCMOBJ_to_NSStringSTAR(src, &dst, i)) == ___FIX(___NO_ERR)) {
 223 #define ___END_CFUN_SCMOBJ_to_NSStringSTAR(src,dst,i) }
 224
 225 #define ___BEGIN_CFUN_NSStringSTAR_to_SCMOBJ(src,dst) \
 226 if ((___err = NSStringSTAR_to_SCMOBJ(src, &dst, ___RETURN_POS)) == ___FIX(___NO_ERR)) {
 227 #define ___END_CFUN_NSStringSTAR_to_SCMOBJ(src,dst) \
 228 ___EXT(___release_scmobj)(dst); }
 229
 230 #define ___BEGIN_SFUN_NSStringSTAR_to_SCMOBJ(src,dst,i) \
 231 if ((___err = NSStringSTAR_to_SCMOBJ(src, &dst, i)) == ___FIX(___NO_ERR)) {
 232 #define ___END_SFUN_NSStringSTAR_to_SCMOBJ(src,dst,i) \
 233 ___EXT(___release_scmobj)(dst); }
 234
 235 #define ___BEGIN_SFUN_SCMOBJ_to_NSStringSTAR(src,dst) \
 236 { ___err = SCMOBJ_to_NSStringSTAR(src, &dst, ___RETURN_POS);
 237 #define ___END_SFUN_SCMOBJ_to_NSStringSTAR(src,dst) }
 238
 239 c-declare-end
 240 )
 241
 242 (c-define-type NSString* "NSString*"
 243   "NSStringSTAR_to_SCMOBJ"
 244   "SCMOBJ_to_NSStringSTAR"
 245   #t)
 246
 247 ;;;----------------------------------------------------------------------------
 248
 249 ;; Interface with NSDate Class.
 250
 251 (define NSDate      (string->Class "NSDate"))
 252 (define alloc       (string->SEL "alloc"))
 253 (define init        (string->SEL "init"))
 254 (define description (string->SEL "description"))
 255
 256 (define (date)
 257   (id->string
 258    (send0 (send0 (send0 NSDate alloc) init) description)))
 259
 260 ;;;----------------------------------------------------------------------------
 261
 262 ;; Interface with NSBundle Class.
 263
 264 (define NSBundle    (string->Class "NSBundle"))
 265 (define mainBundle  (string->SEL "mainBundle"))
 266 (define objectForInfoDictionaryKey (string->SEL "objectForInfoDictionaryKey:"))
 267
 268 (define (mainBundle-info key)
 269   (let ((info
 270          (send1 (send0 NSBundle mainBundle)
 271                 objectForInfoDictionaryKey (string->id key))))
 272     (and info
 273          (id->string info))))
 274
 275 (define CFBundleName (mainBundle-info "CFBundleName"))
 276 (define CFBundleDisplayName (mainBundle-info "CFBundleDisplayName"))
 277
 278 ;;;----------------------------------------------------------------------------
 279
 280 ;; Interface with UIDevice Class.
 281
 282 (define currentDevice-batteryLevel
 283   (c-lambda () float
 284     "___result = [[UIDevice currentDevice] batteryLevel];"))
 285
 286 (define currentDevice-batteryMonitoringEnabled
 287   (c-lambda () bool
 288     "___result = [UIDevice currentDevice].batteryMonitoringEnabled;"))
 289
 290 (define currentDevice-batteryMonitoringEnabled-set!
 291   (c-lambda (bool) void
 292     "[UIDevice currentDevice].batteryMonitoringEnabled = ___arg1;"))
 293
 294 (define currentDevice-multitaskingSupported
 295   (c-lambda () bool
 296     "___result = [UIDevice currentDevice].multitaskingSupported;"))
 297
 298 (define currentDevice-model
 299   (c-lambda () NSString*
 300     "___result = [[UIDevice currentDevice] model];"))
 301
 302 (define currentDevice-name
 303   (c-lambda () NSString*
 304     "___result = [[UIDevice currentDevice] name];"))
 305
 306 (define currentDevice-systemName
 307   (c-lambda () NSString*
 308     "___result = [[UIDevice currentDevice] systemName];"))
 309
 310 (define currentDevice-systemVersion
 311   (c-lambda () NSString*
 312     "___result = [[UIDevice currentDevice] systemVersion];"))
 313
 314 (define currentDevice-uniqueIdentifier
 315   (c-lambda () NSString*
 316     "___result = [[UIDevice currentDevice] uniqueIdentifier];"))
 317
 318 (define (device-status)
 319   (currentDevice-batteryMonitoringEnabled-set! #t)
 320   (list (currentDevice-batteryLevel)
 321         (currentDevice-batteryMonitoringEnabled)
 322         (currentDevice-multitaskingSupported)
 323         (currentDevice-model)
 324         (currentDevice-name)
 325         (currentDevice-systemName)
 326         (currentDevice-systemVersion)
 327         (currentDevice-uniqueIdentifier)))
 328
 329 (define (device-model)
 330   (let ((m (currentDevice-model)))
 331     (cond ((has-prefix? m "iPhone")
 332            'iPhone)
 333           ((has-prefix? m "iPod touch")
 334            'iPod-touch)
 335           ((has-prefix? m "iPad")
 336            'iPad)
 337           (else
 338            #f))))
 339
 340 (define (UDID)
 341   (currentDevice-uniqueIdentifier))
 342
 343
 344 ;;;----------------------------------------------------------------------------
 345
 346 ;; Interface with AudioToolbox.
 347
 348 (c-declare #<<c-declare-end
 349
 350 #import <AudioToolbox/AudioToolbox.h>
 351
 352 c-declare-end
 353 )
 354
 355 (c-define-type SystemSoundID unsigned-int32)
 356
 357 (define AudioServicesPlayAlertSound
 358   (c-lambda (SystemSoundID) void "AudioServicesPlayAlertSound"))
 359
 360 (define AudioServicesPlaySystemSound
 361   (c-lambda (SystemSoundID) void "AudioServicesPlaySystemSound"))
 362
 363 (define kSystemSoundID_FlashScreen        #x00000FFE)
 364 (define kSystemSoundID_Vibrate            #x00000FFF)
 365 (define kSystemSoundID_UserPreferredAlert #x00001000)
 366
 367 ;;;----------------------------------------------------------------------------
 368
 369 ;; Interface with ViewController.
 370
 371 (c-declare #<<c-declare-end
 372
 373 #include "ViewController.h"
 374
 375 c-declare-end
 376 )
 377
 378 ;; C functions callable from Scheme.
 379
 380 (define set-navigation
 381   (c-lambda (int) void "set_navigation"))
 382
 383 (define show-cancelButton
 384   (c-lambda () void "show_cancelButton"))
 385
 386 (define hide-cancelButton
 387   (c-lambda () void "hide_cancelButton"))
 388
 389 (define show-webView
 390   (c-lambda (int) void "show_webView"))
 391
 392 (define show-textView
 393   (c-lambda (int) void "show_textView"))
 394
 395 (define show-imageView
 396   (c-lambda (int) void "show_imageView"))
 397
 398 (define set-textView-font
 399   (c-lambda (int NSString* int) void "set_textView_font"))
 400
 401 (define set-textView-content
 402   (c-lambda (int NSString*) void "set_textView_content"))
 403
 404 (define get-textView-content
 405   (c-lambda (int) NSString* "get_textView_content"))
 406
 407 (define add-output-to-textView
 408   (c-lambda (int NSString*) void "add_output_to_textView"))
 409
 410 (define add-input-to-textView
 411   (c-lambda (int NSString*) void "add_input_to_textView"))
 412
 413 (define (set-webView-content view str #!optional (base-url-path #f) (enable-scaling #f) (mime-type "text/html"))
 414   ((c-lambda (int NSString* NSString* bool NSString*) void "set_webView_content") view str base-url-path enable-scaling mime-type))
 415
 416 (define (set-webView-content-from-file view path #!optional (base-url-path (path-directory path)) (enable-scaling #f) (mime-type "text/html"))
 417   ((c-lambda (int NSString* NSString* bool NSString*) void "set_webView_content_from_file") view path base-url-path enable-scaling mime-type))
 418
 419 (define eval-js-in-webView
 420   (c-lambda (int NSString*) NSString* "eval_js_in_webView"))
 421
 422 (define open-URL
 423   (c-lambda (NSString*) void "open_URL"))
 424
 425 (define set-idle-timer
 426   (c-lambda (bool) void "set_idle_timer"))
 427
 428 (define set-toolbar-alpha
 429   (c-lambda (double) void "set_toolbar_alpha"))
 430
 431 (define segm-ctrl-set-title
 432   (c-lambda (int NSString*) void "segm_ctrl_set_title"))
 433
 434 (define segm-ctrl-insert
 435   (c-lambda (int NSString*) void "segm_ctrl_insert"))
 436
 437 (define segm-ctrl-remove
 438   (c-lambda (int) void "segm_ctrl_remove"))
 439
 440 (define segm-ctrl-remove-all
 441   (c-lambda () void "segm_ctrl_remove_all"))
 442
 443 (define set-pref
 444   (c-lambda (NSString* NSString*) void "set_pref"))
 445
 446 (define get-pref
 447   (c-lambda (NSString*) NSString* "get_pref"))
 448
 449 (define set-pasteboard
 450   (c-lambda (NSString*) void "set_pasteboard"))
 451
 452 (define get-pasteboard
 453   (c-lambda () NSString* "get_pasteboard"))
 454
 455 (define popup-alert
 456   (c-lambda (NSString* NSString* NSString* NSString*) void "popup_alert"))
 457
 458 (define (setup-location-updates desired-accuracy #!optional (distance-filter 0.0))
 459   ((c-lambda (double double) void "setup_location_updates") desired-accuracy distance-filter))
 460
 461 (define (set-navigation-bar titles)
 462   (segm-ctrl-remove-all)
 463   (let loop ((i 0) (lst titles))
 464     (if (pair? lst)
 465         (begin
 466           (segm-ctrl-insert i (car lst))
 467           (loop (+ i 1) (cdr lst))))))
 468
 469 ;; Scheme functions callable from C.
 470
 471 (c-define (send-input str) (NSString*) void "send_input" "extern"
 472
 473   (let ((rp repl-port))
 474     (if (port? rp)
 475         (begin
 476           (display str rp)
 477           (force-output rp)))))
 478
 479 (c-define (send-event str) (NSString*) void "send_event" "extern"
 480
 481   (let ((ep event-port))
 482     (if (port? ep)
 483         (begin
 484           (write str ep)
 485           (force-output ep)))))
 486
 487 (c-define (send-key str) (NSString*) void "send_key" "extern"
 488
 489   (let ((hk handle-key))
 490     (if (procedure? hk)
 491         (hk str))))
 492
 493 (define handle-key #f)
 494
 495 (set! handle-key
 496   (lambda (str)
 497     (add-input-to-textView 0 str)))
 498
 499 (c-define (heartbeat) () double "heartbeat" "extern"
 500
 501   ;; make sure other threads get to run
 502   (##thread-heartbeat!)
 503
 504   ;; check if there has been any REPL output
 505   (let ((rp repl-port))
 506     (if (port? rp)
 507         (let ((output (read-line rp #f)))
 508           (if (string? output)
 509               (add-output-to-textView 0 output)))))
 510
 511   ;; return interval until next heartbeat
 512   (next-heartbeat-interval))
 513
 514 (define (next-heartbeat-interval)
 515
 516   (##declare (not interrupts-enabled))
 517
 518   (let* ((run-queue
 519           (macro-run-queue))
 520          (runnable-threads?
 521           (##not
 522            (let ((root (macro-btq-left run-queue)))
 523              (and (##not (##eq? root run-queue))
 524                   (##eq? (macro-btq-left root) run-queue)
 525                   (##eq? (macro-btq-right root) run-queue))))))
 526     (if runnable-threads?
 527
 528         (begin
 529           ;; There are other threads that can run, so request
 530           ;; to call "heartbeat" real soon to run those threads.
 531           interval-runnable)
 532
 533         (let* ((next-sleeper
 534                 (macro-toq-leftmost run-queue))
 535                (sleep-interval
 536                 (if (##eq? next-sleeper run-queue)
 537                     +inf.0
 538                     (begin
 539                       ;; There is a sleeping thread, so figure out in
 540                       ;; how much time it needs to wake up.
 541                       (##flonum.max
 542                        (##flonum.- (macro-thread-timeout next-sleeper)
 543                                    (##current-time-point))
 544                        interval-min-wait))))
 545                (next-condvar
 546                 (macro-btq-deq-next run-queue))
 547                (io-interval
 548                 (if (##eq? next-condvar run-queue)
 549                     interval-no-io-pending ;; I/O is not pending, just relax
 550                     interval-io-pending))) ;; I/O is pending, so come back soon
 551           (##flonum.min sleep-interval io-interval)))))
 552
 553 (define interval-runnable 0.0)
 554 (set! interval-runnable 0.0)
 555
 556 (define interval-io-pending 0.0)
 557 (set! interval-io-pending 0.02)
 558
 559 (define interval-no-io-pending 0.0)
 560 (set! interval-no-io-pending 1.0)
 561
 562 (define interval-min-wait 0.0)
 563 (set! interval-min-wait 0.0001)
 564
 565 (c-define (eval-string str) (NSString*) NSString* "eval_string" "extern"
 566   (let ()
 567
 568     (define (catch-all-errors thunk)
 569       (with-exception-catcher
 570        (lambda (exc)
 571          (write-to-string exc))
 572        thunk))
 573
 574     (define (write-to-string obj)
 575       (with-output-to-string
 576         ""
 577         (lambda () (write obj))))
 578
 579     (define (read-from-string str)
 580       (with-input-from-string str read))
 581
 582     (catch-all-errors
 583      (lambda () (write-to-string (eval (read-from-string str)))))))
 584
 585 ;;;----------------------------------------------------------------------------
 586
 587 ;; Setup pipe to do I/O on the REPL being run by the primordial thread.
 588
 589 (define repl-port #f)
 590
 591 (receive (i o) (open-string-pipe)
 592
 593   ;; Hack... set the names of the port.
 594   (##vector-set! i 4 (lambda (port) '(console)))
 595
 596   (set! ##stdio/console-repl-channel (##make-repl-channel-ports i i))
 597
 598   (set! repl-port o)
 599
 600   (input-port-timeout-set! o -inf.0))
 601
 602 ;;;----------------------------------------------------------------------------
 603
 604 ;; Handling of events from the webView.
 605
 606 (define event-port #f)
 607
 608 (define event-handler
 609   (lambda (event)
 610     ;; ignore event
 611     #f))
 612
 613 (define location-update-event-handler
 614   (lambda (event)
 615     ;; ignore event
 616     #f))
 617
 618 (receive (i o) (open-vector-pipe '(direction: input))
 619
 620   (set! event-port o)
 621
 622   (thread-start!
 623    (make-thread
 624     (lambda ()
 625       (let loop ()
 626         (let ((event (read i)))
 627           (if (not (eof-object? event))
 628               (let ((x (has-prefix? event "location-update:")))
 629                 (if x
 630                     (let ((location
 631                            (with-exception-catcher
 632                             (lambda (e)
 633                               #f)
 634                             (lambda ()
 635                               (list->vector (with-input-from-string x read-all))))))
 636                       (location-update-event-handler location))
 637                     (event-handler event))
 638                 (loop)))))))))
 639
 640 (define (set-event-handler proc)
 641   (set! event-handler (proc event-handler)))
 642
 643 (define (set-location-update-event-handler proc)
 644   (set! location-update-event-handler proc))
 645
 646 (define (show-view view)
 647   (show-webView view))
 648
 649 (define (set-view-content view content #!optional (base-url-path #f) (enable-scaling #f) (mime-type "text/html"))
 650   (set-webView-content
 651    view
 652    (with-output-to-string "" (lambda () (print content)))
 653    base-url-path
 654    enable-scaling
 655    mime-type))
 656
 657 (define (has-prefix? str prefix)
 658   (and (string? str)
 659        (string? prefix)
 660        (let ((len-str (string-length str))
 661              (len-prefix (string-length prefix)))
 662          (and (>= len-str len-prefix)
 663               (string=? (substring str 0 len-prefix) prefix)
 664               (substring str len-prefix len-str)))))
 665
 666 (define (get-event-parameters rest)
 667   (call-with-input-string
 668    rest
 669    (lambda (port)
 670      (map url-decode
 671           (read-all port (lambda (p) (read-line p #\:)))))))
 672
 673
 674 ;;;----------------------------------------------------------------------------
 675
 676 ;; Make it impossible to quit the application with a call to "exit" or
 677 ;; with a ",q" from the REPL.  This is needed to conform to the iOS
 678 ;; Developer Program License Agreement (I don't know which section
 679 ;; but I remember it had to do with the iOS human interface design).
 680
 681 (set! ##exit
 682       (lambda (#!optional (status 0))
 683         (error "To exit, press the sleep button for 5 seconds then the home button for 10 seconds")))
 684
 685
 686 ;;;----------------------------------------------------------------------------
 687
 688 ;; Make it impossible to access files outside of Gambit REPL.  This is
 689 ;; needed to conform to the iOS Developer Program License Agreement:
 690 ;;
 691 ;; 3.3.4 An Application may only read data from or write data to an
 692 ;; Application's designated container area on the device, except as
 693 ;; otherwise specified by Apple.
 694
 695 ;; The "~~" path will be equal to the app's bundle directory.  The app's
 696 ;; home directory is the directory containing the app's bundle directory.
 697
 698 (define app-home-dir
 699   (##path-normalize "~~/.."))
 700
 701 (define (contained-path-resolve path)
 702   (let loop ()
 703     (let ((str (##path-expand path)))
 704       (if (has-prefix? (##path-normalize str) app-home-dir)
 705           str ;; only allow files in app directory
 706           (begin
 707             (error "App container violation")
 708             (loop))))))
 709
 710 (set! ##path-resolve-hook contained-path-resolve)
 711
 712 ;; Make the current-directory and the "~" path equal to the app's
 713 ;; Documents directory.  This directory is backed-up by iTunes.
 714
 715 (set! ##os-path-homedir
 716       (c-lambda () NSString* "get_documents_dir"))
 717
 718 (current-directory "~")
 719
 720
 721 ;;;============================================================================