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

Merge branch 'master', remote branch 'origin/master' into samth/new-logic2

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-04-22 16:55:44 -04:00
commit 35c0c28e40
43 changed files with 4129 additions and 337 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/drscheme/private/module-language-tools.ss
View File

@ -9,6 +9,9 @@
scheme/gui/base scheme/gui/base
"drsig.ss") "drsig.ss")
(define op (current-output-port))
(define (oprintf . args) (apply fprintf op args))
(define-unit module-language-tools@ (define-unit module-language-tools@
(import [prefix drscheme:unit: drscheme:unit^] (import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:module-language: drscheme:module-language^] [prefix drscheme:module-language: drscheme:module-language^]
@ -18,7 +21,7 @@
(define-local-member-name initialized? move-to-new-language) (define-local-member-name initialized? move-to-new-language)
(define-struct opt-out-toolbar-button (make-button id)) (define-struct opt-out-toolbar-button (make-button id) #:transparent)
(define opt-out-toolbar-buttons '()) (define opt-out-toolbar-buttons '())
(define (add-opt-out-toolbar-button make-button id) (define (add-opt-out-toolbar-button make-button id)
@ -98,18 +101,18 @@
(define/public (move-to-new-language) (define/public (move-to-new-language)
(let* ([port (open-input-text-editor this)] (let* ([port (open-input-text-editor this)]
;; info-result : (or/c #f [#lang without a known language]
;; (vector <get-info-proc>) [no #lang line, so we use the '#lang racket' info proc]
;; <get-info-proc> [the get-info proc for the program in the definitions]
[info-result (with-handlers ((exn:fail? (λ (x) #f))) [info-result (with-handlers ((exn:fail? (λ (x) #f)))
(parameterize ([current-reader-guard (read-language
(let ([old (current-reader-guard)]) port
(lambda (g) (lambda ()
(if (and (pair? g) ;; fall back to whatever #lang racket does if
(eq? (car g) 'planet)) ;; we don't have a #lang line present in the file
(error "#lang planet disbled") (vector (read-language (open-input-string "#lang racket"))))))])
(old g))))])
;; FIXME: do something so that we don't ; sometimes I get eof here, but I don't know why and can't seem to
;; have to disable all planet packages.
(read-language port (lambda () #f))))])
;; sometimes I get eof here, but I don't know why and can't seem to
;; make it happen outside of DrScheme ;; make it happen outside of DrScheme
(when (eof-object? info-result) (when (eof-object? info-result)
(fprintf (current-error-port) "file ~s produces eof from read-language\n" (fprintf (current-error-port) "file ~s produces eof from read-language\n"
@ -128,10 +131,18 @@
(contract (or/c #f (listof (list/c string? (contract (or/c #f (listof (list/c string?
(is-a?/c bitmap%) (is-a?/c bitmap%)
(-> (is-a?/c drscheme:unit:frame<%>) any)))) (-> (is-a?/c drscheme:unit:frame<%>) any))))
(info-result 'drscheme:toolbar-buttons #f) ((if (vector? info-result)
(get-lang-name pos) (vector-ref info-result 0)
info-result)
'drscheme:toolbar-buttons #f)
(if (vector? info-result)
'hash-lang-racket
(get-lang-name pos))
'drscheme/private/module-language-tools) 'drscheme/private/module-language-tools)
(info-result 'drscheme:opt-out-toolbar-buttons '()))))))) ((if (vector? info-result)
(vector-ref info-result 0)
info-result)
'drscheme:opt-out-toolbar-buttons '())))))))
(inherit get-tab) (inherit get-tab)

11
collects/drscheme/private/module-language.ss
View File

@ -63,15 +63,8 @@
(let* ([defs-port (open-input-text-editor defs-text)] (let* ([defs-port (open-input-text-editor defs-text)]
[read-successfully? [read-successfully?
(with-handlers ((exn:fail? (λ (x) #f))) (with-handlers ((exn:fail? (λ (x) #f)))
(let/ec k (read-language defs-port (λ () #f))
(let ([orig-security (current-security-guard)]) #t)])
(parameterize ([current-security-guard
(make-security-guard
orig-security
(lambda (what path modes) #t)
(lambda (what host port mode) (k #f)))])
(read-language defs-port (λ () (void)))
#t))))])
(cond (cond
[read-successfully? [read-successfully?
(let* ([str (send defs-text get-text 0 (file-position defs-port))] (let* ([str (send defs-text get-text 0 (file-position defs-port))]

6
collects/meta/drdr/analyze.ss
View File

@ -1,7 +1,7 @@
#lang scheme #lang scheme
(require scheme/file (require scheme/file
"diff.ss" "diff.ss"
"svn.ss" "scm.ss"
"list-count.ss" "list-count.ss"
"notify.ss" "notify.ss"
"cache.ss" "cache.ss"
@ -129,7 +129,7 @@
responsible)) responsible))
(define committer (define committer
(with-handlers ([exn:fail? (lambda (x) #f)]) (with-handlers ([exn:fail? (lambda (x) #f)])
(svn-rev-log-author (scm-commit-author
(read-cache* (read-cache*
(revision-commit-msg cur-rev))))) (revision-commit-msg cur-rev)))))
(define diff (define diff
@ -317,7 +317,7 @@
(or (or
(and committer? (and committer?
(with-handlers ([exn:fail? (lambda (x) #f)]) (with-handlers ([exn:fail? (lambda (x) #f)])
(svn-rev-log-author (read-cache (revision-commit-msg (current-rev)))))) (scm-commit-author (read-cache (revision-commit-msg (current-rev))))))
(or (path-responsible (trunk-path dir-pth)) (or (path-responsible (trunk-path dir-pth))
"unknown")) "unknown"))

6
collects/meta/drdr/config.ss
View File

@ -2,12 +2,12 @@
(require "cache.ss" (require "cache.ss"
"dirstruct.ss" "dirstruct.ss"
"svn.ss" "scm.ss"
"monitor-svn.ss") "monitor-scm.ss")
(plt-directory "/opt/plt") (plt-directory "/opt/plt")
(drdr-directory "/opt/svn/drdr") (drdr-directory "/opt/svn/drdr")
(svn-path "/usr/bin/svn") (git-path "/usr/bin/git")
(Xvfb-path "/usr/bin/Xvfb") (Xvfb-path "/usr/bin/Xvfb")
(current-make-install-timeout-seconds (* 60 60)) (current-make-install-timeout-seconds (* 60 60))
(current-make-timeout-seconds (* 60 60)) (current-make-timeout-seconds (* 60 60))

6
collects/meta/drdr/dirstruct.ss
View File

@ -31,8 +31,8 @@
(define fluxbox-path (define fluxbox-path
(make-parameter "/usr/bin/fluxbox")) (make-parameter "/usr/bin/fluxbox"))
(define plt-repository (define (plt-repository)
(make-parameter "http://svn.plt-scheme.org/plt/trunk")) (build-path (plt-directory) "repo"))
(define current-make-timeout-seconds (define current-make-timeout-seconds
(make-parameter (* 60 30))) (make-parameter (* 60 30)))
@ -96,7 +96,7 @@
[make-path (parameter/c string?)] [make-path (parameter/c string?)]
[Xvfb-path (parameter/c string?)] [Xvfb-path (parameter/c string?)]
[fluxbox-path (parameter/c string?)] [fluxbox-path (parameter/c string?)]
[plt-repository (parameter/c string?)] [plt-repository (-> path?)]
[path-timing-log (path-string? . -> . path?)] [path-timing-log (path-string? . -> . path?)]
[path-timing-png (path-string? . -> . path?)] [path-timing-png (path-string? . -> . path?)]
[path-timing-png-prefix (path-string? . -> . path?)] [path-timing-png-prefix (path-string? . -> . path?)]

18
collects/meta/drdr/main.ss
View File

@ -3,12 +3,12 @@
(require scheme/system (require scheme/system
"dirstruct.ss" "dirstruct.ss"
"analyze.ss" "analyze.ss"
"monitor-svn.ss" "monitor-scm.ss"
"notify.ss" "notify.ss"
"retry.ss" "retry.ss"
"config.ss" "config.ss"
"plt-build.ss" "plt-build.ss"
"svn.ss" "scm.ss"
"cache.ss" "cache.ss"
"path-utils.ss") "path-utils.ss")
@ -55,15 +55,15 @@
(notify! "Last revision is r~a" cur-rev) (notify! "Last revision is r~a" cur-rev)
(handle-revision prev-rev cur-rev) (handle-revision prev-rev cur-rev)
(notify! "Starting to monitor SVN @ r~a" cur-rev) (notify! "Starting to monitor @ r~a" cur-rev)
(monitor-svn (plt-repository) (monitor-scm (plt-repository)
cur-rev cur-rev
(lambda (newer) (lambda (newer)
(for ([l (in-list newer)]) (for ([rev (in-list newer)])
(write-cache! (future-record-path (svn-rev-log-num l)) l))) (write-cache! (future-record-path rev)
(lambda (prev-rev cur-rev _log) (get-scm-commit-msg rev (plt-repository)))))
(lambda (prev-rev cur-rev)
(handle-revision prev-rev cur-rev) (handle-revision prev-rev cur-rev)
; We have problems running for a long time so just restart after each rev ; We have problems running for a long time so just restart after each rev
(exit 0) (exit 0)))
))

16
collects/meta/drdr/metadata.ss
View File

@ -1,8 +1,7 @@
#lang scheme #lang scheme
(require "path-utils.ss" (require "path-utils.ss"
"dirstruct.ss" "dirstruct.ss"
"svn.ss" "scm.ss")
scheme/system)
(define (testable-file? pth) (define (testable-file? pth)
(define suffix (filename-extension pth)) (define suffix (filename-extension pth))
@ -51,15 +50,14 @@
(define props:get-prop (define props:get-prop
(hash-ref! props-cache rev (hash-ref! props-cache rev
(lambda () (lambda ()
(define tmp-file (make-temporary-file "props~a.ss")) (define tmp-file (make-temporary-file "props~a.ss" #f (current-temporary-directory)))
(and (and
; Checkout the props file ; Checkout the props file
(system* (svn-path) (scm-export
"export" rev
"--quiet" (plt-repository)
"-r" (number->string rev) "collects/meta/props"
(format "~a/collects/meta/props" (plt-repository)) tmp-file)
(path->string tmp-file))
; Dynamic require it ; Dynamic require it
(begin0 (begin0
(dynamic-require `(file ,(path->string tmp-file)) (dynamic-require `(file ,(path->string tmp-file))

28
collects/meta/drdr/monitor-svn.ss → collects/meta/drdr/monitor-scm.ss
View File

@ -1,30 +1,26 @@
#lang scheme #lang scheme
(require "svn.ss" (require "scm.ss"
"retry.ss") "retry.ss")
(define current-monitoring-interval-seconds (define current-monitoring-interval-seconds
(make-parameter 60)) (make-parameter 60))
(define (monitor-svn repos start-rev notify-newer! notify-user!) (define (monitor-scm repos start-rev notify-newer! notify-user!)
(define (monitor-w/o-wait prev-rev) (define (monitor-w/o-wait prev-rev)
(define all-logs (define new-revs
(svn-revision-logs-after prev-rev repos)) (scm-revisions-after prev-rev))
(define new-logs (match new-revs
(filter-not
(lambda (l) (= (svn-rev-log-num l) prev-rev))
all-logs))
(match new-logs
[(list) [(list)
; There has not yet been more revisions ; There has not yet been more revisions
(monitor prev-rev)] (monitor prev-rev)]
[(cons log newer) [(cons new-rev newer)
(define new-rev (svn-rev-log-num log)) (scm-update repos)
; Notify of newer ones ; Notify of newer ones
(notify-newer! newer) (notify-newer! newer)
; There was a commit that we care about. Notify, then recur ; There was a commit that we care about. Notify, then recur
(retry-until-success (retry-until-success
(format "Notifying of revision ~a" new-rev) (format "Notifying of revision ~a" new-rev)
(notify-user! prev-rev new-rev log)) (notify-user! prev-rev new-rev))
(monitor new-rev)])) (monitor new-rev)]))
(define (monitor prev-rev) (define (monitor prev-rev)
(sleep (current-monitoring-interval-seconds)) (sleep (current-monitoring-interval-seconds))
@ -34,8 +30,8 @@
(provide/contract (provide/contract
[current-monitoring-interval-seconds [current-monitoring-interval-seconds
(parameter/c exact-nonnegative-integer?)] (parameter/c exact-nonnegative-integer?)]
[monitor-svn [monitor-scm
(string? exact-nonnegative-integer? (path-string? exact-nonnegative-integer?
((listof svn-rev-log?) . -> . void) ((listof exact-nonnegative-integer?) . -> . void)
(exact-nonnegative-integer? exact-nonnegative-integer? svn-rev-log? . -> . void) (exact-nonnegative-integer? exact-nonnegative-integer? . -> . void)
. -> . any)]) . -> . any)])

4
collects/meta/drdr/path-utils.ss
View File

@ -1,6 +1,9 @@
#lang scheme #lang scheme
(require scheme/file) (require scheme/file)
(define current-temporary-directory
(make-parameter #f))
(define (directory-list->directory-list* l) (define (directory-list->directory-list* l)
(sort (filter-not (compose (sort (filter-not (compose
(lambda (s) (lambda (s)
@ -41,6 +44,7 @@
(path->string pth-string))) (path->string pth-string)))
(provide/contract (provide/contract
[current-temporary-directory (parameter/c (or/c false/c path-string?))]
[safely-delete-directory (path-string? . -> . void)] [safely-delete-directory (path-string? . -> . void)]
[directory-list->directory-list* ((listof path?) . -> . (listof path?))] [directory-list->directory-list* ((listof path?) . -> . (listof path?))]
[directory-list* (path-string? . -> . (listof path?))] [directory-list* (path-string? . -> . (listof path?))]

54
collects/meta/drdr/plt-build.ss
View File

@ -10,7 +10,7 @@
"notify.ss" "notify.ss"
"path-utils.ss" "path-utils.ss"
"sema.ss" "sema.ss"
"svn.ss") "scm.ss")
(define current-env (make-parameter (make-immutable-hash empty))) (define current-env (make-parameter (make-immutable-hash empty)))
(define-syntax-rule (with-env ([env-expr val-expr] ...) expr ...) (define-syntax-rule (with-env ([env-expr val-expr] ...) expr ...)
@ -43,18 +43,7 @@
(path->string co-dir))] (path->string co-dir))]
(notify! "Checking out ~a@~a into ~a" (notify! "Checking out ~a@~a into ~a"
repo rev to-dir) repo rev to-dir)
(run/collect/wait/log (scm-checkout rev repo to-dir))))
; XXX Give it its own timeout
#:timeout (current-make-install-timeout-seconds)
#:env (current-env)
(build-path log-dir "svn-checkout")
(svn-path)
(list
"checkout"
"--quiet"
"-r" (number->string rev)
repo
to-dir)))))
;; Make the build directory ;; Make the build directory
(make-directory* build-dir) (make-directory* build-dir)
;; Run Configure, Make, Make Install ;; Run Configure, Make, Make Install
@ -91,6 +80,20 @@
(define-syntax-rule (with-temporary-directory e) (define-syntax-rule (with-temporary-directory e)
(call-with-temporary-directory (lambda () e))) (call-with-temporary-directory (lambda () e)))
(define (call-with-temporary-home-directory thunk)
(define new-dir (make-temporary-file "home~a" 'directory (current-temporary-directory)))
(dynamic-wind
(lambda ()
(with-handlers ([exn:fail? void])
(copy-directory/files (hash-ref (current-env) "HOME") new-dir)))
(lambda ()
(with-env (["HOME" (path->string new-dir)])
(thunk)))
(lambda ()
(delete-directory/files new-dir))))
(define-syntax-rule (with-temporary-home-directory e)
(call-with-temporary-home-directory (lambda () e)))
(define (with-running-program command args thunk) (define (with-running-program command args thunk)
(define-values (new-command new-args) (define-values (new-command new-args)
(command+args+env->command+args (command+args+env->command+args
@ -196,14 +199,14 @@
test-workers test-workers
(lambda () (lambda ()
(define l (pth-cmd)) (define l (pth-cmd))
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))] (with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))])
["HOME" (make-fresh-home-dir)]) (with-temporary-home-directory
(with-temporary-directory (with-temporary-directory
(run/collect/wait/log log-pth (run/collect/wait/log log-pth
#:timeout pth-timeout #:timeout pth-timeout
#:env (current-env) #:env (current-env)
(first l) (first l)
(rest l)))) (rest l)))))
(semaphore-post dir-sema))) (semaphore-post dir-sema)))
(semaphore-post dir-sema))))))) (semaphore-post dir-sema)))))))
files) files)
@ -240,12 +243,6 @@
(notify! "Stopping testing") (notify! "Stopping testing")
(stop-job-queue! test-workers)) (stop-job-queue! test-workers))
(define (make-fresh-home-dir)
(define new-dir (make-temporary-file "home~a" 'directory))
(with-handlers ([exn:fail? void])
(copy-directory/files (hash-ref (current-env) "HOME") new-dir))
(path->string new-dir))
(define (recur-many i r f) (define (recur-many i r f)
(if (zero? i) (if (zero? i)
(f) (f)
@ -274,6 +271,7 @@
(make-directory* tmp-dir) (make-directory* tmp-dir)
; We are running inside of a test directory so that random files are stored there ; We are running inside of a test directory so that random files are stored there
(parameterize ([current-directory test-dir] (parameterize ([current-directory test-dir]
[current-temporary-directory tmp-dir]
[current-rev rev]) [current-rev rev])
(with-env (["PLTSTDERR" "error"] (with-env (["PLTSTDERR" "error"]
["TMPDIR" (path->string tmp-dir)] ["TMPDIR" (path->string tmp-dir)]
@ -285,7 +283,7 @@
["HOME" (path->string home-dir)]) ["HOME" (path->string home-dir)])
(unless (read-cache* (revision-commit-msg rev)) (unless (read-cache* (revision-commit-msg rev))
(write-cache! (revision-commit-msg rev) (write-cache! (revision-commit-msg rev)
(svn-revision-log rev (plt-repository)))) (get-scm-commit-msg rev (plt-repository))))
(build-revision rev) (build-revision rev)
(recur-many (number-of-cpus) (recur-many (number-of-cpus)
(lambda (j inner) (lambda (j inner)

196
collects/meta/drdr/render.ss
View File

@ -5,12 +5,11 @@
"config.ss" "config.ss"
"diff.ss" "diff.ss"
"list-count.ss" "list-count.ss"
"svn.ss"
"cache.ss" "cache.ss"
(except-in "dirstruct.ss" (except-in "dirstruct.ss"
revision-trunk-dir) revision-trunk-dir)
"status.ss" "status.ss"
"monitor-svn.ss" "monitor-scm.ss"
(only-in "metadata.ss" (only-in "metadata.ss"
PROP:command-line PROP:command-line
PROP:timeout) PROP:timeout)
@ -100,54 +99,101 @@
(define (svn-date->nice-date date) (define (svn-date->nice-date date)
(regexp-replace "^(....-..-..)T(..:..:..).*Z$" date "\\1 \\2")) (regexp-replace "^(....-..-..)T(..:..:..).*Z$" date "\\1 \\2"))
(define (git-date->nice-date date)
(regexp-replace "^(....-..-..) (..:..:..).*$" date "\\1 \\2"))
(define (format-commit-msg) (define (format-commit-msg)
(define pth (revision-commit-msg (current-rev))) (define pth (revision-commit-msg (current-rev)))
(define msg-v (read-cache* pth)) (define (timestamp pth)
(match msg-v (with-handlers ([exn:fail? (lambda (x) "")])
(date->string (seconds->date (read-cache (build-path (revision-dir (current-rev)) pth))) #t)))
(define bdate/s (timestamp "checkout-done"))
(define bdate/e (timestamp "integrated"))
(match (read-cache* pth)
[(struct git-push (num author commits))
`(table ([class "data"])
(tr ([class "author"]) (td "Author:") (td ,author))
(tr ([class "date"]) (td "Build Start:") (td ,bdate/s))
(tr ([class "date"]) (td "Build End:") (td ,bdate/e))
,@(append-map
(match-lambda
[(struct git-merge (hash author date msg from to))
`((tr ([class "hash"]) (td "Commit:") (td (a ([href ,(format "http://github.com/plt/racket/commit/~a" hash)]) ,hash)))
(tr ([class "date"]) (td "Date:") (td ,(git-date->nice-date date)))
(tr ([class "author"]) (td "Author:") (td ,author))
(tr ([class "msg"]) (td "Log:") (td (pre ,@msg)))
(tr ([class "merge"]) (td "Merge:") (td "From " ,from " to " ,to)))]
[(struct git-diff (hash author date msg mfiles))
(define cg-id (symbol->string (gensym 'changes)))
(define ccss-id (symbol->string (gensym 'changes)))
`((tr ([class "hash"]) (td "Commit:") (td (a ([href ,(format "http://github.com/plt/racket/commit/~a" hash)]) ,hash)))
(tr ([class "date"]) (td "Date:") (td ,(git-date->nice-date date)))
(tr ([class "author"]) (td "Author:") (td ,author))
(tr ([class "msg"]) (td "Log:") (td (pre ,@msg)))
(tr ([class "changes"])
(td
(a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" cg-id ccss-id)])
(span ([id ,cg-id]) 9658) "Changes:"))
(td
(div ([id ,ccss-id]
[style "display: none;"])
,@(for/list ([path (in-list mfiles)])
`(p ([class "output"])
,(if (regexp-match #rx"^collects" path)
(local [(define path-w/o-trunk
(apply build-path (explode-path path)))
(define html-path
(if (looks-like-directory? path)
(format "~a/" path-w/o-trunk)
path-w/o-trunk))
(define path-url
(path->string* html-path))
(define path-tested?
#t)]
(if path-tested?
`(a ([href ,path-url]) ,path)
path))
path)))))))])
commits))]
[(struct svn-rev-log (num author date msg changes)) [(struct svn-rev-log (num author date msg changes))
(define url (format "http://svn.plt-scheme.org/view?view=rev&revision=~a" num)) (define url (format "http://svn.plt-scheme.org/view?view=rev&revision=~a" num))
(define (timestamp pth)
(with-handlers ([exn:fail? (lambda (x) "")])
(date->string (seconds->date (read-cache (build-path (revision-dir (current-rev)) pth))) #t)))
(define bdate/s (timestamp "checkout-done"))
(define bdate/e (timestamp "integrated"))
(define cg-id (symbol->string (gensym 'changes))) (define cg-id (symbol->string (gensym 'changes)))
(define ccss-id (symbol->string (gensym 'changes))) (define ccss-id (symbol->string (gensym 'changes)))
`(table ([class "data"]) `(table ([class "data"])
(tr ([class "author"]) (td "Author:") (td ,author)) (tr ([class "author"]) (td "Author:") (td ,author))
(tr ([class "date"]) (td "Commit Date:") (td ,(svn-date->nice-date date))) (tr ([class "date"]) (td "Build Start:") (td ,bdate/s))
(tr ([class "date"]) (td "Build Start:") (td ,bdate/s)) (tr ([class "date"]) (td "Build End:") (td ,bdate/e))
(tr ([class "date"]) (td "Build End:") (td ,bdate/e)) (tr ([class "rev"]) (td "Commit:") (td (a ([href ,url]) ,(number->string num))))
(tr ([class "msg"]) (td "Log:") (td (pre ,msg))) (tr ([class "date"]) (td "Date:") (td ,(svn-date->nice-date date)))
(tr ([class "changes"]) (tr ([class "msg"]) (td "Log:") (td (pre ,msg)))
(td (tr ([class "changes"])
(a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" cg-id ccss-id)]) (td
(span ([id ,cg-id]) 9658) "Changes:")) (a ([href ,(format "javascript:TocviewToggle(\"~a\",\"~a\");" cg-id ccss-id)])
(td (span ([id ,cg-id]) 9658) "Changes:"))
(div ([id ,ccss-id] (td
[style "display: none;"]) (div ([id ,ccss-id]
,@(map (match-lambda [style "display: none;"])
[(struct svn-change (action path)) ,@(map (match-lambda
`(p ([class "output"]) [(struct svn-change (action path))
,(symbol->string action) " " `(p ([class "output"])
,(if (regexp-match #rx"^/trunk/collects" path) ,(symbol->string action) " "
(local [(define path-w/o-trunk ,(if (regexp-match #rx"^/trunk/collects" path)
(apply build-path (list-tail (explode-path path) 2))) (local [(define path-w/o-trunk
(define html-path (apply build-path (list-tail (explode-path path) 2)))
(if (looks-like-directory? path) (define html-path
(format "~a/" path-w/o-trunk) (if (looks-like-directory? path)
path-w/o-trunk)) (format "~a/" path-w/o-trunk)
(define path-url path-w/o-trunk))
(path->string* html-path)) (define path-url
(define path-tested? (path->string* html-path))
#t)] (define path-tested?
(if path-tested? #t)]
`(a ([href ,path-url]) ,path) (if path-tested?
path)) `(a ([href ,path-url]) ,path)
path))]) path))
changes)))) path))])
(tr (td nbsp) (td (a ([href ,url]) "View Commit"))))] changes)))))]
[else [else
'nbsp])) 'nbsp]))
@ -160,10 +206,6 @@
(br) (br)
"Current time: " ,(date->string (seconds->date (current-seconds)) #t))) "Current time: " ,(date->string (seconds->date (current-seconds)) #t)))
(define (revision-svn-url rev)
(format "http://svn.plt-scheme.org/view?view=rev&revision=~a"
rev))
(define (render-event e) (define (render-event e)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
@ -184,10 +226,16 @@
(define-values (title breadcrumb) (path->breadcrumb log-pth #f)) (define-values (title breadcrumb) (path->breadcrumb log-pth #f))
(define the-base-path (define the-base-path
(base-path log-pth)) (base-path log-pth))
(define svn-url (define scm-url
(format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a" (if ((current-rev) . < . 20000)
the-base-path (format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a"
(current-rev))) the-base-path
(current-rev))
(local [(define msg (read-cache* (revision-commit-msg (current-rev))))]
(if msg
(format "http://github.com/plt/racket/blob/~a~a"
(git-push-end-commit msg) the-base-path)
"#"))))
(define prev-rev-url (format "/~a~a" (previous-rev) the-base-path)) (define prev-rev-url (format "/~a~a" (previous-rev) the-base-path))
(define cur-rev-url (format "/~a~a" "current" the-base-path)) (define cur-rev-url (format "/~a~a" "current" the-base-path))
(define output (map render-event output-log)) (define output (map render-event output-log))
@ -208,7 +256,7 @@
(tr (td "Duration:") (td ,(format-duration-ms dur))) (tr (td "Duration:") (td ,(format-duration-ms dur)))
(tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity ""))) (tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity "")))
(tr (td "Exit Code:") (td ,(if (exit? log) (number->string (exit-code log)) ""))) (tr (td "Exit Code:") (td ,(if (exit? log) (number->string (exit-code log)) "")))
(tr (td nbsp) (td (a ([href ,svn-url]) "View File")))) (tr (td nbsp) (td (a ([href ,scm-url]) "View File"))))
,(if (lc-zero? changed) ,(if (lc-zero? changed)
"" ""
`(div ([class "error"]) `(div ([class "error"])
@ -269,8 +317,8 @@
(div ([class "dirlog, content"]) (div ([class "dirlog, content"])
,breadcrumb ,breadcrumb
,(if show-commit-msg? ,(if show-commit-msg?
(format-commit-msg) (format-commit-msg)
"") "")
,(local [(define (path->url pth) ,(local [(define (path->url pth)
(format "http://drdr.plt-scheme.org/~a~a" (current-rev) pth)) (format "http://drdr.plt-scheme.org/~a~a" (current-rev) pth))
@ -487,9 +535,27 @@
(if (eof-object? v) (if (eof-object? v)
"" v)) "" v))
(define log->committer+title
(match-lambda
[(struct git-push (num author commits))
(define lines (append-map git-commit-msg commits))
(define title
(if (empty? lines)
""
(first lines)))
(values author title)]
[(struct svn-rev-log (num author date msg changes))
(define commit-msg (string-first-line msg))
(define title
(format "~a - ~a"
(svn-date->nice-date date)
commit-msg))
(values author title)]))
(require web-server/servlet-env (require web-server/servlet-env
web-server/http web-server/http
web-server/dispatch) web-server/dispatch
"scm.ss")
(define how-many-revs 45) (define how-many-revs 45)
(define (show-revisions req) (define (show-revisions req)
(define builds-pth (plt-build-directory)) (define builds-pth (plt-build-directory))
@ -540,16 +606,14 @@
(define name (path->string rev-pth)) (define name (path->string rev-pth))
(define rev (string->number name)) (define rev (string->number name))
(define log (read-cache (future-record-path rev))) (define log (read-cache (future-record-path rev)))
(define committer (svn-rev-log-author log)) (define-values (committer title)
(define commit-msg (string-first-line (svn-rev-log-msg log))) (log->committer+title log))
(define title (define url
(format "~a - ~a" (format "http://github.com/plt/racket/commit/~a"
(svn-date->nice-date (svn-rev-log-date log)) (git-push-end-commit log)))
commit-msg))
`(tr ([class "dir"] `(tr ([class "dir"]
[title ,title]) [title ,title])
(td (a ([href ,(revision-svn-url name)]) ,name)) (td (a ([href ,url]) ,name))
(td ([class "building"] [colspan "6"]) (td ([class "building"] [colspan "6"])
"") "")
(td ([class "author"]) ,committer))] (td ([class "author"]) ,committer))]
@ -559,12 +623,8 @@
(define rev (string->number name)) (define rev (string->number name))
(define log-pth (revision-commit-msg rev)) (define log-pth (revision-commit-msg rev))
(define log (read-cache log-pth)) (define log (read-cache log-pth))
(define committer (svn-rev-log-author log)) (define-values (committer title)
(define commit-msg (string-first-line (svn-rev-log-msg log))) (log->committer+title log))
(define title
(format "~a - ~a"
(svn-date->nice-date (svn-rev-log-date log))
commit-msg))
(define (no-rendering-row) (define (no-rendering-row)
(define mtime (define mtime
(file-or-directory-modify-seconds log-pth)) (file-or-directory-modify-seconds log-pth))

189
collects/meta/drdr/scm.ss Normal file
View File

@ -0,0 +1,189 @@
#lang scheme
(require "svn.ss"
"path-utils.ss"
net/url
scheme/system)
(provide
(all-from-out "svn.ss"))
(define git-path (make-parameter "/opt/local/bin/git"))
(provide/contract
[git-path (parameter/c string?)])
(define git-url-base "http://git.racket-lang.org/plt.git")
(define (newest-push)
(string->number (port->string (get-pure-port (string->url (format "~a/push-counter" git-url-base))))))
(define (pad2zeros n)
(format "~a~a"
(if (n . < . 10)
"0" "")
(number->string n)))
(define-struct push-data (who end-commit branches) #:prefab)
(define (push-info push-n)
(define push-n100s (quotient push-n 100))
(define push-nrem (pad2zeros (modulo push-n 100)))
(define ls
(port->lines
(get-pure-port
(string->url
(format "~a/pushes/~a/~a" git-url-base push-n100s push-nrem)))))
(match ls
[(list (regexp #rx"^([^ ]+) +([0-9abcdef]+)$" (list _ who end-commit))
(regexp #rx"^([0-9abcdef]+) +([0-9abcdef]+) +(.+)$" (list _ bstart bend branch))
...)
(make-push-data who end-commit
(make-immutable-hash
(map (lambda (b bs be) (cons b (vector bs be)))
branch bstart bend)))]
[_
#f]))
(define (system/output-port #:k k #:stdout [init-stdout #f] . as)
(define _ (printf "~S~n" as))
(define-values (sp stdout stdin stderr)
(apply subprocess init-stdout #f #f as))
(begin0 (k stdout)
(subprocess-wait sp)))
(define-struct git-push (num author commits) #:prefab)
(define-struct git-commit (hash author date msg) #:prefab)
(define-struct (git-diff git-commit) (mfiles) #:prefab)
(define-struct (git-merge git-commit) (from to) #:prefab)
(define (read-until-empty-line in-p)
(let loop ()
(let ([l (read-line in-p)])
(cond
[(eof-object? l)
(close-input-port in-p)
empty]
[(string=? l "")
empty]
[else
(list* (regexp-replace #rx"^ +" l "") (loop))]))))
(define (read-commit in-p)
(match (read-line in-p)
[(? eof-object?)
#f]
[(regexp #rx"^commit +(.+)$" (list _ hash))
(match (read-line in-p)
[(regexp #rx"^Merge: +(.+) +(.+)$" (list _ from to))
(match-define (regexp #rx"^Author: +(.+)$" (list _ author)) (read-line in-p))
(match-define (regexp #rx"^Date: +(.+)$" (list _ date)) (read-line in-p))
(define _1 (read-line in-p))
(define msg (read-until-empty-line in-p))
(make-git-merge hash author date msg from to)]
[(regexp #rx"^Author: +(.+)$" (list _ author))
(match-define (regexp #rx"^Date: +(.+)$" (list _ date)) (read-line in-p))
(define _1 (read-line in-p))
(define msg (read-until-empty-line in-p))
(define mfiles (read-until-empty-line in-p))
(make-git-diff hash author date msg mfiles)])]))
(define port-empty? port-closed?)
(define (read-commits in-p)
(cond
[(port-empty? in-p)
empty]
[(read-commit in-p)
=> (lambda (c)
(printf "~S~n" c)
(list* c (read-commits in-p)))]
[else
empty]))
(define (parse-push num author in-p)
(make-git-push num author (read-commits in-p)))
(define (get-scm-commit-msg rev repo)
(match-define (struct push-data (who _ branches)) (push-info rev))
(match-define (vector start-commit end-commit) (hash-ref branches master-branch))
(parameterize ([current-directory repo])
(system/output-port
#:k (curry parse-push rev who)
(git-path)
"--no-pager" "log" "--date=iso" "--name-only"
(format "~a..~a" start-commit end-commit))))
(provide/contract
[struct git-push
([num exact-nonnegative-integer?]
[author string?]
[commits (listof git-commit?)])]
[struct git-commit
([hash string?]
[author string?]
[date string?]
[msg (listof string?)])]
[struct git-diff
([hash string?]
[author string?]
[date string?]
[msg (listof string?)]
[mfiles (listof string?)])]
[struct git-merge
([hash string?]
[author string?]
[date string?]
[msg (listof string?)]
[from string?]
[to string?])]
[get-scm-commit-msg (exact-nonnegative-integer? path-string? . -> . git-push?)])
(define (git-push-end-commit gp)
(git-commit-hash (first (git-push-commits gp))))
(provide/contract
[git-push-end-commit (git-push? . -> . string?)])
(define scm-commit-author
(match-lambda
[(? git-push? gp) (git-push-author gp)]
[(? svn-rev-log? srl) (svn-rev-log-author srl)]))
(provide/contract
[scm-commit-author ((or/c git-push? svn-rev-log?) . -> . string?)])
(define (scm-export rev repo file dest)
(define commit
(push-data-end-commit (push-info rev)))
(call-with-output-file*
dest
#:exists 'truncate/replace
(lambda (file-port)
(parameterize ([current-directory repo])
(system/output-port
#:k void
#:stdout file-port
(git-path) "--no-pager" "show" (format "~a:~a" commit file)))))
(void))
(define (scm-checkout rev repo dest)
(system* (git-path) "clone" (path->string* repo) (path->string* dest))
(parameterize ([current-directory dest])
(system* (git-path) "checkout" (push-data-end-commit (push-info rev))))
(void))
(define (scm-update repo)
(parameterize ([current-directory repo])
(system* (git-path) "fetch" git-url-base))
(void))
(define master-branch "refs/heads/master")
(define (scm-revisions-after cur-rev)
(define newest-rev (newest-push))
(for/list ([rev (in-range (add1 cur-rev) newest-rev)]
#:when
(let ([info (push-info rev)])
(and info (hash-has-key? (push-data-branches info) master-branch))))
rev))
(provide/contract
[scm-update (path? . -> . void?)]
[scm-revisions-after (exact-nonnegative-integer? . -> . (listof exact-nonnegative-integer?))]
[scm-export (exact-nonnegative-integer? path-string? string? path-string? . -> . void?)]
[scm-checkout (exact-nonnegative-integer? path-string? path-string? . -> . void?)])

119
collects/meta/drdr/svn.ss
View File

@ -1,130 +1,11 @@
#lang scheme #lang scheme
(require xml
"notify.ss")
(define svn-path
(make-parameter "/opt/local/bin/svn"))
;; Running SVN w/ XML parsing
(define (svn/xml-parse . in-args)
(define args
(list* "--xml" in-args))
(define-values
(the-process stdout stdin stderr)
(apply
subprocess
#f #f #f
(svn-path)
args))
#;(notify! "Parsing SVN XML output: ~a ~a" (svn-path) args)
(begin0
(dynamic-wind void
(lambda ()
(with-handlers ([exn:xml? (lambda (x) x)])
(parameterize ([collapse-whitespace #t]
[xexpr-drop-empty-attributes #t])
(xml->xexpr (document-element (read-xml stdout))))))
(lambda ()
(close-input-port stdout)))
(close-output-port stdin)
(close-input-port stderr)
(sync the-process
(handle-evt (alarm-evt (+ (current-inexact-milliseconds) (* 1000 2)))
(lambda (_)
(subprocess-kill the-process #t)
#f)))))
;;; Finding out about SVN revisions
(define-struct svn-rev () #:prefab) (define-struct svn-rev () #:prefab)
(define-struct (svn-rev-nolog svn-rev) () #:prefab) (define-struct (svn-rev-nolog svn-rev) () #:prefab)
(define-struct (svn-rev-log svn-rev) (num author date msg changes) #:prefab) (define-struct (svn-rev-log svn-rev) (num author date msg changes) #:prefab)
(define-struct svn-change (action path) #:prefab) (define-struct svn-change (action path) #:prefab)
(define (svn-revision-log-xml rev trunk)
(notify! "Getting log file for r~a in ~a" rev trunk)
(svn/xml-parse
"log"
"-r" rev
"-v"
#;"--with-all-revprops" ; v1.5
trunk))
(define parse-log-entry
(match-lambda
[`(logentry ((revision ,rev)) " "
(author ,author) " "
(date ,date) " "
(paths ,path ...)
" " (msg . ,msg) " ")
(make-svn-rev-log
(string->number rev)
author date (apply string-append msg)
(filter-map (match-lambda
[`(path ((action ,action) . ,any) ,file)
(make-svn-change (string->symbol action) file)]
[" "
#f])
path))]
[" " #f]))
(define parse-svn-log-xml
(match-lambda
[(? exn:fail? x)
(fprintf (current-error-port) "Error: ~a" (exn-message x))
#f]
[`(log " ")
(make-svn-rev-nolog)]
[`(log
" " ,le " ")
(parse-log-entry le)]))
(define (svn-revision-log rev trunk)
(define rev-string
(cond
[(number? rev) (number->string rev)]
[(symbol? rev)
(case rev
[(HEAD) "HEAD"])]))
(parse-svn-log-xml
(svn-revision-log-xml rev-string trunk)))
(define (svn-revision-logs-after-xml rev trunk)
(notify! "Getting logs for revision after r~a in ~a" rev trunk)
(svn/xml-parse
"log"
"-r" (format "~a:HEAD" rev)
"-v"
#;"--with-all-revprops" ; v1.5
trunk))
(define (parse-svn-logs-xml xexpr)
(match xexpr
[(? exn:fail? x)
(fprintf (current-error-port) "Error: ~a" (exn-message x))
empty]
[`(log " ")
empty]
[`(log . ,les)
(filter-map parse-log-entry les)]))
(define (svn-revision-logs-after rev trunk)
(parse-svn-logs-xml
(svn-revision-logs-after-xml rev trunk)))
(provide/contract (provide/contract
[svn-path (parameter/c string?)]
[svn-revision-log
((or/c exact-nonnegative-integer? (symbols 'HEAD))
string?
. -> .
(or/c false/c
svn-rev?))]
[svn-revision-logs-after
(exact-nonnegative-integer?
string?
. -> .
(listof svn-rev-log?))]
[struct svn-rev ()] [struct svn-rev ()]
[struct (svn-rev-nolog svn-rev) ()] [struct (svn-rev-nolog svn-rev) ()]
[struct (svn-rev-log svn-rev) [struct (svn-rev-log svn-rev)

45
collects/planet/lang/reader.ss
View File

@ -1,19 +1,30 @@
(module reader scheme/base #lang scheme/base
(require syntax/module-reader) (require syntax/module-reader
"../resolver.ss")
(provide (rename-out [planet-read read] (provide (rename-out [planet-read read]
[planet-read-syntax read-syntax] [planet-read-syntax read-syntax]
[planet-get-info get-info])) [planet-get-info get-info]))
(define (str->spec str)
(let ([str (bytes->string/latin-1 str)])
(if (module-path? `(planet ,(string->symbol str)))
`(planet ,(string->symbol (string-append str "/lang/reader")))
#f)))
(define-values (planet-read planet-read-syntax real-planet-get-info)
(make-meta-reader
'planet
"planet path"
str->spec
values
values
values))
(define op (current-output-port))
(define (planet-get-info inport module-path line col pos)
(parameterize ([install? #f]
[download? #f])
(real-planet-get-info inport module-path line col pos)))
(define-values (planet-read planet-read-syntax planet-get-info)
(make-meta-reader
'planet
"planet path"
(lambda (str)
(let ([str (bytes->string/latin-1 str)])
(if (module-path? `(planet ,(string->symbol str)))
`(planet ,(string->symbol (string-append str "/lang/reader")))
#f)))
values
values
values)))

28
collects/planet/planet.scrbl
View File

@ -463,6 +463,30 @@ The @schememodname[planet] module (as opposed to the reader used with
The planet collection provides configuration and utilities for using PLaneT. The planet collection provides configuration and utilities for using PLaneT.
@subsection{Resolver}
@defmodule[planet/resolver]
The primary purpose of this library to for @scheme[require] to find
@PLaneT packages. It also, however, provides some utilities for manipulating
the resolvers behavior.
@defproc[(resolve-planet-path [planet-path any/c]) path?]{
Returns the path where the file named by the require spec @scheme[planet-path] is located in the current installation.
}
@defparam[download? dl? boolean?]{
A parameter that controls if @PLaneT attempts to download a planet package that isn't already present.
If the package isn't present, the resolver will raise the @scheme[exn:fail:planet?] exception
instead of downloading it.
}
@defparam[install? inst? boolean?]{
A parameter that controls if @PLaneT attempts to install a planet package that isn't already installed.
If the package isn't installed, the resolver will raise the @scheme[exn:fail:planet?] exception
instead of installing it.
}
@subsection{Client Configuration} @subsection{Client Configuration}
@defmodule[planet/config] @defmodule[planet/config]
@ -659,6 +683,10 @@ context of a package. The others are convenience macros that
select out the relevant field, or return @scheme[#f] if the expression select out the relevant field, or return @scheme[#f] if the expression
appears outside the context of a PLaneT package.} appears outside the context of a PLaneT package.}
@defproc[(exn:fail:planet? [val any/c]) boolean?]{
Returns @scheme[#t] if @scheme[val] is
}
@subsection{Terse Status Updates} @subsection{Terse Status Updates}
@defmodule[planet/terse-info] @defmodule[planet/terse-info]

18
collects/planet/resolver.ss
View File

@ -212,10 +212,16 @@ subdirectory.
pkg-promise->pkg pkg-promise->pkg
install-pkg install-pkg
get-planet-module-path/pkg get-planet-module-path/pkg
install?) download?
install?
exn:fail:planet?
make-exn:fail:planet)
;; if #f, will not install packages and instead give an error ;; if #f, will not install packages and instead raise a exn:fail:install? error
(define install? (make-parameter #t)) (define install? (make-parameter #t))
;; if #f, will not download packages and instead raise a exn:fail:install? error
(define download? (make-parameter #t))
(define-struct (exn:fail:planet exn:fail) ())
;; update doc index only once for a set of installs: ;; update doc index only once for a set of installs:
(define planet-nested-install (make-parameter #f)) (define planet-nested-install (make-parameter #f))
@ -511,6 +517,12 @@ subdirectory.
(string-append "PLaneT could not download the requested package: " s)])) (string-append "PLaneT could not download the requested package: " s)]))
(define (download-package pkg) (define (download-package pkg)
(unless (download?)
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot download package ~s since the download? parameter is set to #f"
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg)))
(current-continuation-marks))))
((if (USE-HTTP-DOWNLOADS?) download-package/http download-package/planet) ((if (USE-HTTP-DOWNLOADS?) download-package/http download-package/planet)
pkg)) pkg))
@ -539,7 +551,7 @@ subdirectory.
;; installed file ;; installed file
(define (install-pkg pkg path maj min) (define (install-pkg pkg path maj min)
(unless (install?) (unless (install?)
(raise (make-exn:fail (raise (make-exn:fail:planet
(format (format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f" "PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min)) (list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min))

7
collects/planet/util.ss
View File

@ -41,12 +41,13 @@
unlink-all unlink-all
lookup-package-by-keys lookup-package-by-keys
resolve-planet-path resolve-planet-path
(struct-out exn:fail:planet)
display-plt-file-structure display-plt-file-structure
display-plt-archived-file display-plt-archived-file
get-package-from-cache get-package-from-cache
install-pkg install-pkg
pkg->download-url) pkg->download-url
exn:fail:planet?
make-exn:fail:planet)
(provide/contract (provide/contract
[get-package-spec [get-package-spec
@ -103,8 +104,6 @@
;; -- remove any existing linkage for package ;; -- remove any existing linkage for package
;; returns void if the removal worked; raises an exception if no package existed. ;; returns void if the removal worked; raises an exception if no package existed.
(define-struct (exn:fail:planet exn:fail) ())
(define (remove-pkg owner name maj min) (define (remove-pkg owner name maj min)
(let ((p (get-installed-package owner name maj min))) (let ((p (get-installed-package owner name maj min)))
(unless p (unless p

7
collects/schelog/COPYING Normal file
View File

@ -0,0 +1,7 @@
Copyright (c) 1993-2001, Dorai Sitaram.
All rights reserved.
Permission to distribute and use this work for any
purpose is hereby granted provided this copyright
notice is included in the copy. This work is provided
as is, with no warranty of any kind.

85
collects/schelog/INSTALL Normal file
View File

@ -0,0 +1,85 @@
Installing Schelog
*** JBC, 2010-04-22: I conjecture that (as a collection
within the PLT tree) installation directions are now
superfluous. The below is preserved for posterity.
-
First, obtain the Schelog distribution. This is
available at
http://www.ccs.neu.edu/~dorai/schelog/schelog.html
Gunzipping and untarring this file produces a directory
called "schelog". This directory contains, among other
subsidiary files:
the Schelog code file "schelog.scm";
the file INSTALL, which you are now reading.
-
The file schelog.scm in the distribution loads in
MzScheme (and some other Scheme dialects) without
configuration. If it does not load in your
dialect, you can configure Schelog for it using
the scmxlate package, which is available at
http://www.ccs.neu.edu/~dorai/scmxlate/scmxlate.html
Start your Scheme in the schelog directory, and load
the file scmxlate/scmxlate.scm , using the correct
relative or full pathname. You will be asked what your
Scheme dialect is. Answer appropriately. The
following symbols are used by the porting
mechanism to identify the corresponding Scheme
dialects: bigloo (Bigloo); gambit (Gambit); guile
(Guile); mitscheme (MIT Scheme); mzscheme (MzScheme);
petite (Petite Chez Scheme); pscheme (Pocket Scheme);
scm (SCM); stk (STk).
scmxlate will generate a file called
"my-schelog.scm", which you may rename to
"schelog.scm".
Load schelog.scm into your Scheme in order to use
Schelog.
The distribution comes with an "examples" subdirectory
containing some sample Schelog programs. In order to
try an example file, load it into your Scheme after
ensuring that "schelog.scm" has already been loaded.
Follow the instructions in the example file.
-
The file "schelog.tex" contains a tutorial on Schelog. Run it
through (plain) TeX to obtain viewable/printable
documentation. (You will need to run TeX twice to resolve
cross references.)
You can get a browsable version of the document by
calling
tex2page schelog.tex
This browsable version is also available for Web
viewing at
http://www.ccs.neu.edu/~dorai/schelog/schelog.html
tex2page is available at
http://www.ccs.neu.edu/~dorai/tex2page/tex2page-doc.html
-
Concise bug reports, questions, and suggestions
may be emailed to
ds26 at gte dot com

55
collects/schelog/README Normal file
View File

@ -0,0 +1,55 @@
README
Schelog
Dorai Sitaram
ds26@gte.com
*** JBC 2010-04-22: this package has been TAMPERED WITH in an unscrupulous and
undisciplined way by John Clements 2010-04-22 in order to see how difficult it
would be to get it to compile in PLT 4.2.5. The answer is "not hard", but it's
certainly not portable any more, and crucially the two macros that cause
capture of the ! symbol now require uses of the macro to supply the bang, thus
making them non-capturing.
TODO:
- pull some part of the docs across from their tex format
- figure out what to do with the makefile (delete it?)
- turn more of the implicit test cases into explicit test cases
- clean up this README file
- figure out whether there are copyright issues
...
Schelog is for you if you are interested in any or all
of the following: Scheme, Prolog, logic, logic
programming, AI, and expert systems.
Schelog is an embedding of logic programming a la
Prolog in Scheme. "Embedding" means you don't lose
Scheme: You can use Prolog-style and conventional
Scheme code fragments alongside each other. Schelog
contains the full repertoire of Prolog features,
including meta-logical and second-order ("set")
predicates, leaving out only those features that could
be more easily and more efficiently done with Scheme
subexpressions. The Schelog distribution includes
examples and comprehensive documentation.
Schelog has been tested successfully on the following
Scheme dialects:
Bigloo, Gambit, Guile, MIT Scheme, MzScheme, Petite
Chez Scheme, Pocket Scheme, SCM, and STk.
...
The Schelog distribution is available at the URL:
http://www.cs.rice.edu/CS/PLT/packages/schelog/
Unpacking (using gunzip and tar xf) the Schelog distribution
produces a directory called "schelog". In it is a file
called INSTALL which contains detailed installation
instructions. Read INSTALL now.

130
collects/schelog/examples/bible.rkt Normal file
View File

@ -0,0 +1,130 @@
#lang racket
(require "../schelog.rkt"
schemeunit)
;The following is the "Biblical" database from "The Art of
;Prolog", Sterling & Shapiro, ch. 1.
;(%father X Y) :- X is the father of Y.
(define %father
(%rel ! ()
(('terach 'abraham)) (('terach 'nachor)) (('terach 'haran))
(('abraham 'isaac)) (('haran 'lot)) (('haran 'milcah))
(('haran 'yiscah))))
;(%mother X Y) :- X is the mother of Y.
(define %mother
(%rel ! () (('sarah 'isaac))))
(define %male
(%rel ! ()
(('terach)) (('abraham)) (('isaac)) (('lot)) (('haran)) (('nachor))))
(define %female
(%rel ! ()
(('sarah)) (('milcah)) (('yiscah))))
;AoP, ch. 17. Finding all the children of a particular
;father. (%children F CC) :- CC is the list of children
;whose father is F. First approach: %children-1 uses an
;auxiliary predicate %children-aux, which uses an
;accumulator.
(define %children-1
(letrec ((children-aux
(%rel ! (x a cc c)
((x a cc)
(%father x c) (%not (%member c a)) !
(children-aux x (cons c a) cc))
((x cc cc)))))
(%rel ! (x cc)
((x cc) (children-aux x '() cc)))))
(define terachs-kids-test
;find all the children of Terach. Returns
;cc = (abraham nachor haran)
(lambda ()
(%which (cc)
(%children-1 'terach cc))))
(check-equal? (terachs-kids-test)
`((cc (haran nachor abraham))))
(define dad-kids-test
;find a father and all his children. Returns
;f = terach, cc = (haran nachor abraham).
;(%more) fails, showing flaw in %children-1.
;see AoP, ch. 17, p. 267
(lambda ()
(%which (f cc)
(%children-1 f cc))))
(check-equal? (dad-kids-test)
`((f terach) (cc (haran nachor abraham))))
(define terachs-kids-test-2
;find all the kids of Terach, using %set-of.
;returns kk = (abraham nachor haran)
(lambda ()
(%let (k)
(%which (kk)
(%set-of k (%father 'terach k) kk)))))
;This is a better definition of the %children predicate.
;Uses set predicate %bag-of
(define %children
(%rel ! (x kids c)
((kids) (%set-of c (%father x c) kids))))
(define dad-kids-test-2
;find each dad-kids combo.
;1st soln: dad = terach, kids = (abraham nachor haran)
;(%more) gives additional solutions.
(lambda ()
(%let (x)
(%which (dad kids)
(%set-of x (%free-vars (dad)
(%father dad x))
kids)))))
(define dad-kids-test-3
;looks like dad-kids-test-2, but dad is now
;existentially quantified. returns a set of
;kids (i.e., anything with a father)
(lambda ()
(%let (x)
(%which (dad kids)
(%set-of x (%father dad x)
kids)))))
(define dad-kids-test-4
;find the set of dad-kids.
;since dad is existentially quantified,
;this gives the wrong answer: it gives
;one set containing all the kids
(lambda ()
(%let (dad kids x)
(%which (dad-kids)
(%set-of (list dad kids)
(%set-of x (%father dad x) kids)
dad-kids)))))
(define dad-kids-test-5
;the correct solution. dad is
;identified as a free var.
;returns a set of dad-kids, one for
;each dad
(lambda ()
(%let (dad kids x)
(%which (dad-kids)
(%set-of (list dad kids)
(%set-of x (%free-vars (dad)
(%father dad x))
kids)
dad-kids)))))

57
collects/schelog/examples/england.rkt Normal file
View File

@ -0,0 +1,57 @@
#lang racket
(require "../schelog.rkt"
schemeunit)
;The following is a simple database about a certain family in England.
;Should be a piece of cake, but given here so that you can hone
;your ability to read the syntax.
;This file is written using `%rel' for a more Prolog-like syntax.
;The file england2.scm uses a Scheme-like syntax.
(define %male
(%rel ! ()
(('philip)) (('charles)) (('andrew)) (('edward))
(('mark)) (('william)) (('harry)) (('peter))))
(define %female
(%rel ! ()
(('elizabeth)) (('anne)) (('diana)) (('sarah)) (('zara))))
(define %husband-of
(%rel ! ()
(('philip 'elizabeth)) (('charles 'diana))
(('mark 'anne)) (('andrew 'sarah))))
(define %wife-of
(%rel ! (w h)
((w h) (%husband-of h w))))
(define %married-to
(%rel ! (x y)
((x y) (%husband-of x y))
((x y) (%wife-of x y))))
(define %father-of
(%rel ! ()
(('philip 'charles)) (('philip 'anne)) (('philip 'andrew))
(('philip 'edward)) (('charles 'william)) (('charles 'harry))
(('mark 'peter)) (('mark 'zara))))
(define %mother-of
(%rel ! (m c f)
((m c) (%wife-of m f) (%father-of f c))))
(define %child-of
(%rel ! (c p)
((c p) (%father-of p c))
((c p) (%mother-of p c))))
(define %parent-of
(%rel ! (p c)
((p c) (%child-of c p))))
(define %brother-of
(%rel ! (b x f)
((b x) (%male b) (%father-of f b) (%father-of f x) (%/= b x))))

78
collects/schelog/examples/england2.rkt Normal file
View File

@ -0,0 +1,78 @@
#lang racket
(require "../schelog.rkt")
;The following is a simple database about a certain family in England.
;Should be a piece of cake, but given here so that you can hone
;your ability to read the syntax.
;This file is written using goal combinations like %or, %and
;like you would use Scheme procedures. For a more Prolog-like
;syntax of the same program, see england.scm.
(define %male
(lambda (x)
(%or (%= x 'philip)
(%= x 'charles)
(%= x 'andrew)
(%= x 'edward)
(%= x 'mark)
(%= x 'william)
(%= x 'harry)
(%= x 'peter))))
(define %female
(lambda (x)
(%or (%= x 'elizabeth)
(%= x 'anne)
(%= x 'diana)
(%= x 'sarah)
(%= x 'zara))))
(define %husband-of
(lambda (h w)
(%or (%and (%= h 'philip) (%= w 'elizabeth))
(%and (%= h 'charles) (%= w 'diana))
(%and (%= h 'mark) (%= w 'anne))
(%and (%= h 'andrew) (%= w 'sarah)))))
(define %wife-of
(lambda (w h)
(%husband-of h w)))
(define %married-to
(lambda (x y)
(%or (%husband-of x y) (%wife-of x y))))
(define %father-of
(lambda (x y)
(%or (%and (%= x 'philip) (%= y 'charles))
(%and (%= x 'philip) (%= y 'anne))
(%and (%= x 'philip) (%= y 'andrew))
(%and (%= x 'philip) (%= y 'edward))
(%and (%= x 'charles) (%= y 'william))
(%and (%= x 'charles) (%= y 'harry))
(%and (%= x 'mark) (%= y 'peter))
(%and (%= x 'mark) (%= y 'zara)))))
(define %mother-of
(lambda (m c)
(%let (f)
(%and (%wife-of m f) (%father-of f c)))))
(define %child-of
(lambda (c p)
(%or (%father-of p c) (%mother-of p c))))
(define %parent-of
(lambda (p c)
(%child-of c p)))
(define %brother-of
(lambda (b x)
(%let (f)
(%and (%male b)
(%father-of f b)
(%father-of f x)
(%/= b x)))))

92
collects/schelog/examples/games.rkt Normal file
View File

@ -0,0 +1,92 @@
#lang scheme
(require "../schelog.rkt"
"./puzzle.rkt"
schemeunit)
;;This example is from Sterling & Shapiro, p. 214.
;;
;;The problem reads: Three friends came first, second and
;;third in a competition. Each had a different name, liked a
;;different sport, and had a different nationality. Michael
;;likes basketball, and did better than the American. Simon,
;;the Israeli, did better than the tennis player. The
;;cricket player came first. Who's the Australian? What
;;sport does Richard play?
(define person
;;a structure-builder for persons
(lambda (name country sport)
(list 'person name country sport)))
(define %games
(%rel ! (clues queries solution the-men
n1 n2 n3 c1 c2 c3 s1 s2 s3)
((clues queries solution)
(%= the-men
(list (person n1 c1 s1) (person n2 c2 s2) (person n3 c3 s3)))
(%games-clues the-men clues)
(%games-queries the-men queries solution))))
(define %games-clues
(%rel ! (the-men clue1-man1 clue1-man2 clue2-man1 clue2-man2 clue3-man)
((the-men
(list
(%did-better clue1-man1 clue1-man2 the-men)
(%name clue1-man1 'michael)
(%sport clue1-man1 'basketball)
(%country clue1-man2 'usa)
(%did-better clue2-man1 clue2-man2 the-men)
(%name clue2-man1 'simon)
(%country clue2-man1 'israel)
(%sport clue2-man2 'tennis)
(%first the-men clue3-man)
(%sport clue3-man 'cricket))))))
(define %games-queries
(%rel ! (the-men man1 man2 aussies-name dicks-sport)
((the-men
(list
(%member man1 the-men)
(%country man1 'australia)
(%name man1 aussies-name)
(%member man2 the-men)
(%name man2 'richard)
(%sport man2 dicks-sport))
(list
(list aussies-name 'is 'the 'australian)
(list 'richard 'plays dicks-sport))))))
(define %did-better
(%rel ! (a b c)
((a b (list a b c)))
((a c (list a b c)))
((b c (list a b c)))))
(define %name
(%rel ! (name country sport)
(((person name country sport) name))))
(define %country
(%rel ! (name country sport)
(((person name country sport) country))))
(define %sport
(%rel ! (name country sport)
(((person name country sport) sport))))
(define %first
(%rel ! (car cdr)
(((cons car cdr) car))))
;;With the above as the database, and also loading the file
;;puzzle.scm containing the puzzle solver, we merely need to
;;ask (solve-puzzle %games) to get the solution, which is
;;
;;((michael is the australian) (richard plays tennis))
(check-equal? (solve-puzzle %games)
'((solution= ((michael is the australian) (richard plays tennis)))))

40
collects/schelog/examples/holland.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket
(require "../schelog.rkt")
;This is a very trivial program. In Prolog, it would be:
;
; city(amsterdam).
; city(brussels).
; country(holland).
; country(belgium).
(define %city
(lambda (x)
(%or (%= x 'amsterdam)
(%= x 'brussels))))
(define %country
(lambda (x)
(%or (%= x 'holland)
(%= x 'belgium))))
;For a more Prolog-style syntax, you can rewrite the same thing,
;using the `%rel' macro, as the following:
'(define %city
(%rel ()
(('amsterdam))
(('brussels))))
'(define %country
(%rel ()
(('holland))
(('belgium))))
;Typical easy queries:
;
; (%which (x) (%city x)) succeeds twice
; (%which (x) (%country x)) succeeds twice
; (%which () (%city 'amsterdam)) succeeds
; (%which () (%country 'amsterdam)) fails

152
collects/schelog/examples/houses.rkt Normal file
View File

@ -0,0 +1,152 @@
#lang racket
(require "../schelog.rkt")
;Exercise 14.1 (iv) from Sterling & Shapiro, p. 217-8
;There are 5 houses, each of a different color and inhabited
;by a man of a different nationality, with a different pet,
;drink and cigarette choice.
;
;1. The Englishman lives in the red house
;2. The Spaniard owns the dog
;3. Coffee is drunk in the green house
;4. The Ukrainian drinks tea
;5. The green house is to the immediate right of the ivory house
;6. The Winston smoker owns snails
;7. Kools are smoked in the yellow house
;8. Milk is drunk in the middle house
;9. The Norwegian lives in the first house on the left
;10. The Chesterfield smoker lives next to the man with the fox
;11. Kools are smoked in the house adjacent to the horse's place
;12. The Lucky Strike smoker drinks orange juice
;13. The Japanese smokes Parliaments
;14. The Norwegian lives next to the blue house
;Who owns the zebra? Who drinks water?
(define house
(lambda (hue nation pet drink cigarette)
(list 'house hue nation pet drink cigarette)))
(define %hue (%rel ! (h) (((house h (_) (_) (_) (_)) h))))
(define %nation (%rel ! (n) (((house (_) n (_) (_) (_)) n))))
(define %pet (%rel ! (p) (((house (_) (_) p (_) (_)) p))))
(define %drink (%rel ! (d) (((house (_) (_) (_) d (_)) d))))
(define %cigarette (%rel ! (c) (((house (_) (_) (_) (_) c) c))))
(define %adjacent
(%rel ! (a b)
((a b (list a b (_) (_) (_))))
((a b (list (_) a b (_) (_))))
((a b (list (_) (_) a b (_))))
((a b (list (_) (_) (_) a b)))))
(define %middle
(%rel ! (a)
((a (list (_) (_) a (_) (_))))))
(define %houses
(%rel ! (row-of-houses clues queries solution
h1 h2 h3 h4 h5 n1 n2 n3 n4 n5 p1 p2 p3 p4 p5
d1 d2 d3 d4 d5 c1 c2 c3 c4 c5)
((clues queries solution)
(%= row-of-houses
(list
(house h1 n1 p1 d1 c1)
(house h2 n2 p2 d2 c2)
(house h3 n3 p3 d3 c3)
(house h4 n4 p4 d4 c4)
(house h5 n5 p5 d5 c5)))
(%houses-clues row-of-houses clues)
(%houses-queries row-of-houses queries solution))))
(define %houses-clues
(%rel ! (row-of-houses abode1 abode2 abode3 abode4 abode5 abode6 abode7
abode8 abode9 abode10 abode11 abode12 abode13 abode14 abode15)
((row-of-houses
(list
(%member abode1 row-of-houses)
(%nation abode1 'english)
(%hue abode1 'red)
(%member abode2 row-of-houses)
(%nation abode2 'spain)
(%pet abode2 'dog)
(%member abode3 row-of-houses)
(%drink abode3 'coffee)
(%hue abode3 'green)
(%member abode4 row-of-houses)
(%nation abode4 'ukraine)
(%drink abode4 'tea)
(%member abode5 row-of-houses)
(%adjacent abode5 abode3 row-of-houses)
(%hue abode5 'ivory)
(%member abode6 row-of-houses)
(%cigarette abode6 'winston)
(%pet abode6 'snail)
(%member abode7 row-of-houses)
(%cigarette abode7 'kool)
(%hue abode7 'yellow)
(%= (list (_) (_) abode8 (_) (_)) row-of-houses)
(%drink abode8 'milk)
(%= (list abode9 (_) (_) (_) (_)) row-of-houses)
(%nation abode9 'norway)
(%member abode10 row-of-houses)
(%member abode11 row-of-houses)
(%or (%adjacent abode10 abode11 row-of-houses)
(%adjacent abode11 abode10 row-of-houses))
(%cigarette abode10 'chesterfield)
(%pet abode11 'fox)
(%member abode12 row-of-houses)
(%or (%adjacent abode7 abode12 row-of-houses)
(%adjacent abode12 abode7 row-of-houses))
(%pet abode12 'horse)
(%member abode13 row-of-houses)
(%cigarette abode13 'lucky-strike)
(%drink abode13 'oj)
(%member abode14 row-of-houses)
(%nation abode14 'japan)
(%cigarette abode14 'parliament)
(%member abode15 row-of-houses)
(%or (%adjacent abode9 abode15 row-of-houses)
(%adjacent abode15 abode9 row-of-houses))
(%hue abode15 'blue))))))
(define %houses-queries
(%rel ! (row-of-houses abode1 abode2 zebra-owner water-drinker)
((row-of-houses
(list
(%member abode1 row-of-houses)
(%pet abode1 'zebra)
(%nation abode1 zebra-owner)
(%member abode2 row-of-houses)
(%drink abode2 'water)
(%nation abode2 water-drinker))
(list (list zebra-owner 'owns 'the 'zebra)
(list water-drinker 'drinks 'water))))))
;Load puzzle.scm and type (solve-puzzle %houses)
;Note: This program, as written, requires
;the occurs check. Make sure the global
;*schelog-use-occurs-check?* is set to #t before
;calling solve-puzzle. If not, you will get into
;an infinite loop.
;Note 2: Perhaps there is a way to rewrite the
;program so that it doesn't rely on the occurs check.

85
collects/schelog/examples/mapcol.rkt Normal file
View File

@ -0,0 +1,85 @@
#lang racket
(require (except-in "../schelog.rkt" %member))
;map coloring, example from Sterling & Shapiro, p. 212
;(%member x y) holds if x is in y
;; is this different from the %member provided by schelog? fencing that one out.
(define %member
(%rel ! (X Xs Y Ys)
((X (cons X Xs)))
((X (cons Y Ys)) (%member X Ys))))
;(%members x y) holds if x is a subset of y
(define %members
(%rel ! (X Xs Ys)
(((cons X Xs) Ys) (%member X Ys) (%members Xs Ys))
(('() Ys))))
;(%select x y z) holds if z is y with one less occurrence of x
(define %select
(%rel ! (X Xs Y Ys Zs)
((X (cons X Xs) Xs))
((X (cons Y Ys) (cons Y Zs))
(%select X Ys Zs))))
;region is a structure-builder
(define region
(lambda (name color neighbors)
(list 'region name color neighbors)))
(define %color-map
(%rel ! (Region Regions Colors)
(((cons Region Regions) Colors)
(%color-region Region Colors) (%color-map Regions Colors))
(('() Colors))))
(define %color-region
(%rel ! (Name Color Neighbors Colors Colors1)
(((region Name Color Neighbors) Colors)
(%select Color Colors Colors1)
(%members Neighbors Colors1))))
(define %test-color
(%rel ! (Name Map Colors)
((Name Map)
(%map Name Map)
(%colors Colors)
(%color-map Map Colors))))
(define %map
(%rel ! (A B C D E F G H I L P S)
(('test (list
(region 'a A (list B C D))
(region 'b B (list A C E))
(region 'c C (list A B D E F))
(region 'd D (list A C F))
(region 'e E (list B C F))
(region 'f F (list C D E)))))
(('western-europe
(list
(region 'portugal P (list E))
(region 'spain E (list F P))
(region 'france F (list E I S B G L))
(region 'belgium B (list F H L G))
(region 'holland H (list B G))
(region 'germany G (list F A S H B L))
(region 'luxembourg L (list F B G))
(region 'italy I (list F A S))
(region 'switzerland S (list F I A G))
(region 'austria A (list I S G)))))))
(define %colors
(%rel ! ()
(('(red yellow blue white)))))
;ask (%which (M) (%test-color 'test M)) or
;ask (%which (M) (%test-color 'western-europe M)) for the
;respective (non-unique) colorings.

47
collects/schelog/examples/puzzle.rkt Normal file
View File

@ -0,0 +1,47 @@
#lang scheme
(require "../schelog.rkt")
(provide (all-defined-out))
;This is the puzzle solver described in Sterling & Shapiro, p. 214
;As S & S say, it is a "trivial" piece of code
;that successively solves each clue and query, which are expressed
;as Prolog goals and are executed with the meta-variable facility.
;The code in "real" Prolog, for comparison, is:
;
; solve_puzzle(Clues, Queries, Solution)
; :- solve(Clues), solve(Queries).
;
; solve([Clue|Clues]) :- Clue, solve(Clues).
; solve([]).
(define %solve-puzzle
(%rel ! (clues queries solution)
((clues queries solution)
(%solve clues)
(%solve queries))))
(define %solve
(%rel ! (clue clues)
(((cons clue clues))
clue
(%solve clues))
(('()))))
;evaluate (solve-puzzle %puzzle) to get the solution to
;%puzzle. Here %puzzle is a relation that is defined to
;hold for the three arguments clues, queries and solution=,
;iff they satisfy the constraints imposed by the puzzle.
;solve-puzzle finds an (the?) instantiation for the solution=
;variable.
(define solve-puzzle
(lambda (%puzzle)
(%let (clues queries)
(%which (solution=)
(%and
(%puzzle clues queries solution=)
(%solve-puzzle clues queries solution=))))))

88
collects/schelog/examples/toys.rkt Normal file
View File

@ -0,0 +1,88 @@
#lang racket
(require (except-in "../schelog.rkt" %append))
;A list of trivial programs in Prolog, just so you can get used
;to schelog syntax.
;(%length l n) holds if length(l) = n
(define %length
(%rel ! (h t n m)
(('() 0))
(((cons h t) n) (%length t m) (%is n (+ m 1)))))
;(%delete x y z) holds if z is y with all x's removed
(define %delete
(%rel ! (x y z w)
((x '() '()))
((x (cons x w) y) (%delete x w y))
((x (cons z w) (cons z y)) (%not (%= x z)) (%delete x w y))))
;(%remdup x y) holds if y is x without duplicates
(define %remdup
(%rel ! (x y z w)
(('() '()))
(((cons x y) (cons x z)) (%delete x y w) (%remdup w z))))
;(%count x n) holds if n is the number of elements in x without
;counting duplicates
'(define %count
(%rel ! (x n y)
((x n) (%remdup x y) (%length y n))))
;same thing
(define %count
(letrec ((countaux
(%rel ! (m n m+1 x y z)
(('() m m))
(((cons x y) m n)
(%delete x y z) (%is m+1 (+ m 1)) (countaux z m+1 n)))))
(%rel ! (x n)
((x n) (countaux x 0 n)))))
;(%append x y z) holds if z is the concatenation of x and y
(define %append
(%rel ! (x y z w)
(('() x x))
(((cons x y) z (cons x w)) (%append y z w))))
;(%reverse x y) holds if the y is the reversal of x
'(define %reverse
(%rel ! (x y z yy)
(('() '()))
(((cons x y) z) (%reverse y yy) (%append yy (list x) z))))
;same thing, but tailcall optimizing
(define %reverse
(letrec ((revaux
(%rel ! (x y z w)
(('() y y))
(((cons x y) z w) (revaux y (cons x z) w)))))
(%rel ! (x y)
((x y) (revaux x '() y)))))
;(%fact n m) holds if m = n!
'(define %fact
(%rel ! (n n! n-1 n-1!)
((0 1))
((n n!) (%is n-1 (- n 1)) (%fact n-1 n-1!) (%is n! (* n n-1!)))))
;same thing, but tailcall optimizing
(define %fact
(letrec ((factaux
(%rel ! (n! m x m-1 xx)
((0 n! n!))
((m x n!) (%is m-1 (- m 1)) (%is xx (* x m))
(factaux m-1 xx n!)))))
(%rel ! (n n!)
((n n!) (factaux n 1 n!)))))

109
collects/schelog/history Normal file
View File

@ -0,0 +1,109 @@
June 1, 2003
Include Gauche as a target dialect. Alex Shinn
provided Gauche recognition to scmxlate (q.v.).
3h5
Mar 25, 2003
%assert documentation bugfix. From Steve Pothier.
3h4
15 Jul 2001
Added optional Occurs Check, suggested by Brad Lucier.
Brad also points out that the examples/houses.scm
puzzle, as written, needs the Occurs Check. ("as
written"...? Well, Prolog doesn't have the Occurs
Check, and this famous puzzle is offered as an exercise
in the Prolog textbook _The Art of Prolog_ (Sterling &
Shapiro). So I'm thinking perhaps there is a
less naive solution that doesn't rely on the Occurs
Check.)
3h3
Feb 28, 2000
Gambit port improvement from Brad Lucier: eval
define-macro explicitly to make macros usable after
loading
Sep 20, 1999
3h
Ported to Pocket Scheme (Ben Goetter) and Petite Chez Scheme.
Jan 31, 1999
3g1
Minor bugfix for Gambit install
May 2, 1998
3g
Ported to STk
April 19, 1998
3f
Porting mechanism refined: ports to mzscheme, scm,
guile, gambit, mitscheme, bigloo.
April 1997
3e
Extensible mechanism added for porting to various
Scheme dialects
3d
maybeini4gambit.scm (Brad Lucier)
Corrected () in evaluable positions to '(), as Gambit
won't accept unquoted ()s. (Brad Lucier)
3c
maybeini4mzscheme.scm.
Equal strings unify (Paul Prescod).
HTML version of doc included.
v. 3b
Fixed bug in %and and %or. (Using macros for now -- these were
procedures in v. 3, 3a.)
v. 3a
Added maybeini4mitscheme.scm (for Tore Amble).
March 1997
v. 3
Added syntax for asserting additional clauses to an existing
relation.
Set-predicates rewritten. (Free variables given choice of
treatment as in Prolog. Previously they had all been
assumed to be existentially quantified.)
Improved tutorial documentation.
Feb 1993
Second release.
1989
First release.

2
collects/schelog/info.ss Normal file
View File

@ -0,0 +1,2 @@
#lang setup/infotab

48
collects/schelog/makefile Normal file
View File

@ -0,0 +1,48 @@
# JBC, 2010-04-22:
# this makefile could probably be usefully rendered in scheme... but
# I'm not going to try.
TRIGGER_FILES = history manifest makefile version.tex \
schelog.scm schelog.tex
default:
@echo Please read the file INSTALL.
%.html: %.tex
tex2page $(@:%.html=%)
while grep -i "rerun: tex2page" $(@:%.html=%.hlog); do \
tex2page $(@:%.html=%); \
done
schelog.pdf: schelog.tex
pdftex $^
schelog.tar:
echo tar cf schelog.tar schelog/manifest > .tarscript
for f in `grep "^[^;]" manifest`; do \
echo tar uf schelog.tar schelog/$$f >> .tarscript; \
done
chmod +x .tarscript
cd ..; schelog/.tarscript
mv ../schelog.tar .
schelog.tar.bz2: $(TRIGGER_FILES)
make schelog.tar
bzip2 -f schelog.tar
schelog.tar.gz: $(TRIGGER_FILES)
make schelog.tar
gzip -f schelog.tar
html: schelog.html
pdf: schelog.pdf
dist: schelog.tar.bz2
webdist: schelog.tar.gz html
clean:
@rm -f *~ *.bak
cd dialects; rm -f *~ *.bak

20
collects/schelog/manifest Normal file
View File

@ -0,0 +1,20 @@
COPYING
README
manifest
makefile
schelog-version.tex
INSTALL
history
schelog.tex
schelog.scm
schelog.bib
dialects/*.scm
examples/bible.scm
examples/england.scm
examples/england2.scm
examples/games.scm
examples/holland.scm
examples/houses.scm
examples/mapcol.scm
examples/puzzle.scm
examples/toys.scm

1
collects/schelog/schelog-version.tex Normal file
View File

@ -0,0 +1 @@
2003-06-01% last change

95
collects/schelog/schelog.bib Normal file
View File

@ -0,0 +1,95 @@
@book{sicp,
author = "Harold Abelson and Gerald Jay {Sussman with Julie Sussman}",
title = "\urlp{Structure and Interpretation of
Computer Programs (``SICP'')}{http://mitpress.mit.edu/sicp/full-text/book/book.html}",
edition = "2nd",
publisher = "MIT Press",
year = 1996,
}
@book{aop,
author = "Leon Sterling and Ehud Shapiro",
title = "\urlh{http://mitpress.mit.edu/book-home.tcl?isbn=0262193388}{The Art
of Prolog}",
publisher = "MIT Press",
year = 1994,
edition = "2nd",
}
@book{tls,
author = "Daniel P Friedman and Matthias Felleisen",
title = "\urlh{http://www.ccs.neu.edu/~matthias/BTLS}{The Little Schemer}",
publisher = "MIT Press",
year = 1996,
edition = "4th",
}
@book{tss,
author = "Daniel P Friedman and Matthias Felleisen",
title = "\urlh{http://www.ccs.neu.edu/~matthias/BTSS}{The Seasoned Schemer}",
publisher = "MIT Press",
year = 1996,
}
@book{eopl,
author = "Daniel P Friedman and Mitchell Wand and Christopher T Haynes",
title = "\urlh{http://mitpress.mit.edu/book-home.tcl?isbn=0262061457}{Essentials
of Programming Languages}",
publisher = "MIT Press, McGraw-Hill",
year = 1992,
}
@book{bratko,
author = "Ivan Bratko",
title = "Prolog Programming for Artificial Intelligence",
publisher = "Addison-Wesley",
year = 1986,
}
@book{campbell,
editor = "J A Campbell",
title = "Implementations of Prolog",
publisher = "Ellis Horwood",
year = 1984,
}
@book{ok:prolog,
author = "Richard A O'Keefe",
title = "\urlh{http://mitpress.mit.edu/book-home.tcl?isbn=0262150395}{The
Craft of Prolog}",
publisher = "MIT Press",
year = 1990,
}
@inproceedings{logick,
author = "Christopher T Haynes",
title = "{Logic continuations}",
booktitle = "{J Logic Program}",
year = 1987,
note = "vol 4",
pages = "157--176",
}
@misc{r5rs,
author = "Richard Kelsey and William Clinger and
Jonathan {Rees (eds)}",
title = "\urlp{Revised\^{}5
Report on the Algorithmic Language Scheme
(``R5RS'')}{http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs.html}",
year = 1998,
}
@misc{t-y-scheme,
author = "Dorai Sitaram",
title = "\urlp{Teach Yourself Scheme
in Fixnum Days}{http://www.ccs.neu.edu/~dorai/t-y-scheme/t-y-scheme.html}",
}
@techreport{mf:prolog,
author = "Matthias Felleisen",
title = "{Transliterating Prolog into Scheme}",
institution = "{Indiana U Comp Sci Dept}",
year = 1985,
number = 182,
}

795
collects/schelog/schelog.rkt Normal file
View File

@ -0,0 +1,795 @@
#lang racket
;; TODO: figure out what should actually be 'provide'd.
(provide (all-defined-out))
;; A Note on changes: define-macro isn't so nice, but
;; someone (Dorai?) helpfully provided commented-out
;; versions of each macro in syntax-rules style.
;; Unfortunately, they didn't compile, but this seemed
;; related to an inability to capture the '!' name.
;; The easiest way to fix this was just to take the
;; classic "make 'em put the identifier in there" approach,
;; which means that uses of cut and rel must now include
;; a bang explicitly. It wouldn't be too hard to change
;; back to a capturing macro; I know syntax-case can do
;; it, I don't know if syntax-rules can.
;; Also, I changed a few top-level mutable bindings into
;; boxed bindings.
;;-- JBC, 2010-04-22
;MzScheme version of
;schelog.scm
;Schelog
;An embedding of Prolog in Scheme
;Dorai Sitaram
;1989, revised Feb. 1993, Mar. 1997
;logic variables and their manipulation
(define schelog:*ref* "ref")
(define schelog:*unbound* '_)
(define schelog:make-ref
;;makes a fresh unbound ref;
;;unbound refs point to themselves
(lambda opt
(vector schelog:*ref*
(if (null? opt) schelog:*unbound*
(car opt)))))
(define _ schelog:make-ref)
(define schelog:ref?
(lambda (r)
(and (vector? r)
(eq? (vector-ref r 0) schelog:*ref*))))
(define schelog:deref
(lambda (r)
(vector-ref r 1)))
(define schelog:set-ref!
(lambda (r v)
(vector-set! r 1 v)))
(define schelog:unbound-ref?
(lambda (r)
(eq? (schelog:deref r) schelog:*unbound*)))
(define schelog:unbind-ref!
(lambda (r)
(schelog:set-ref! r schelog:*unbound*)))
;frozen logic vars
(define schelog:*frozen* "frozen")
(define schelog:freeze-ref
(lambda (r)
(schelog:make-ref (vector schelog:*frozen* r))))
(define schelog:thaw-frozen-ref
(lambda (r)
(vector-ref (schelog:deref r) 1)))
(define schelog:frozen-ref?
(lambda (r)
(let ((r2 (schelog:deref r)))
(and (vector? r2)
(eq? (vector-ref r2 0) schelog:*frozen*)))))
;deref a structure completely (except the frozen ones, i.e.)
(define schelog:deref*
(lambda (s)
(cond ((schelog:ref? s)
(if (schelog:frozen-ref? s) s
(schelog:deref* (schelog:deref s))))
((pair? s) (cons (schelog:deref* (car s))
(schelog:deref* (cdr s))))
((vector? s)
(list->vector (map schelog:deref* (vector->list s))))
(else s))))
;%let introduces new logic variables
(define-syntax %let
(syntax-rules ()
((%let (x ...) . e)
(let ((x (schelog:make-ref)) ...)
. e))))
#;(define-macro %let
(lambda (xx . ee)
`(let ,(map (lambda (x) `(,x (schelog:make-ref))) xx)
,@ee)))
;the unify predicate
(define *schelog-use-occurs-check?* #f)
(define schelog:occurs-in?
(lambda (var term)
(and *schelog-use-occurs-check?*
(let loop ((term term))
(cond ((eqv? var term) #t)
((schelog:ref? term)
(cond ((schelog:unbound-ref? term) #f)
((schelog:frozen-ref? term) #f)
(else (loop (schelog:deref term)))))
((pair? term)
(or (loop (car term)) (loop (cdr term))))
((vector? term)
(loop (vector->list term)))
(else #f))))))
(define schelog:unify
(lambda (t1 t2)
(lambda (fk)
(letrec
((cleanup-n-fail
(lambda (s)
(for-each schelog:unbind-ref! s)
(fk 'fail)))
(unify1
(lambda (t1 t2 s)
;(printf "unify1 ~s ~s~%" t1 t2)
(cond ((eqv? t1 t2) s)
((schelog:ref? t1)
(cond ((schelog:unbound-ref? t1)
(cond ((schelog:occurs-in? t1 t2)
(cleanup-n-fail s))
(else
(schelog:set-ref! t1 t2)
(cons t1 s))))
((schelog:frozen-ref? t1)
(cond ((schelog:ref? t2)
(cond ((schelog:unbound-ref? t2)
;(printf "t2 is unbound~%")
(unify1 t2 t1 s))
((schelog:frozen-ref? t2)
(cleanup-n-fail s))
(else
(unify1 t1 (schelog:deref t2) s))))
(else (cleanup-n-fail s))))
(else
;(printf "derefing t1~%")
(unify1 (schelog:deref t1) t2 s))))
((schelog:ref? t2) (unify1 t2 t1 s))
((and (pair? t1) (pair? t2))
(unify1 (cdr t1) (cdr t2)
(unify1 (car t1) (car t2) s)))
((and (string? t1) (string? t2))
(if (string=? t1 t2) s
(cleanup-n-fail s)))
((and (vector? t1) (vector? t2))
(unify1 (vector->list t1)
(vector->list t2) s))
(else
(for-each schelog:unbind-ref! s)
(fk 'fail))))))
(let ((s (unify1 t1 t2 '())))
(lambda (d)
(cleanup-n-fail s)))))))
(define %= schelog:unify)
;disjunction
(define-syntax %or
(syntax-rules ()
((%or g ...)
(lambda (__fk)
(call-with-current-continuation
(lambda (__sk)
(call-with-current-continuation
(lambda (__fk)
(__sk ((schelog:deref* g) __fk))))
...
(__fk 'fail)))))))
#;(define-macro %or
(lambda gg
`(lambda (__fk)
(call-with-current-continuation
(lambda (__sk)
,@(map (lambda (g)
`(call-with-current-continuation
(lambda (__fk)
(__sk ((schelog:deref* ,g) __fk)))))
gg)
(__fk 'fail))))))
;conjunction
(define-syntax %and
(syntax-rules ()
((%and g ...)
(lambda (__fk)
(let* ((__fk ((schelog:deref* g) __fk))
...)
__fk)))))
#;(define-macro %and
(lambda gg
`(lambda (__fk)
(let* ,(map (lambda (g) `(__fk ((schelog:deref* ,g) __fk))) gg)
__fk))))
;cut
;; rather arbitrarily made this macro non-
;; capturing by requiring ! to be supplied at
;; macro use... not changing docs... -- JBC 2010
(define-syntax %cut-delimiter
(syntax-rules ()
((%cut-delimiter ! g)
(lambda (__fk)
(let ((! (lambda (__fk2) __fk)))
((schelog:deref* g) __fk))))))
#;(define-macro %cut-delimiter
(lambda (g)
`(lambda (__fk)
(let ((! (lambda (__fk2) __fk)))
((schelog:deref* ,g) __fk)))))
;Prolog-like sugar
(define-syntax %rel
(syntax-rules ()
((%rel ! (v ...) ((a ...) subgoal ...) ...)
(lambda __fmls
(lambda (__fk)
(call-with-current-continuation
(lambda (__sk)
(let ((! (lambda (fk1) __fk)))
(%let (v ...)
(call-with-current-continuation
(lambda (__fk)
(let* ((__fk ((%= __fmls (list a ...)) __fk))
(__fk ((schelog:deref* subgoal) __fk))
...)
(__sk __fk))))
...
(__fk 'fail))))))))))
#;(define-macro %rel
(lambda (vv . cc)
`(lambda __fmls
(lambda (__fk)
(call-with-current-continuation
(lambda (__sk)
(let ((! (lambda (fk1) __fk)))
(%let ,vv
,@(map (lambda (c)
`(call-with-current-continuation
(lambda (__fk)
(let* ((__fk ((%= __fmls (list ,@(car c)))
__fk))
,@(map (lambda (sg)
`(__fk ((schelog:deref* ,sg)
__fk)))
(cdr c)))
(__sk __fk)))))
cc)
(__fk 'fail)))))))))
;the fail and true preds
(define %fail
(lambda (fk) (fk 'fail)))
(define %true
(lambda (fk) fk))
;for structures ("functors"), use Scheme's list and vector
;functions and anything that's built using them.
;arithmetic
(define-syntax %is
(syntax-rules (quote)
((%is v e)
(lambda (__fk)
((%= v (%is (1) e __fk)) __fk)))
((%is (1) (quote x) fk) (quote x))
((%is (1) (x ...) fk)
((%is (1) x fk) ...))
((%is (1) x fk)
(if (and (schelog:ref? x) (schelog:unbound-ref? x))
(fk 'fail) (schelog:deref* x)))))
#;(define-macro %is
(lambda (v e)
(letrec ((%is-help (lambda (e fk)
(cond ((pair? e)
(cond ((eq? (car e) 'quote) e)
(else
(map (lambda (e1)
(%is-help e1 fk)) e))))
(else
`(if (and (schelog:ref? ,e)
(schelog:unbound-ref? ,e))
(,fk 'fail) (schelog:deref* ,e)))))))
`(lambda (__fk)
((%= ,v ,(%is-help e '__fk)) __fk)))))
;defining arithmetic comparison operators
(define schelog:make-binary-arithmetic-relation
(lambda (f)
(lambda (x y)
(%is #t (f x y)))))
(define %=:= (schelog:make-binary-arithmetic-relation =))
(define %> (schelog:make-binary-arithmetic-relation >))
(define %>= (schelog:make-binary-arithmetic-relation >=))
(define %< (schelog:make-binary-arithmetic-relation <))
(define %<= (schelog:make-binary-arithmetic-relation <=))
(define %=/= (schelog:make-binary-arithmetic-relation
(lambda (m n) (not (= m n)))))
;type predicates
(define schelog:constant?
(lambda (x)
(cond ((schelog:ref? x)
(cond ((schelog:unbound-ref? x) #f)
((schelog:frozen-ref? x) #t)
(else (schelog:constant? (schelog:deref x)))))
((pair? x) #f)
((vector? x) #f)
(else #t))))
(define schelog:compound?
(lambda (x)
(cond ((schelog:ref? x) (cond ((schelog:unbound-ref? x) #f)
((schelog:frozen-ref? x) #f)
(else (schelog:compound? (schelog:deref x)))))
((pair? x) #t)
((vector? x) #t)
(else #f))))
(define %constant
(lambda (x)
(lambda (fk)
(if (schelog:constant? x) fk (fk 'fail)))))
(define %compound
(lambda (x)
(lambda (fk)
(if (schelog:compound? x) fk (fk 'fail)))))
;metalogical type predicates
(define schelog:var?
(lambda (x)
(cond ((schelog:ref? x)
(cond ((schelog:unbound-ref? x) #t)
((schelog:frozen-ref? x) #f)
(else (schelog:var? (schelog:deref x)))))
((pair? x) (or (schelog:var? (car x)) (schelog:var? (cdr x))))
((vector? x) (schelog:var? (vector->list x)))
(else #f))))
(define %var
(lambda (x)
(lambda (fk) (if (schelog:var? x) fk (fk 'fail)))))
(define %nonvar
(lambda (x)
(lambda (fk) (if (schelog:var? x) (fk 'fail) fk))))
; negation of unify
(define schelog:make-negation ;basically inlined cut-fail
(lambda (p)
(lambda args
(lambda (fk)
(if (call-with-current-continuation
(lambda (k)
((apply p args) (lambda (d) (k #f)))))
(fk 'fail)
fk)))))
(define %/=
(schelog:make-negation %=))
;identical
(define schelog:ident?
(lambda (x y)
(cond ((schelog:ref? x)
(cond ((schelog:unbound-ref? x)
(cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) (eq? x y))
((schelog:frozen-ref? y) #f)
(else (schelog:ident? x (schelog:deref y)))))
(else #f)))
((schelog:frozen-ref? x)
(cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) #f)
((schelog:frozen-ref? y) (eq? x y))
(else (schelog:ident? x (schelog:deref y)))))
(else #f)))
(else (schelog:ident? (schelog:deref x) y))))
((pair? x)
(cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) #f)
((schelog:frozen-ref? y) #f)
(else (schelog:ident? x (schelog:deref y)))))
((pair? y)
(and (schelog:ident? (car x) (car y))
(schelog:ident? (cdr x) (cdr y))))
(else #f)))
((vector? x)
(cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) #f)
((schelog:frozen-ref? y) #f)
(else (schelog:ident? x (schelog:deref y)))))
((vector? y)
(schelog:ident? (vector->list x)
(vector->list y)))
(else #f)))
(else
(cond ((schelog:ref? y)
(cond ((schelog:unbound-ref? y) #f)
((schelog:frozen-ref? y) #f)
(else (schelog:ident? x (schelog:deref y)))))
((pair? y) #f)
((vector? y) #f)
(else (eqv? x y)))))))
(define %==
(lambda (x y)
(lambda (fk) (if (schelog:ident? x y) fk (fk 'fail)))))
(define %/==
(lambda (x y)
(lambda (fk) (if (schelog:ident? x y) (fk 'fail) fk))))
;variables as objects
(define schelog:freeze
(lambda (s)
(let ((dict '()))
(let loop ((s s))
(cond ((schelog:ref? s)
(cond ((or (schelog:unbound-ref? s) (schelog:frozen-ref? s))
(let ((x (assq s dict)))
(if x (cdr x)
(let ((y (schelog:freeze-ref s)))
(set! dict (cons (cons s y) dict))
y))))
;((schelog:frozen-ref? s) s) ;?
(else (loop (schelog:deref s)))))
((pair? s) (cons (loop (car s)) (loop (cdr s))))
((vector? s)
(list->vector (map loop (vector->list s))))
(else s))))))
(define schelog:melt
(lambda (f)
(cond ((schelog:ref? f)
(cond ((schelog:unbound-ref? f) f)
((schelog:frozen-ref? f) (schelog:thaw-frozen-ref f))
(else (schelog:melt (schelog:deref f)))))
((pair? f)
(cons (schelog:melt (car f)) (schelog:melt (cdr f))))
((vector? f)
(list->vector (map schelog:melt (vector->list f))))
(else f))))
(define schelog:melt-new
(lambda (f)
(let ((dict '()))
(let loop ((f f))
(cond ((schelog:ref? f)
(cond ((schelog:unbound-ref? f) f)
((schelog:frozen-ref? f)
(let ((x (assq f dict)))
(if x (cdr x)
(let ((y (schelog:make-ref)))
(set! dict (cons (cons f y) dict))
y))))
(else (loop (schelog:deref f)))))
((pair? f) (cons (loop (car f)) (loop (cdr f))))
((vector? f)
(list->vector (map loop (vector->list f))))
(else f))))))
(define schelog:copy
(lambda (s)
(schelog:melt-new (schelog:freeze s))))
(define %freeze
(lambda (s f)
(lambda (fk)
((%= (schelog:freeze s) f) fk))))
(define %melt
(lambda (f s)
(lambda (fk)
((%= (schelog:melt f) s) fk))))
(define %melt-new
(lambda (f s)
(lambda (fk)
((%= (schelog:melt-new f) s) fk))))
(define %copy
(lambda (s c)
(lambda (fk)
((%= (schelog:copy s) c) fk))))
;negation as failure
(define %not
(lambda (g)
(lambda (fk)
(if (call-with-current-continuation
(lambda (k)
((schelog:deref* g) (lambda (d) (k #f)))))
(fk 'fail) fk))))
;assert, asserta
(define %empty-rel
(lambda args
%fail))
(define-syntax %assert
(syntax-rules (!)
((%assert rel-name (v ...) ((a ...) subgoal ...) ...)
(set! rel-name
(let ((__old-rel rel-name)
(__new-addition (%rel (v ...) ((a ...) subgoal ...) ...)))
(lambda __fmls
(%or (apply __old-rel __fmls)
(apply __new-addition __fmls))))))))
(define-syntax %assert-a
(syntax-rules (!)
((%assert-a rel-name (v ...) ((a ...) subgoal ...) ...)
(set! rel-name
(let ((__old-rel rel-name)
(__new-addition (%rel (v ...) ((a ...) subgoal ...) ...)))
(lambda __fmls
(%or (apply __new-addition __fmls)
(apply __old-rel __fmls))))))))
#;(define-macro %assert
(lambda (rel-name vv . cc)
`(set! ,rel-name
(let ((__old-rel ,rel-name)
(__new-addition (%rel ,vv ,@cc)))
(lambda __fmls
(%or (apply __old-rel __fmls)
(apply __new-addition __fmls)))))))
#;(define-macro %assert-a
(lambda (rel-name vv . cc)
`(set! ,rel-name
(let ((__old-rel ,rel-name)
(__new-addition (%rel ,vv ,@cc)))
(lambda __fmls
(%or (apply __new-addition __fmls)
(apply __old-rel __fmls)))))))
;set predicates
(define schelog:set-cons
(lambda (e s)
(if (member e s) s (cons e s))))
(define-syntax %free-vars
(syntax-rules ()
((%free-vars (v ...) g)
(cons 'schelog:goal-with-free-vars
(cons (list v ...) g)))))
#;(define-macro %free-vars
(lambda (vv g)
`(cons 'schelog:goal-with-free-vars
(cons (list ,@vv) ,g))))
(define schelog:goal-with-free-vars?
(lambda (x)
(and (pair? x) (eq? (car x) 'schelog:goal-with-free-vars))))
(define schelog:make-bag-of
(lambda (kons)
(lambda (lv goal bag)
(let ((fvv '()))
(when (schelog:goal-with-free-vars? goal)
(set! fvv (cadr goal))
(set! goal (cddr goal)))
(schelog:make-bag-of-aux kons fvv lv goal bag)))))
(define schelog:make-bag-of-aux
(lambda (kons fvv lv goal bag)
(lambda (fk)
(call-with-current-continuation
(lambda (sk)
(let ((lv2 (cons fvv lv)))
(let* ((acc '())
(fk-final
(lambda (d)
;;(set! acc (reverse! acc))
(sk ((schelog:separate-bags fvv bag acc) fk))))
(fk-retry (goal fk-final)))
(set! acc (kons (schelog:deref* lv2) acc))
(fk-retry 'retry))))))))
(define schelog:separate-bags
(lambda (fvv bag acc)
;;(format #t "Accum: ~s~%" acc)
(let ((bags (let loop ((acc acc)
(current-fvv #f) (current-bag '())
(bags '()))
(if (null? acc)
(cons (cons current-fvv current-bag) bags)
(let ((x (car acc)))
(let ((x-fvv (car x)) (x-lv (cdr x)))
(if (or (not current-fvv) (equal? x-fvv current-fvv))
(loop (cdr acc) x-fvv (cons x-lv current-bag) bags)
(loop (cdr acc) x-fvv (list x-lv)
(cons (cons current-fvv current-bag) bags)))))))))
;;(format #t "Bags: ~a~%" bags)
(if (null? bags) (%= bag '())
(let ((fvv-bag (cons fvv bag)))
(let loop ((bags bags))
(if (null? bags) %fail
(%or (%= fvv-bag (car bags))
(loop (cdr bags))))))))))
(define %bag-of (schelog:make-bag-of cons))
(define %set-of (schelog:make-bag-of schelog:set-cons))
;%bag-of-1, %set-of-1 hold if there's at least one solution
(define %bag-of-1
(lambda (x g b)
(%and (%bag-of x g b)
(%= b (cons (_) (_))))))
(define %set-of-1
(lambda (x g s)
(%and (%set-of x g s)
(%= s (cons (_) (_))))))
;user interface
;(%which (v ...) query) returns #f if query fails and instantiations
;of v ... if query succeeds. In the latter case, type (%more) to
;retry query for more instantiations.
(define schelog:*more-k* (box 'forward))
(define schelog:*more-fk* (box 'forward))
(define-syntax %which
(syntax-rules ()
((%which (v ...) g)
(%let (v ...)
(call-with-current-continuation
(lambda (__qk)
(set-box! schelog:*more-k* __qk)
(set-box! schelog:*more-fk*
((schelog:deref* g)
(lambda (d)
(set-box! schelog:*more-fk* #f)
((unbox schelog:*more-k*) #f))))
((unbox schelog:*more-k*)
(map (lambda (nam val) (list nam (schelog:deref* val)))
'(v ...)
(list v ...)))))))))
#;(define-macro %which
(lambda (vv g)
`(%let ,vv
(call-with-current-continuation
(lambda (__qk)
(set! schelog:*more-k* __qk)
(set! schelog:*more-fk*
((schelog:deref* ,g)
(lambda (d)
(set! schelog:*more-fk* #f)
(schelog:*more-k* #f))))
(schelog:*more-k*
(map (lambda (nam val) (list nam (schelog:deref* val)))
',vv
(list ,@vv))))))))
(define %more
(lambda ()
(call-with-current-continuation
(lambda (k)
(set-box! schelog:*more-k* k)
(if (unbox schelog:*more-fk*) ((unbox schelog:*more-fk*) 'more)
#f)))))
;end of embedding code. The following are
;some utilities, written in Schelog
(define %member
(lambda (x y)
(%let (xs z zs)
(%or
(%= y (cons x xs))
(%and (%= y (cons z zs))
(%member x zs))))))
(define %if-then-else
(lambda (p q r)
(%cut-delimiter !
(%or
(%and p ! q)
r))))
;the above could also have been written in a more
;Prolog-like fashion, viz.
#;'(define %member
(%rel ! (x xs y ys)
((x (cons x xs)))
((x (cons y ys)) (%member x ys))))
#;'(define %if-then-else
(%rel ! (p q r)
((p q r) p ! q)
((p q r) r)))
(define %append
(%rel ! (x xs ys zs)
(('() ys ys))
(((cons x xs) ys (cons x zs))
(%append xs ys zs))))
(define %repeat
;;failure-driven loop
(%rel ! ()
(())
(() (%repeat))))
; deprecated names -- retained here for backward-compatibility
;; JBC, 2010-04-22 -- don't think backward compatibility counts any more. commenting
;; these out.
#;(define == %=)
#;(define %notunify %/=)
#;(define-macro %cut
(lambda e
`(%cur-delimiter ,@e)))
#;(define-macro rel
(lambda e
`(%rel ,@e)))
(define %eq %=:=)
(define %gt %>)
(define %ge %>=)
(define %lt %<)
(define %le %<=)
(define %ne %=/=)
(define %ident %==)
(define %notident %/==)
;(define-syntax %exists (syntax-rules () ((%exists vv g) g)))
#;(define-macro %exists (lambda (vv g) g))
#;(define-macro which
(lambda e
`(%which ,@e)))
(define more %more)
;end of file

1572
collects/schelog/schelog.tex Normal file
View File

File diff suppressed because it is too large Load Diff

4
collects/scriblib/figure.tex
View File

@ -9,7 +9,7 @@
\newlength{\FigOrigskip} \newlength{\FigOrigskip}
\FigOrigskip=\parskip \FigOrigskip=\parskip
\newenvironment{CenterfigureMulti}{\begin{figure*}\centering}{\end{figure*}} \newenvironment{CenterfigureMulti}{\begin{figure*}[htp]\centering}{\end{figure*}}
\newenvironment{CenterfigureMultiWide}{\begin{CenterfigureMulti}}{\end{CenterfigureMulti}} \newenvironment{CenterfigureMultiWide}{\begin{CenterfigureMulti}}{\end{CenterfigureMulti}}
\newenvironment{Centerfigure}{\begin{figure}\centering}{\end{figure}} \newenvironment{Centerfigure}{\begin{figure}[htp]\centering}{\end{figure}}
\newenvironment{FigureInside}{\begin{list}{}{\leftmargin=0pt\topsep=0pt\parsep=\FigOrigskip\partopsep=0pt}\item}{\end{list}} \newenvironment{FigureInside}{\begin{list}{}{\leftmargin=0pt\topsep=0pt\parsep=\FigOrigskip\partopsep=0pt}\item}{\end{list}}

11
collects/syntax-color/module-lexer.ss
View File

@ -12,16 +12,7 @@
[(init) (file-position p)] [(init) (file-position p)]
[(start-line start-col start-pos) (port-next-location p)]) [(start-line start-col start-pos) (port-next-location p)])
(let ([get-info (with-handlers ([exn:fail? (lambda (exn) 'fail)]) (let ([get-info (with-handlers ([exn:fail? (lambda (exn) 'fail)])
(parameterize ([current-reader-guard (read-language p (lambda () #f)))]
(let ([old (current-reader-guard)])
(lambda (g)
(if (and (pair? g)
(eq? (car g) 'planet))
(error "#lang planet disbled")
(old g))))])
;; FIXME: do something so that we don't
;; have to disable all planet packages.
(read-language p (lambda () #f))))]
[sync-ports (lambda () [sync-ports (lambda ()
(read-bytes (- (file-position p) init) in))]) (read-bytes (- (file-position p) init) in))])
(cond (cond

2
collects/syntax/module-reader.ss
View File

@ -216,7 +216,7 @@
#:read-spec #:read-spec
[read-spec [read-spec
(lambda (in) (lambda (in)
(let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) ;; if this changes, the regexp in planet's lang/reader.ss must also change
(and spec (let ([s (cadr spec)]) (and spec (let ([s (cadr spec)])
(if (equal? s "") #f s)))))]) (if (equal? s "") #f s)))))])
(define (get in export-sym src line col pos spec-as-stx? mk-fail-thunk) (define (get in export-sym src line col pos spec-as-stx? mk-fail-thunk)

47
collects/web-server/scribblings/faq.scrbl
View File

@ -3,18 +3,53 @@
@title[#:tag "faq"]{Troubleshooting and Tips} @title[#:tag "faq"]{Troubleshooting and Tips}
@section{Why are my servlets not updating on the server when I change the code on disk?} @section{Why are my templates not updating on the server when I change the file on disk?}
@(require (for-label web-server/dispatchers/dispatch-servlets)) Templates are compiled into your application, so when you change them there is no connection between that change in the filesystem and the compiled bytecode that is already loaded in a running Web server process. For more discussion, see @secref["update-servlets"].
By default, the server uses @scheme[make-cached-url->servlet] to load servlets @section{Why are templates compiled into programs?}
@(require (for-label web-server/templates))
Since templates can include arbitrary Scheme code, macros, etc and refer to
arbitrary identifiers, @scheme[include-template] is really just an obscured
@scheme[require].
@section[#:tag "update-servlets"]{Why are my stateful servlets not updating on the server when I change the file on disk?}
@(require (for-label web-server/dispatchers/dispatch-servlets
web-server/servlet-env))
If you are using @scheme[serve/servlet], it starts a Web server that directly references a closure that has no connection
to some file on the disk.
If you are using the command-line tool, or configuration file, then by default,
the server uses @scheme[make-cached-url->servlet] to load servlets
from the disk. As it loads them, they are cached and the disk is not referred to for future from the disk. As it loads them, they are cached and the disk is not referred to for future
requests. This ensures that there is a single namespace for each servlet, so that different instances requests. This ensures that there is a single namespace for each servlet, so that different instances
can share resources, such as database connections, and communicate through the store. The default can share resources, such as database connections, and communicate through the store. The default
configuration of the server (meaning the dispatcher sequence used when you load a configuration file) configuration of the server (meaning the dispatcher sequence used when you load a configuration file)
provides a special URL to localhost that will reset the cache: @filepath{/conf/refresh-servlets}. If provides a special URL to localhost that will reset the cache: @filepath{/conf/refresh-servlets}.
you want the server to reload your changed servlet code, then GET this URL and the server will reload the
servlet on the next request. If you want the server to reload your changed servlet code, then GET this URL and the server will reload the
servlet on the next request. However, you may be surprised by what happens on the next request. For more discussion, see @secref["refresh-servlets"].
@section[#:tag "refresh-servlets"]{After refreshing my stateful servlet, old captured continuations don't change or old global effects are gone. Why?}
Every load of your servlet is in a fresh namespace. When you refresh, a new namespace without the old effects is created. Old captured continuations
refer to the original namespace and will never update. It is impossible, in general, to port a continuation from one namespace to another, because the
code could be arbitrarily different.
@section{How are stateless servlets different from stateful servlets vis a vis refreshing?}
Continuations are serialized with a hash that ensures that any source
code modifications makes all the old continuations incompatible for
the same reason native continuations naturally are.
However, this hash only protects against changes in a single source file. Therefore if you modularize
your application, then only continuations that refer to changed source files will be incompatible.
For example, if you put all your templates in a single module, then it can change without
invalidating old continuations.
@section{What special considerations are there for security with the Web Server?} @section{What special considerations are there for security with the Web Server?}

47
src/racket/src/places.c
View File

@ -11,7 +11,7 @@ READ_ONLY static Scheme_Object *scheme_def_place_exit_proc;
SHARED_OK mz_proc_thread *scheme_master_proc_thread; SHARED_OK mz_proc_thread *scheme_master_proc_thread;
THREAD_LOCAL_DECL(mz_proc_thread *proc_thread_self); THREAD_LOCAL_DECL(mz_proc_thread *proc_thread_self);
Scheme_Object *scheme_place(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_sleep(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place_sleep(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[]);
@ -20,16 +20,19 @@ static Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_channel_p(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place_channel_p(int argc, Scheme_Object *args[]);
static Scheme_Object *def_place_exit_handler_proc(int argc, Scheme_Object *args[]); static Scheme_Object *def_place_exit_handler_proc(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_channel(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_channel_receiver_channel(int argc, Scheme_Object *args[]);
Scheme_Object *scheme_place_async_channel_create(); static Scheme_Object *scheme_place_async_channel_create();
Scheme_Object *scheme_place_bi_channel_create(); static Scheme_Object *scheme_place_bi_channel_create();
Scheme_Object *scheme_place_bi_peer_channel_create(Scheme_Object *orig); static Scheme_Object *scheme_place_bi_peer_channel_create(Scheme_Object *orig);
static void scheme_place_bi_channel_set_signal(Scheme_Object *cho); static void scheme_place_bi_channel_set_signal(Scheme_Object *cho);
static int scheme_place_channel_ready(Scheme_Object *so); static int scheme_place_channel_ready(Scheme_Object *so);
void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o);
Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch); static void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o);
Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht); static Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch);
static Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht);
# ifdef MZ_PRECISE_GC # ifdef MZ_PRECISE_GC
static void register_traversers(void); static void register_traversers(void);
@ -73,6 +76,8 @@ void scheme_init_place(Scheme_Env *env)
PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv); PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 1, 1, plenv); PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv); PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel", scheme_place_channel, 0, 0, plenv);
PLACE_PRIM_W_ARITY("place-channel->receiver-channel", scheme_place_channel_receiver_channel, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel-send", scheme_place_send, 1, 2, plenv); PLACE_PRIM_W_ARITY("place-channel-send", scheme_place_send, 1, 2, plenv);
PLACE_PRIM_W_ARITY("place-channel-recv", scheme_place_recv, 1, 1, plenv); PLACE_PRIM_W_ARITY("place-channel-recv", scheme_place_recv, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel?", scheme_place_channel_p, 1, 1, plenv); PLACE_PRIM_W_ARITY("place-channel?", scheme_place_channel_p, 1, 1, plenv);
@ -450,6 +455,8 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
case scheme_true_type: case scheme_true_type:
case scheme_false_type: case scheme_false_type:
case scheme_null_type: case scheme_null_type:
/* place_bi_channels are allocated in the master and can be passed along as is */
case scheme_place_bi_channel_type:
new_so = so; new_so = so;
break; break;
case scheme_char_type: case scheme_char_type:
@ -945,6 +952,32 @@ Scheme_Object *scheme_place_bi_peer_channel_create(Scheme_Object *orig) {
return (Scheme_Object *)ch; return (Scheme_Object *)ch;
} }
static Scheme_Object *scheme_place_channel(int argc, Scheme_Object *args[]) {
if (argc == 0) {
return scheme_place_bi_channel_create();
}
else {
scheme_wrong_count_m("place-channel", 0, 0, argc, args, 0);
}
return scheme_true;
}
static Scheme_Object *scheme_place_channel_receiver_channel(int argc, Scheme_Object *args[]) {
if (argc == 1) {
if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) {
return scheme_place_bi_peer_channel_create(args[0]);
}
else {
scheme_wrong_type("place-channel->receive-channel", "place-channel?", 0, argc, args);
}
}
else {
scheme_wrong_count_m("place-channel-send", 1, 1, argc, args, 0);
}
return scheme_true;
}
static void scheme_place_bi_channel_set_signal(Scheme_Object *cho) { static void scheme_place_bi_channel_set_signal(Scheme_Object *cho) {
Scheme_Place_Async_Channel *ch; Scheme_Place_Async_Channel *ch;
void *signaldescr; void *signaldescr;

5
src/racket/src/schpriv.h
View File

@ -3470,11 +3470,6 @@ typedef struct Scheme_Place_Async_Channel {
void *wakeup_signal; void *wakeup_signal;
} Scheme_Place_Async_Channel; } Scheme_Place_Async_Channel;
Scheme_Object *scheme_place_async_channel_create();
void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o);
Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch);
Scheme_Env *scheme_place_instance_init(); Scheme_Env *scheme_place_instance_init();
void scheme_place_instance_destroy(); void scheme_place_instance_destroy();
void scheme_kill_green_thread_timer(); void scheme_kill_green_thread_timer();