From 94f76a1565f09d189d9f2cef6d3df7860321709e Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Sun, 23 May 2010 23:10:52 +0200 Subject: Racket support (PLT 5 needed). --- scheme/plt/geiser/modules.ss | 147 ------------------------------------------- 1 file changed, 147 deletions(-) delete mode 100644 scheme/plt/geiser/modules.ss (limited to 'scheme/plt/geiser/modules.ss') diff --git a/scheme/plt/geiser/modules.ss b/scheme/plt/geiser/modules.ss deleted file mode 100644 index 829cf77..0000000 --- a/scheme/plt/geiser/modules.ss +++ /dev/null @@ -1,147 +0,0 @@ -;;; modules.ss -- module metadata - -;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the Modified BSD License. You should -;; have received a copy of the license along with this program. If -;; not, see . - -;; Start date: Wed May 06, 2009 02:35 - -#lang scheme - -(provide load-module - ensure-module-spec - module-spec->namespace - namespace->module-path-name - module-path-name->name - module-spec->path-name - module-list - module-exports) - -(require srfi/13 syntax/modresolve syntax/modcode geiser/enter) - -(define (ensure-module-spec spec) - (cond ((symbol? spec) spec) - ((not (string? spec)) #f) - (else `(file ,spec)))) - -(define (module-spec->namespace spec (lang #f)) - (let ((spec (ensure-module-spec spec)) - (try-lang (lambda (_) - (with-handlers ((exn? (const (current-namespace)))) - (and lang - (begin - (load-module lang #f (current-namespace)) - (module->namespace lang))))))) - (or (and spec - (with-handlers ((exn? try-lang)) (get-namespace spec))) - (current-namespace)))) - -(define nowhere (open-output-nowhere)) - -(define (load-module spec (port #f) (ns #f)) - (parameterize ((current-error-port (or port nowhere))) - (enter-module (ensure-module-spec spec)) - (when (namespace? ns) - (current-namespace ns)))) - -(define (namespace->module-path-name ns) - (let ((rmp (variable-reference->resolved-module-path - (eval '(#%variable-reference) ns)))) - (and (resolved-module-path? rmp) - (resolved-module-path-name rmp)))) - -(define (module-spec->path-name spec) - (with-handlers ((exn? (lambda (_) #f))) - (let ((ns (module-spec->namespace (ensure-module-spec spec)))) - (namespace->module-path-name ns)))) - -(define (module-path-name->name path) - (cond ((path? path) - (let* ((path (path->string path)) - (cpaths (map (compose path->string path->directory-path) - (current-library-collection-paths))) - (prefix-len (lambda (p) - (let ((pl (string-length p))) - (if (= pl (string-prefix-length p path)) - pl - 0)))) - (lens (map prefix-len cpaths)) - (real-path (substring path (apply max lens)))) - (if (absolute-path? real-path) - (call-with-values (lambda () (split-path path)) - (lambda (_ basename __) (path->string basename))) - (regexp-replace "\\.[^./]*$" real-path "")))) - ((eq? path '#%kernel) "(kernel)") - ((string? path) path) - ((symbol? path) (symbol->string path)) - (else ""))) - -(define (skippable-dir? path) - (call-with-values (lambda () (split-path path)) - (lambda (_ basename __) - (member (path->string basename) '(".svn" "compiled"))))) - -(define path->symbol (compose string->symbol path->string)) - -(define (path->entry path) - (and (bytes=? (or (filename-extension path) #"") #"ss") - (let ((path (path->string path))) - (substring path 0 (- (string-length path) 3))))) - -(define (visit-module-path path kind acc) - (case kind - ((file) (let ((entry (path->entry path))) - (if entry (cons entry acc) acc))) - ((dir) (cond ((skippable-dir? path) (values acc #f)) - ((file-exists? (build-path path "main.ss")) - (cons (path->string path) acc)) - (else acc))) - (else acc))) - -(define (find-modules path acc) - (if (directory-exists? path) - (parameterize ((current-directory path)) - (fold-files visit-module-path acc)) - acc)) - -(define (known-modules) - (sort (foldl find-modules '() (current-library-collection-paths)) stringnamespace mod)))))) - -(define (startup) - (thread update-module-cache) - (void)) - -(startup) - -;;; modules.ss ends here -- cgit v1.2.3