Skip to content
Browse files

Merge branch 'master' of http://www.iro.umontreal.ca/~gambit/repo/gambit



Conflicts:
	include/stamp.h
  • Loading branch information...
2 parents dbda5d7 + fd08700 commit 9ad3699511fdf9df9c4452e81b880112253f6f53 @feeley committed
View
6 examples/iOS/README
@@ -1,6 +1,6 @@
-This program implements the "Gambit REPL" application for iOS devices.
-It is a simple development environment for Scheme. The user can
-interact with a REPL, edit/save/run small scripts, and upload
+This program implements the "Gambit REPL dev" application for iOS
+devices. It is a simple development environment for Scheme. The user
+can interact with a REPL, edit/save/run small scripts, and upload
scripts to a public script repository.
This example was tested with iOS 4.3 and XCode 4.0 . If you do not have
View
474 examples/iOS/grd.scm
@@ -0,0 +1,474 @@
+#! /usr/bin/env gsi
+
+;;;============================================================================
+
+;;; File: "grd.scm"
+
+;;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
+
+;; This program allows remote interaction with the "Gambit REPL dev"
+;; app for iOS devices. The "Gambit REPL dev" app must have started a
+;; REPL server with the command:
+;;
+;; (repl-server #f)
+;;
+
+(define usage #<<EOF
+This program implements several commands:
+
+ grd scan list the Gambit REPL apps on the LAN
+ grd pwd get current directory
+ grd cd <remote_dir> change current directory
+ grd ls [<remote_dir>] list files in directory
+ grd mkdir <remote_dir> create directory
+ grd rm <remote_file> remove file or dir
+ grd eval <expr> evaluate expression
+ grd load <remote_file> load file
+ grd push <local_file> copy local file or dir to iOS device
+ grd pull <remote_file> copy remote file or dir locally
+ grd add-script <local_file> add a script to iOS device
+
+A specific "Gambit REPL dev" can be chosen by doing a "scan" or by
+using the option "-addr host:port". For example:
+
+ % ./grd scan
+ 192.168.0.100:7000 mega.local
+ 192.168.0.101:7000 My-iPhone
+ % ./grd eval "(host-name)"
+ "My-iPhone"
+ % ./grd -addr 192.168.0.100:7000 eval "(host-name)"
+ "mega.local"
+ % ./grd eval "(host-name)"
+ "mega.local"
+
+EOF
+)
+
+;;;============================================================================
+
+(define REPL-server-port-num 7000)
+
+;;-----------------------------------------------------------------------------
+
+(##include "digest.scm")
+(##include "genport.scm")
+(##include "zlib.scm")
+(##include "tar.scm")
+
+;;-----------------------------------------------------------------------------
+
+(##namespace (""))
+
+(##include "~~lib/gambit#.scm")
+
+(##include "digest#.scm")
+(##include "genport#.scm")
+(##include "zlib#.scm")
+(##include "tar#.scm")
+
+(declare
+ (standard-bindings)
+ (extended-bindings)
+ (block)
+ (generic)
+ (not safe)
+)
+
+;;-----------------------------------------------------------------------------
+
+;; Exception related utilities
+
+(define-macro (without-exception expr)
+ `(with-exception-catcher
+ (lambda (e) #f)
+ (lambda () ,expr)))
+
+(define-macro (try-catch expr catch)
+ `(with-exception-catcher
+ ,catch
+ (lambda () ,expr)))
+
+(define-macro (try-finally expr final)
+ (let ((f (gensym)) (r (gensym)))
+ `(let* ((,f (lambda () ,final))
+ (,r (with-exception-catcher
+ (lambda (e) (,f) (raise e))
+ (lambda () ,expr))))
+ (,f)
+ ,r)))
+
+;;-----------------------------------------------------------------------------
+
+;; Thread related utilities
+
+(define lock mutex-lock!)
+(define unlock mutex-unlock!)
+(define signal condition-variable-signal!)
+
+(define-macro (spawn expr)
+ `(thread-start!
+ (make-root-thread
+ (lambda () ,expr))))
+
+(define (halt)
+ (thread-terminate! (current-thread)))
+
+(define join thread-join!)
+(define sleep thread-sleep!)
+
+(define send thread-send)
+(define recv thread-receive)
+
+;;-----------------------------------------------------------------------------
+
+;; General purpose utilities
+
+(define (writeln obj #!optional (port (current-output-port)))
+ (write obj port)
+ (newline port)
+ (force-output port))
+
+(define (for lo hi proc)
+ (if (>= lo hi)
+ '()
+ (let ((x (proc lo)))
+ (cons x (for (+ lo 1) hi proc)))))
+
+(define (pfor lo hi proc)
+ (if (>= lo hi)
+ '()
+ (if (= lo (- hi 1))
+ (list (proc lo))
+ (let* ((mid (quotient (+ lo hi) 2))
+ (a (spawn (pfor lo mid proc)))
+ (b (pfor mid hi proc)))
+ (append (join a) b)))))
+
+(define (make-throttle concurrency-limit)
+ (let ((m (make-mutex))
+ (cv (make-condition-variable))
+ (n concurrency-limit))
+
+ (lambda (thunk)
+ (let wait ()
+ (lock m)
+ (if (= n 0)
+ (begin
+ (unlock m cv) ;; wait on cv
+ (wait))
+ (begin
+ (set! n (- n 1))
+ (unlock m)
+ (try-finally
+ (thunk)
+ (begin
+ (lock m)
+ (set! n (+ n 1))
+ (signal cv) ;; wake up next waiting thread
+ (unlock m)))))))))
+
+;;-----------------------------------------------------------------------------
+
+;; Networking related utilities
+
+(define (ip->num ip)
+
+ ;; (ip->num '#u8(127 0 0 1)) => 2130706433
+
+ (do ((i 0 (+ i 1))
+ (n 0 (+ (* 256 n) (u8vector-ref ip i))))
+ ((= i 4) n)))
+
+(define (num->ip num)
+
+ ;; (num->ip 2130706433) => #u8(127 0 0 1)
+
+ (let ((v (make-u8vector 4)))
+ (do ((i 3 (- i 1))
+ (n num (quotient n 256)))
+ ((< i 0) v)
+ (u8vector-set! v i (modulo n 256)))))
+
+(define (self-local-ip)
+
+ ;; (self-local-ip) => #u8(192 168 0 101)
+
+ (let* ((port (open-tcp-client
+ (list server-address: '#u8(73 125 226 48) ;; google.com
+ port-number: 80)))
+ (ip (socket-info-address
+ (tcp-client-self-socket-info port))))
+ (close-port port)
+ ip))
+
+;;-----------------------------------------------------------------------------
+
+(define (REPL-server-connect addr)
+ (let ((port
+ (without-exception
+ (open-tcp-client
+ (list server-address: addr
+ eol-encoding: 'cr-lf)))))
+ (and port
+ (try-catch
+ (begin
+ (input-port-timeout-set! port 2.0)
+ (let ((header (read port)))
+ (input-port-timeout-set! port +inf.0)
+ (if (equal? header 'Gambit)
+ (list port addr)
+ (begin
+ (close-port port)
+ #f))))
+ (lambda (e)
+ (without-exception (close-port port))
+ #f)))))
+
+(define (REPL-server-disconnect conn)
+ (with-exception-catcher
+ (lambda (e)
+ #f)
+ (lambda ()
+ (let ((port (car conn)))
+ (display ",qt\n" port)
+ (force-output port)
+ (thread-sleep! 0.5)
+ (close-port port)))))
+
+(define (REPL-server-eval conn expr)
+ (let ((port (car conn)))
+
+ (write `(let ((result (with-exception-catcher (lambda (e) (vector 'exception-was-raised "\n" (with-output-to-string "" (lambda () (display-exception e))))) (lambda () ,expr)))) (display "\n***RESULT***\n") (write result) (newline)) port)
+ (newline port)
+ (force-output port)
+
+ (let loop ()
+ (let ((x (read-line port)))
+ (if (string? x)
+ (if (string=? x "***RESULT***")
+ (let ((result (read port)))
+ (close-port port)
+ result)
+ (loop))
+ (vector 'exception-was-raised "\n" "REPL-server-eval failed"))))))
+
+(define (make-addr ip port-num)
+ (with-output-to-string
+ ""
+ (lambda ()
+ (print (u8vector-ref ip 0)
+ "."
+ (u8vector-ref ip 1)
+ "."
+ (u8vector-ref ip 2)
+ "."
+ (u8vector-ref ip 3)
+ ":"
+ (number->string port-num)))))
+
+(define (discover-local-REPL-servers ip port-num found)
+ (let* ((nm #xffffff00)
+ (throttle (make-throttle 100)))
+ (pfor 0
+ (- #xffffffff nm)
+ (lambda (i)
+ (throttle
+ (lambda ()
+ (check-for-REPL-server
+ (make-addr (num->ip (+ i (bitwise-and nm (ip->num ip))))
+ port-num)
+ found)))))))
+
+(define (check-for-REPL-server addr found)
+ (let ((conn (REPL-server-connect addr)))
+ (if conn
+ (found conn))
+ (sleep 0.5)))
+
+(define (scan-local-REPL-servers)
+ (discover-local-REPL-servers
+ (self-local-ip)
+ REPL-server-port-num
+ (lambda (conn)
+ (let* ((id (REPL-server-eval conn '(host-name)))
+ (addr (cadr conn)))
+ (print addr " " id "\n")
+ (save-default-addr addr)
+ (REPL-server-disconnect conn)))))
+
+;;-----------------------------------------------------------------------------
+
+(define (remote-eval addr expr)
+ (let ((conn (REPL-server-connect addr)))
+ (if (not conn)
+ (error "remote-eval could not connect to" addr)
+ (let ((result (REPL-server-eval conn expr)))
+ (REPL-server-disconnect conn)
+ result))))
+
+;;-----------------------------------------------------------------------------
+
+(define (grd-pwd #!key (addr (default-addr)))
+ (remote-eval addr `(current-directory)))
+
+(define (grd-cd path #!key (addr (default-addr)))
+ (remote-eval addr `(current-directory ,path)))
+
+(define (grd-ls path #!key (addr (default-addr)))
+ (remote-eval addr `(directory-files ,path)))
+
+(define (grd-mkdir path #!key (addr (default-addr)))
+ (remote-eval addr `(tar#create-dir ,path)))
+
+(define (grd-rm path #!key (addr (default-addr)))
+ (remote-eval addr `(tar#delete-file-recursive ,path)))
+
+(define (grd-eval expr #!key (addr (default-addr)))
+ (remote-eval addr expr))
+
+(define (grd-load filename #!key (addr (default-addr)))
+ (remote-eval addr `(load ,filename)))
+
+(define (grd-push filename #!key (addr (default-addr)))
+ (let ((u8vect (tar-pack-u8vector (tar-read filename) #t)))
+ (pp `(sending ,(u8vector-length u8vect) bytes))
+ (remote-eval addr `(tar#tar-write-unchecked
+ (tar#tar-unpack-u8vector ',u8vect #t)))))
+
+(define (grd-pull filename #!key (addr (default-addr)))
+ (let ((u8vect
+ (remote-eval addr `(tar#tar-pack-u8vector
+ (tar#tar-read ,filename)
+ #t))))
+ (pp `(received ,(u8vector-length u8vect) bytes))
+ (tar-write-unchecked
+ (tar-unpack-u8vector u8vect #t))))
+
+(define (grd-add-script filename #!key (addr (default-addr)))
+ (let ((script
+ (call-with-input-file filename (lambda (port) (read-line port #f)))))
+ (remote-eval addr `(let ((index (script#get-script-index-by-name ,filename)))
+ (and index (gr#delete-script-event index))
+ (script#add-script ,filename ,script)
+ (gr#set-edit-view)))))
+
+;;-----------------------------------------------------------------------------
+
+(define (default-addr)
+ (with-input-from-file "~/.grd.ini" (lambda () (read-line))))
+
+(define (save-default-addr addr)
+ (with-output-to-file "~/.grd.ini" (lambda () (println addr))))
+
+(define (main . args)
+
+ (define addr #f)
+
+ (let loop ((args args))
+ (if (not (pair? args))
+ (begin
+ (print usage)
+ (exit 1))
+ (let ((op (car args)))
+
+ (cond ((equal? op "-addr")
+ (if (not (pair? (cdr args)))
+ (error "address expected"))
+ (set! addr (cadr args))
+ (save-default-addr addr)
+ (loop (cddr args)))
+
+ ((equal? op "scan")
+ (scan-local-REPL-servers))
+
+ ((equal? op "pwd")
+ (println
+ (if addr
+ (grd-pwd addr: addr)
+ (grd-pwd))))
+
+ ((equal? op "cd")
+ (if (not (pair? (cdr args)))
+ (error "path expected"))
+ (let ((path (cadr args)))
+ (println
+ (if addr
+ (grd-cd path addr: addr)
+ (grd-cd path)))))
+
+ ((equal? op "ls")
+ (for-each
+ (lambda (path)
+ (let ((x (if addr
+ (grd-ls path addr: addr)
+ (grd-ls path))))
+ (if (list? x)
+ (for-each println x)
+ (println x))))
+ (if (pair? (cdr args)) (cdr args) '("."))))
+
+ ((equal? op "mkdir")
+ (for-each
+ (lambda (path)
+ (println
+ (if addr
+ (grd-mkdir path addr: addr)
+ (grd-mkdir path))))
+ (cdr args)))
+
+ ((equal? op "rm")
+ (for-each
+ (lambda (path)
+ (println
+ (if addr
+ (grd-rm path addr: addr)
+ (grd-rm path))))
+ (cdr args)))
+
+ ((equal? op "eval")
+ (for-each
+ (lambda (str)
+ (let ((expr (with-input-from-string str read)))
+ (pretty-print
+ (if addr
+ (grd-eval expr addr: addr)
+ (grd-eval expr)))))
+ (cdr args)))
+
+ ((equal? op "load")
+ (for-each
+ (lambda (filename)
+ (pretty-print
+ (if addr
+ (grd-load filename addr: addr)
+ (grd-load filename))))
+ (cdr args)))
+
+ ((equal? op "push")
+ (for-each
+ (lambda (filename)
+ (if addr
+ (grd-push filename addr: addr)
+ (grd-push filename)))
+ (cdr args)))
+
+ ((equal? op "pull")
+ (for-each
+ (lambda (filename)
+ (if addr
+ (grd-pull filename addr: addr)
+ (grd-pull filename)))
+ (cdr args)))
+
+ ((equal? op "add-script")
+ (for-each
+ (lambda (filename)
+ (if addr
+ (grd-add-script filename addr: addr)
+ (grd-add-script filename)))
+ (cdr args)))
+
+ (else
+ (error "unknown operation" op)))))))
+
+;;;============================================================================
View
8 examples/iOS/makefile.in
@@ -72,6 +72,7 @@ wiki.scm "wiki\#.scm" repl-server.scm "repl-server\#.scm" \
intf.scm "intf\#.scm" intf.h script.scm "script\#.scm" \
repo.scm "repo\#.scm" help.scm "help\#.scm" program.scm \
Prefix.pch main.m \
+grd.scm \
AppDelegate.m AppDelegate.h ViewController.m ViewController.h \
AccessoryView.xib MainWindow.xib ViewController.xib \
Icon-72.png Icon-Small-50.png Icon-Small.png Icon-Small@2x.png Icon-512.png \
@@ -104,7 +105,7 @@ all-pre:
all-post:
-examples: prepare-for-xcode
+examples: grd@exe@ prepare-for-xcode
gambit-iOS:
@echo "*************************************************************"
@@ -151,6 +152,9 @@ xcodeproj:
gzip -9 GambitREPL.xcodeproj.tar
mv GambitREPL.xcodeproj.tar.gz GambitREPL.xcodeproj.tgz
+grd@exe@: grd.scm
+ @SETDLPATH@ $(rootfromhere)/gsc/gsc -:~~bin=$(srcdirpfx)$(rootfromhere)/bin,~~lib=$(srcdirpfx)$(rootfromhere)/lib,~~include=$(srcdirpfx)$(rootfromhere)/include -f -o grd@exe@ -exe grd.scm
+
install-pre:
install-post: all
@@ -162,7 +166,7 @@ uninstall-post:
mostlyclean-pre:
mostlyclean-post:
- rm -f digest.m genport.m zlib.m tar.m json.m url.m html.m wiki.m repl-server.m intf.m script.m repo.m help.m program.m program_.m
+ rm -f digest.m genport.m zlib.m tar.m json.m url.m html.m wiki.m repl-server.m intf.m script.m repo.m help.m program.m program_.m grd@exe@
clean-pre: mostlyclean-pre
View
2 include/stamp.h
@@ -3,4 +3,4 @@
*/
#define ___STAMP_YMD 20120221
-#define ___STAMP_HMS 145739
+#define ___STAMP_HMS 150224
View
9 makefile.in
@@ -1,6 +1,6 @@
# makefile for Gambit-C system.
-# Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
+# Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
PACKAGE_SHORTNAME = @PACKAGE_SHORTNAME@
PACKAGE_NAME = @PACKAGE_NAME@
@@ -86,6 +86,11 @@ DISTFILES = $(RCFILES) $(GENDISTFILES)
GITDISTFILES = $(GITRCFILES)
HGDISTFILES = $(HGRCFILES)
+#BUILD_FARM = farm
+BUILD_FARM = localhost
+#BUILD_HOST = baro.iro.umontreal.ca
+BUILD_HOST = localhost
+
.SUFFIXES:
all:
@@ -110,7 +115,7 @@ examples: fake_target all
cd examples && $(MAKE) $(MDEFINES) $@
prebuilt: dist dist-devel
- PATH="gsi:$$PATH" prebuilt/remote-connect farm "" "(define tmpdir \"gambtmp0\")(define gambc-dist \"$(PACKAGE_TARNAME)\")(define timeout 600)(ssh timeout (string-append \"rm -rf \" tmpdir \";mkdir \" tmpdir \";echo 'logged in on:';hostname\"))(scp-to timeout (string-append gambc-dist \".tgz\") (string-append tmpdir \"/.\"))(ssh timeout (string-append \"ssh baro.iro.umontreal.ca 'cd \" tmpdir \";tar zxf \" gambc-dist \".tgz;cd \" gambc-dist \";./configure;make -j 4;mv ../\" gambc-dist \".tgz .;cd prebuilt;make prebuilt'\"))(scp-from timeout (string-append tmpdir \"/\" gambc-dist \"/$(PACKAGE_TARNAME)-*\") \".\")"
+ PATH="gsi:$$PATH" prebuilt/remote-connect $(BUILD_FARM) "" "(define tmpdir \"gambtmp0\")(define gambc-dist \"$(PACKAGE_TARNAME)\")(define timeout 600)(ssh timeout (string-append \"rm -rf \" tmpdir \";mkdir \" tmpdir \";echo 'logged in on:';hostname\"))(scp-to timeout (string-append gambc-dist \".tgz\") (string-append tmpdir \"/.\"))(ssh timeout (string-append \"ssh $(BUILD_HOST) 'cd \" tmpdir \";tar zxf \" gambc-dist \".tgz;cd \" gambc-dist \";./configure;make -j 4;mv ../\" gambc-dist \".tgz .;cd prebuilt;make prebuilt'\"))(scp-from timeout (string-append tmpdir \"/\" gambc-dist \"/$(PACKAGE_TARNAME)-*\") \".\")"
@# cd prebuilt && $(MAKE) $(MDEFINES) $@
stamp: fake_target
View
4 prebuilt/macosx/build-phase2.in
@@ -1,6 +1,6 @@
#! /bin/sh
-# Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
+# Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
herefromroot="prebuilt/macosx"
rootfromhere="../.."
@@ -51,7 +51,7 @@ install_gambc()
{
cd "$rootfromhere"
make clean
- make
+ make -j 2
make install
if [ "$RUN_TESTS" == "0" ] ; then
View
18 prebuilt/remote-connect
@@ -1,6 +1,6 @@
#! /usr/bin/env gsi
-;; Copyright (c) 2011 by Marc Feeley, All Rights Reserved.
+;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
;; This program allows execution of commands on a remote host. The
;; "remote host" may be a real computer or a VM running locally in
@@ -47,18 +47,19 @@
(if (and (equal? pw "") alias (>= (length alias) 4))
(cadddr alias)
pw))
- (if (equal? password "")
+ (if (equal? password "?")
(begin
(print "\nPassword for " username "@" hostname ": ")
(set! password (read-line))
- (print "\n")
- (if (equal? password "")
- (set! password #f))))
+ (print "\n")))
(set! ssh-port
(if (and alias (>= (length alias) 5))
(car (cddddr alias))
22))))
+ (if (equal? password "")
+ (set! password #f))
+
(end-vbox-vm vbox-vm)
(if (not (start-vbox-vm vbox-vm))
(err)
@@ -73,9 +74,10 @@
(define ssh-port #f)
(define host-aliases
- '(("macosx" "Snow-Leopard-x86-VM1")
- ("windows" "Windows-7-Ultimate-x86-VM1")
- ("farm" "frontal.iro.umontreal.ca" "gambit" "" 22)
+ '(("macosx" "Snow-Leopard-x86-VM1")
+ ("windows" "Windows-7-Ultimate-x86-VM1")
+ ("farm" "frontal.iro.umontreal.ca" "gambit" "?" 22)
+ ("localhost" "localhost")
))
;; Name of the VM and username, password and port to connect to the VM
View
4 prebuilt/windows/build-phase2.in
@@ -1,6 +1,6 @@
#! /bin/sh
-# Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
+# Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
herefromroot="prebuilt/windows"
rootfromhere="../.."
@@ -40,7 +40,7 @@ install_gambc()
{
cd "$rootfromhere"
make clean
- make
+ make -j 2
make install
if [ "$RUN_TESTS" == "0" ] ; then

0 comments on commit 9ad3699

Please sign in to comment.
Something went wrong with that request. Please try again.