mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-15 00:47:34 +02:00
Adding documentation.
This commit is contained in:
Alex Shinn
parent
4cacc6abde
commit
265d3e5136
15 changed files with 587 additions and 105 deletions
|
|
@ -1,12 +1,22 @@
|
|||
;; ast.scm -- ast utilities
|
||||
;; Copyright (c) 2010 Alex Shinn. All rights reserved.
|
||||
;; Copyright (c) 2010-2011 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
(define (macroexpand x)
|
||||
(ast->sexp (analyze x)))
|
||||
;;> Abstract Syntax Tree. Interface to the types used by
|
||||
;;> the compiler, and other core types less commonly
|
||||
;;> needed in user code, plus related utilities.
|
||||
|
||||
(define (procedure-name x)
|
||||
(bytecode-name (procedure-code x)))
|
||||
;;> @subsubsection{Analysis and Expansion}
|
||||
|
||||
;;> @subsubsubsection{@scheme{(analyze x [env])}}
|
||||
|
||||
;;> Expands and analyzes the expression @var{x} and returns the
|
||||
;;> resulting AST.
|
||||
|
||||
;;> @subsubsubsection{@scheme{(optimize ast)}}
|
||||
|
||||
;;> Runs an optimization pass on @var{ast} and returns the
|
||||
;;> resulting simplified expression.
|
||||
|
||||
(define (ast-renames ast)
|
||||
(define i 0)
|
||||
|
|
@ -67,6 +77,15 @@
|
|||
((null? ls) '())
|
||||
(else (f ls))))
|
||||
|
||||
;;> Performs a full syntax expansion of the form @var{x} and
|
||||
;;> returns the resulting s-expression.
|
||||
|
||||
(define (macroexpand x)
|
||||
(ast->sexp (analyze x)))
|
||||
|
||||
;;> Convert @var{ast} to a s-expression, renaming variables if
|
||||
;;> necessary.
|
||||
|
||||
(define (ast->sexp ast)
|
||||
(let ((renames (ast-renames ast)))
|
||||
(let a2s ((x ast))
|
||||
|
|
@ -89,8 +108,244 @@
|
|||
((opcode? x) (or (opcode-name x) x))
|
||||
(else x)))))
|
||||
|
||||
(define (type-parent x)
|
||||
(let ((v (type-cpl x)))
|
||||
;;> @subsubsection{Types}
|
||||
|
||||
;;> All objects have an associated type, and types may have parent
|
||||
;;> types. When using SRFI-9 @scheme{define-record-type}, the
|
||||
;;> name is bound to a first class type object.
|
||||
|
||||
;;> The following core types are also available by name, and may be
|
||||
;;> used in the @scheme{match} @scheme{($ ...)} syntax.
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{<object>} - the parent of all types}
|
||||
;;> @item{@scheme{<number>} - abstract numeric type}
|
||||
;;> @item{@scheme{<bignum>} - arbitrary precision exact integers}
|
||||
;;> @item{@scheme{<flonum>} - inexact real numbers}
|
||||
;;> @item{@scheme{<integer>} - abstract integer type}
|
||||
;;> @item{@scheme{<symbol>} - symbols}
|
||||
;;> @item{@scheme{<char>} - character}
|
||||
;;> @item{@scheme{<boolean>} - @scheme{#t} or @scheme{#f}}
|
||||
;;> @item{@scheme{<string>} - strings of characters}
|
||||
;;> @item{@scheme{<byte-vector>} - uniform vector of octets}
|
||||
;;> @item{@scheme{<pair>} - a @var{car} and @var{cdr}, the basis for lists}
|
||||
;;> @item{@scheme{<vector>} - vectors}
|
||||
;;> @item{@scheme{<opcode>} - a primitive opcode or C function}
|
||||
;;> @item{@scheme{<procedure>} - a closure}
|
||||
;;> @item{@scheme{<bytecode>} - the compiled code for a closure}
|
||||
;;> @item{@scheme{<env>} - an environment structure}
|
||||
;;> @item{@scheme{<macro>} - a macro object, usually not first-class}
|
||||
;;> @item{@scheme{<lam>} - a lambda AST type}
|
||||
;;> @item{@scheme{<cnd>} - an conditional AST type (i.e. @scheme{if})}
|
||||
;;> @item{@scheme{<ref>} - a reference AST type}
|
||||
;;> @item{@scheme{<set>} - a mutation AST type (i.e. @scheme{set!})}
|
||||
;;> @item{@scheme{<seq>} - a sequence AST type}
|
||||
;;> @item{@scheme{<lit>} - a literal AST type}
|
||||
;;> @item{@scheme{<sc>} - a syntactic closure}
|
||||
;;> @item{@scheme{<context>} - a context object (including threads)}
|
||||
;;> @item{@scheme{<exception>} - an exception object}
|
||||
;;> ]
|
||||
|
||||
;;> The following extended type predicates may also be used to test
|
||||
;;> individual objects for their type:
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{environment?}}
|
||||
;;> @item{@scheme{bytecode?}}
|
||||
;;> @item{@scheme{macro?}}
|
||||
;;> @item{@scheme{syntactic-closure?}}
|
||||
;;> @item{@scheme{lambda?}}
|
||||
;;> @item{@scheme{cnd?}}
|
||||
;;> @item{@scheme{ref?}}
|
||||
;;> @item{@scheme{set?}}
|
||||
;;> @item{@scheme{seq?}}
|
||||
;;> @item{@scheme{lit?}}
|
||||
;;> @item{@scheme{opcode?}}
|
||||
;;> @item{@scheme{type?}}
|
||||
;;> @item{@scheme{context?}}
|
||||
;;> @item{@scheme{exception?}}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{@scheme{(type-of x)}}
|
||||
|
||||
;;> Returns the type of any object @var{x}.
|
||||
|
||||
;;> @subsubsubsection{@scheme{(type-name type)}}
|
||||
|
||||
;;> Returns the name of type @var{type}.
|
||||
|
||||
;;> @subsubsubsection{@scheme{(type-parent type)}}
|
||||
|
||||
;;> Returns the immediate parent of type @var{type},
|
||||
;;> or @scheme{#f} for a type with no parent.
|
||||
|
||||
(define (type-parent type)
|
||||
(let ((v (type-cpl type)))
|
||||
(and (vector? v)
|
||||
(> (vector-length v) 1)
|
||||
(vector-ref v (- (vector-length v) 2)))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(type-cpl type)}}
|
||||
|
||||
;;> Returns the class precedence list of type @var{type} as a
|
||||
;;> vector, or @scheme{#f} for a type with no parent.
|
||||
|
||||
;;> @subsubsubsection{@scheme{(type-slots type)}}
|
||||
|
||||
;;> Returns the slot list of type @var{type}.
|
||||
|
||||
;;> @subsubsection{Accessors}
|
||||
|
||||
;;> This section describes additional accessors on AST and other core
|
||||
;;> types.
|
||||
|
||||
;;> @subsubsubsection{Procedures}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(procedure-code f)} - the compiled bytecode object}
|
||||
;;> @item{@scheme{(procedure-vars f)} - the variables closed over by @var{f}}
|
||||
;;> @item{@scheme{(procedure-name f)} - the name of @var{f} if known, else @scheme{#f}}
|
||||
;;> ]
|
||||
|
||||
(define (procedure-name x)
|
||||
(bytecode-name (procedure-code x)))
|
||||
|
||||
;;> @subsubsubsection{Macros}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(macro-procedure f)} - the macro procedure}
|
||||
;;> @item{@scheme{(macro-env f)} - the environment the macro was defined in}
|
||||
;;> @item{@scheme{(macro-source f)} - the source location the macro was defined in}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{Bytecode Objects}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(bytecode-name bc)} - the macro procedure}
|
||||
;;> @item{@scheme{(bytecode-literals bc)} - literals the bytecode references}
|
||||
;;> @item{@scheme{(bytecode-source bc)} - the source location the procedure was defined in}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{Syntactic Closures}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(syntactic-closure-env sc)}}
|
||||
;;> @item{@scheme{(syntactic-closure-vars sc)}}
|
||||
;;> @item{@scheme{(syntactic-closure-expr sc)}}
|
||||
;;> ]
|
||||
|
||||
;;> Return the environment, free variables, and expression
|
||||
;;> associated with @var{sc} respectively.
|
||||
|
||||
;;> @subsubsubsection{Exceptions}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(exception-kind exn)}}
|
||||
;;> @item{@scheme{(exception-message exn)}}
|
||||
;;> @item{@scheme{(exception-irritants exn)}}
|
||||
;;> ]
|
||||
|
||||
;;> Return the kind, message, and irritants
|
||||
;;> associated with @var{exn} respectively.
|
||||
|
||||
;;> @subsubsubsection{Lambdas}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(lambda-name lam)} - the name of the lambda, if known}
|
||||
;;> @item{@scheme{(lambda-name-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-params lam)} - the lambda parameter list}
|
||||
;;> @item{@scheme{(lambda-params-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-body lam)} - the body of the lambda}
|
||||
;;> @item{@scheme{(lambda-body-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-defs lam)} - internal definitions of the lambda}
|
||||
;;> @item{@scheme{(lambda-defs-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-locals lam)} - local variables as a list of identifiers}
|
||||
;;> @item{@scheme{(lambda-locals-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-flags lam)} - various flags describing the lambda}
|
||||
;;> @item{@scheme{(lambda-flags-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-free-vars lam)} - free variables the lambda will need to close over}
|
||||
;;> @item{@scheme{(lambda-free-vars-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-set-vars lam)} - variables the lambda mutates}
|
||||
;;> @item{@scheme{(lambda-set-vars-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-return-type lam)} - the return type of the lambda}
|
||||
;;> @item{@scheme{(lambda-return-type-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-param-types lam)} - the types of the input parameters}
|
||||
;;> @item{@scheme{(lambda-param-types-set! lam x)}}
|
||||
;;> @item{@scheme{(lambda-source lam)} - the source code of the lambda}
|
||||
;;> @item{@scheme{(lambda-source-set! lam x)}}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{Conditionals}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(cnd-test cnd)} - the test for the conditional}
|
||||
;;> @item{@scheme{(cnd-test-set! cnd x)}}
|
||||
;;> @item{@scheme{(cnd-pass cnd)} - the success branch}
|
||||
;;> @item{@scheme{(cnd-pass-set! cnd x)}}
|
||||
;;> @item{@scheme{(cnd-fail cnd)} - the failure branch}
|
||||
;;> @item{@scheme{(cnd-fail-set! cnd x)}}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{Sequences}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(seq-ls seq)} - the list of sequence expressions}
|
||||
;;> @item{@scheme{(seq-ls-set! seq x)}}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{References}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(ref-name ref)} - the name of the referenced variable}
|
||||
;;> @item{@scheme{(ref-name-set! ref x)}}
|
||||
;;> @item{@scheme{(ref-cell ref)} - the environment cell the reference resolves to}
|
||||
;;> @item{@scheme{(ref-cell-set! ref x)}}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{Mutations}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(set-var set)} - a reference to the mutated variable}
|
||||
;;> @item{@scheme{(set-var-set! set x)}}
|
||||
;;> @item{@scheme{(set-value set)} - the value to set the variable to}
|
||||
;;> @item{@scheme{(set-value-set! set x)}}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{Literals}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(lit-value lit)} - the literal value}
|
||||
;;> @item{@scheme{(lit-value-set! lit x)}}
|
||||
;;> ]
|
||||
|
||||
;;> @subsubsubsection{Pairs}
|
||||
|
||||
;;> @itemlist[
|
||||
;;> @item{@scheme{(pair-source x)}}
|
||||
;;> @item{@scheme{(pair-source-set! x source)}}
|
||||
;;> ]
|
||||
|
||||
;;> Set or return the source code info associated with a pair x.
|
||||
;;> Source info is represented as another pair whose @var{car} is
|
||||
;;> the source file name and whose @var{cdr} is the line number.
|
||||
|
||||
;;> @subsubsection{Miscellaneous Utilities}
|
||||
|
||||
;;> @subsubsubsection{@scheme{(gc)}}
|
||||
|
||||
;;> Force a garbage collection.
|
||||
|
||||
;;> @subsubsubsection{@scheme{(object-size x)}}
|
||||
|
||||
;;> Returns the heap space directly used by @var{x}, not
|
||||
;;> counting any elements of @var{x}.
|
||||
|
||||
;;> @subsubsubsection{@scheme{(integer->immediate n)}}
|
||||
|
||||
;;> Returns the interpretation of the integer @var{n} as
|
||||
;;> an immediate object, useful for debugging.
|
||||
|
||||
;;> @subsubsubsection{@scheme{(string-contains str pat)}}
|
||||
|
||||
;;> Returns the first string cursor of @var{pat} in @var{str},
|
||||
;;> of @scheme{#f} if it's not found.
|
||||
|
|
|
|||
|
|
@ -1,4 +1,9 @@
|
|||
|
||||
;;> @subsubsubsection{(disasm f [out])}
|
||||
|
||||
;;> Write a human-readable disassembly for the procedure @var{f} to
|
||||
;;> the port @var{out}, defaulting to @scheme{(current-output-port)}.
|
||||
|
||||
(module (chibi disasm)
|
||||
(export disasm)
|
||||
(import-immutable (scheme))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,9 @@
|
|||
|
||||
;;> Cycle-aware equality. Returns @scheme{#t} iff @scheme{a} and
|
||||
;;> @scheme{b} are @scheme{equal?}, including cycles. Another way
|
||||
;;> to think of it is they are @scheme{equiv} if they print the
|
||||
;;> same, assuming all elements can be printed.
|
||||
|
||||
(define (equiv? a b)
|
||||
(let ((equivs (make-hash-table eq?)))
|
||||
(define (get-equivs x)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,9 @@
|
|||
|
||||
;;> Interface to the filesystem and file descriptor objects.
|
||||
;;> Note that file descriptors are currently represented as
|
||||
;;> integers, but may be replaced with opaque (and gc-managed)
|
||||
;;> objects in a future release.
|
||||
|
||||
(module (chibi filesystem)
|
||||
(export open-input-file-descriptor open-output-file-descriptor
|
||||
duplicate-file-descriptor duplicate-file-descriptor-to
|
||||
|
|
|
|||
|
|
@ -1,19 +1,28 @@
|
|||
;; filesystem.scm -- additional filesystem utilities
|
||||
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
|
||||
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;> The fundamental directory iterator. Applies @var{kons} to
|
||||
;;> each filename in directory @var{dir} and the result of the
|
||||
;;> previous application, beginning with @var{knil}. With
|
||||
;;> @var{kons} as @scheme{cons} and @var{knil} as @scheme{'()},
|
||||
;;> equivalent to @scheme{directory-files}.
|
||||
|
||||
(define (directory-fold dir kons knil)
|
||||
(let ((dir (opendir dir)))
|
||||
(let lp ((res knil))
|
||||
(let ((file (readdir dir)))
|
||||
(if file (lp (kons (dirent-name file) res)) res)))))
|
||||
|
||||
;;> Returns a list of the files in @var{dir} in an unspecified
|
||||
;;> order.
|
||||
|
||||
(define (directory-files dir)
|
||||
(directory-fold dir cons '()))
|
||||
|
||||
(define (renumber-file-descriptor old new)
|
||||
(and (duplicate-file-descriptor-to old new)
|
||||
(close-file-descriptor old)))
|
||||
;;> Returns the @scheme{status} object for the given @var{file},
|
||||
;;> which should be a string indicating the path or a file
|
||||
;;> descriptor.
|
||||
|
||||
(define (file-status file)
|
||||
(if (string? file) (stat file) (fstat file)))
|
||||
|
|
@ -32,6 +41,10 @@
|
|||
(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
|
||||
(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
|
||||
|
||||
;;> File status accessors. @var{x} should be a string indicating
|
||||
;;> the file to lookup the status for, or an existing status object.
|
||||
;;/
|
||||
|
||||
(define (file-regular? x) (S_ISREG (file-mode x)))
|
||||
(define (file-directory? x) (S_ISDIR (file-mode x)))
|
||||
(define (file-character? x) (S_ISCHR (file-mode x)))
|
||||
|
|
@ -39,5 +52,17 @@
|
|||
(define (file-fifo? x) (S_ISFIFO (file-mode x)))
|
||||
(define (file-link? x) (S_ISLNK (file-mode x)))
|
||||
(define (file-socket? x) (S_ISSOCK (file-mode x)))
|
||||
|
||||
(define (file-exists? x) (and (file-status x) #t))
|
||||
|
||||
;;> File type tests. @var{x} should be a string indicating the
|
||||
;;> file to lookup the status for, or an existing status object.
|
||||
;;> Returns @scheme{#t} if the file exists and the given type
|
||||
;;> is satisfied, and @scheme{#f} otherwise.
|
||||
;;/
|
||||
|
||||
;;> Equivalent to duplicating the file descriptor @var{old} to
|
||||
;;> @var{new} and closing @var{old}.
|
||||
|
||||
(define (renumber-file-descriptor old new)
|
||||
(and (duplicate-file-descriptor-to old new)
|
||||
(close-file-descriptor old)))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,6 @@
|
|||
;; filesystem.stub -- filesystem bindings
|
||||
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
(c-system-include "sys/types.h")
|
||||
(c-system-include "unistd.h")
|
||||
|
|
@ -62,30 +65,79 @@
|
|||
(define-c errno fstat (int (result stat)))
|
||||
(define-c errno (file-link-status "lstat") (string (result stat)))
|
||||
|
||||
;;> Creates a new input-port from the file descriptor @var{int}.
|
||||
|
||||
(define-c input-port (open-input-file-descriptor "fdopen")
|
||||
(int (value "r" string)))
|
||||
|
||||
;;> Creates a new output-port from the file descriptor @var{int}.
|
||||
|
||||
(define-c output-port (open-output-file-descriptor "fdopen")
|
||||
(int (value "w" string)))
|
||||
|
||||
;;> Unlinks the file named @var{string} from the filesystem.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (delete-file "unlink") (string))
|
||||
|
||||
;;> Creates a hard link to the first arg from the second.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (link-file "link") (string string))
|
||||
|
||||
;;> Creates a symbolic link to the first arg from the second.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (symbolic-link-file "symlink") (string string))
|
||||
|
||||
;;> Renames the first arg to the second.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (rename-file "rename") (string string))
|
||||
|
||||
;;> Returns the current working directory of the process as a string.
|
||||
|
||||
(define-c non-null-string (current-directory "getcwd")
|
||||
((result (array char (auto-expand arg1))) (value 256 int)))
|
||||
|
||||
;;> Creates a new directory with the given mode.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (create-directory "mkdir") (string int))
|
||||
|
||||
;;> Deletes the directory named @var{string} from the filesystem.
|
||||
;;> Does not attempt to delete recursively.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (delete-directory "rmdir") (string))
|
||||
|
||||
(define-c (free DIR) opendir (string))
|
||||
(define-c dirent readdir ((link (pointer DIR))))
|
||||
|
||||
;;> Duplicates the given file descriptor, returning he new value,
|
||||
;; or -1 on failure.
|
||||
|
||||
(define-c int (duplicate-file-descriptor "dup") (int))
|
||||
|
||||
;;> Copies the first file descriptor to the second, closing
|
||||
;;> it if needed.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (duplicate-file-descriptor-to "dup2") (int int))
|
||||
|
||||
;;> Closes the given file descriptor.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (close-file-descriptor "close") (int))
|
||||
|
||||
;;> Returns a list of 2 new file descriptors, the input and
|
||||
;;> output end of a new pipe, respectively.
|
||||
|
||||
(define-c errno (open-pipe "pipe") ((result (array int 2))))
|
||||
|
||||
;;> Creates a new named pipe in the given path.
|
||||
;;> Returns @scheme{#t} on success and @scheme{#f} on failure.
|
||||
|
||||
(define-c errno (make-fifo "mkfifo") (string (default #o644 int)))
|
||||
|
||||
(define-c int (get-file-descriptor-flags "fcntl")
|
||||
|
|
@ -93,11 +145,17 @@
|
|||
(define-c errno (set-file-descriptor-flags! "fcntl")
|
||||
(int (value F_SETFD int) long))
|
||||
|
||||
;;> Get and set the flags for the given file descriptor.
|
||||
;;/
|
||||
|
||||
(define-c int (get-file-descriptor-status "fcntl")
|
||||
(int (value F_GETFL int)))
|
||||
(define-c errno (set-file-descriptor-status! "fcntl")
|
||||
(int (value F_SETFL int) long))
|
||||
|
||||
;;> Get and set the status for the given file descriptor.
|
||||
;;/
|
||||
|
||||
;; (define-c int (get-file-descriptor-lock "fcntl")
|
||||
;; (int (value F_GETLK int) flock))
|
||||
;; (define-c errno (set-file-descriptor-lock! "fcntl")
|
||||
|
|
@ -114,5 +172,10 @@
|
|||
(define-c-const int (open/append "O_APPEND"))
|
||||
(define-c-const int (open/non-block "O_NONBLOCK"))
|
||||
|
||||
(define-c boolean (is-a-tty? "isatty") (port-or-fd))
|
||||
;;> File opening modes.
|
||||
;;/
|
||||
|
||||
;;> Returns @scheme{#t} if the given port of file descriptor
|
||||
;;> if backed by a TTY object, and @scheme{#f} otherwise.
|
||||
|
||||
(define-c boolean (is-a-tty? "isatty") (port-or-fd))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
|
||||
;;> Simple generic function interface.
|
||||
|
||||
(module (chibi generic)
|
||||
(export define-generic define-method make-generic generic-add!)
|
||||
(import-immutable (scheme))
|
||||
|
|
|
|||
|
|
@ -1,9 +1,12 @@
|
|||
|
||||
;;> Define a new generic function named @var{name}.
|
||||
|
||||
(define-syntax define-generic
|
||||
(syntax-rules ()
|
||||
((define-generic name)
|
||||
(define name (make-generic 'name)))))
|
||||
|
||||
;; call-next-method needs to be unhygienic
|
||||
'(define-syntax define-method
|
||||
(syntax-rules ()
|
||||
((define-method (name (param type) ...) . body)
|
||||
|
|
@ -13,6 +16,11 @@
|
|||
(let-syntax ((call))
|
||||
. body))))))
|
||||
|
||||
;;> @subsubsubsection{(define-method (name (param type) ...) body ...)}
|
||||
|
||||
;;> Extends the generic function @var{name} with a new method that
|
||||
;;> applies when the given param types all match.
|
||||
|
||||
(define-syntax define-method
|
||||
(er-macro-transformer
|
||||
(lambda (e r c)
|
||||
|
|
@ -38,6 +46,8 @@
|
|||
|
||||
(define add-method-tag (list 'add-method-tag))
|
||||
|
||||
;;> Create a new first-class generic function named @var{name}.
|
||||
|
||||
(define (make-generic name)
|
||||
(let ((name name)
|
||||
(methods (make-vector 6 '())))
|
||||
|
|
@ -75,5 +85,9 @@
|
|||
(vector-set! res plen (cons (cons preds f) (vector-ref res plen)))
|
||||
res)))
|
||||
|
||||
;;> Extend the generic @var{g} with a new method @var{f}
|
||||
;;> that applies when all parameters match the given list
|
||||
;;> of predicates @var{preds}.
|
||||
|
||||
(define (generic-add! g preds f)
|
||||
(g add-method-tag preds f))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,23 @@
|
|||
|
||||
;;> Utilities for gathering statistics on the heap. Just measuring
|
||||
;;> runtime memory usage doesn't give a good idea of how to optimize
|
||||
;;> that usage, so this module is provided for profiling.
|
||||
|
||||
;;> @subsubsubsection{(heap-stats)}
|
||||
|
||||
;;> Returns an alist summarizing all heap allocated objects. The
|
||||
;;> @var{car} of each cell is the type-name, and the @var{cdr} is the
|
||||
;;> count of objects of that type in the heap. Garbage is collected
|
||||
;;> before the counts are taken.
|
||||
|
||||
;;> @subsubsubsection{(heap-dump [depth])}
|
||||
|
||||
;;> Returns the same value as @scheme{(heap-stats)}, but also prints
|
||||
;;> all objects on the heap as it runs. @var{depth} indicates the
|
||||
;;> printing depth for compound objects and defaults to 1.
|
||||
|
||||
;;> These functions just return @scheme{'()} when using the Boehm GC.
|
||||
|
||||
(module (chibi heap-stats)
|
||||
(export heap-stats heap-dump)
|
||||
(import-immutable (scheme))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,9 @@
|
|||
;; Copyright (c) 2011 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;> Library for highlighting source code in different
|
||||
;;> languages. Currently supports Scheme, C and Assembly.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (string-concatenate-reverse ls)
|
||||
|
|
@ -10,6 +13,18 @@
|
|||
(define (reverse-list->string ls)
|
||||
(list->string (reverse ls)))
|
||||
|
||||
;;> Returns an sxml structure representing the code from source
|
||||
;;> with various language constructs wrapped in highlighting
|
||||
;;> forms. @var{source} should be a string or port. The
|
||||
;;> language to highlight for is auto-detected.
|
||||
|
||||
(define (highlight source)
|
||||
(let ((str (if (string? source) source (port->string source))))
|
||||
((highlighter-for (highlight-detect-language str)) str)))
|
||||
|
||||
;;> Attempst to auto-detect which language @var{str} is code
|
||||
;;> for, and returns a symbol representing that language.
|
||||
|
||||
(define (highlight-detect-language str)
|
||||
(cond
|
||||
((guard (exn (else #f))
|
||||
|
|
@ -20,6 +35,8 @@
|
|||
(else
|
||||
'c)))
|
||||
|
||||
;;> Return a procedure for highlighting the given language.
|
||||
|
||||
(define (highlighter-for language)
|
||||
(case language
|
||||
((scheme) highlight-scheme)
|
||||
|
|
@ -27,10 +44,6 @@
|
|||
((none) (lambda (x) x))
|
||||
(else highlight-c)))
|
||||
|
||||
(define (highlight source)
|
||||
(let ((str (if (string? source) source (port->string source))))
|
||||
((highlighter-for (highlight-detect-language str)) str)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define highlight-themes
|
||||
|
|
@ -54,6 +67,11 @@
|
|||
;;'("#BAFFFF" "#FFCACA" "#FFFFBA" "#CACAFF" "#CAFFCA" "FFBAFF")
|
||||
'("#AAAAAA" "#888888" "#666666" "#444444" "#222222" "#000000"))
|
||||
|
||||
;;> Returns a string representing the CSS needed for the output
|
||||
;;> of @var{highlight}. This should be included in a referenced
|
||||
;;> CSS file, or in a @var{<script>} section in the generated in
|
||||
;;> the generated HTML output.
|
||||
|
||||
(define (highlight-style . theme)
|
||||
(string-concatenate
|
||||
(append
|
||||
|
|
@ -151,6 +169,8 @@
|
|||
summing multpliying up-from down-from else
|
||||
)))
|
||||
|
||||
;;> Highlighter for Scheme source code.
|
||||
|
||||
(define (highlight-scheme source)
|
||||
(let ((in (if (string? source) (open-input-string source) source)))
|
||||
(define (read-identifier ls)
|
||||
|
|
@ -170,7 +190,7 @@
|
|||
(highlight-class "string"
|
||||
(read-identifier (list (read-char in) #\\ #\#))))
|
||||
(else
|
||||
"#"))))
|
||||
(string-append "#" (if (char? c) (string c) ""))))))
|
||||
(define (highlight n str res)
|
||||
(let ((c (read-char in)))
|
||||
(if (eof-object? c)
|
||||
|
|
@ -261,6 +281,8 @@
|
|||
short signed static struct union unsigned void volatile wchar_t
|
||||
sexp sexp_uint_t sexp_sint_t)))
|
||||
|
||||
;;> Highlighter for C source code.
|
||||
|
||||
(define (highlight-c source)
|
||||
(let ((in (if (string? source) (open-input-string source) source)))
|
||||
(define (char-c-initial? c)
|
||||
|
|
@ -369,6 +391,8 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;> Highlighter for Assembly source code.
|
||||
|
||||
(define (highlight-assembly source)
|
||||
(let ((in (if (string? source) (open-input-string source) source)))
|
||||
(define (char-asm-initial? c)
|
||||
|
|
|
|||
|
|
@ -24,11 +24,21 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; reading and writing
|
||||
|
||||
;; Display @var{str} to the given output port, defaulting to
|
||||
;; @scheme{(current-output-port)}, followed by a newline.
|
||||
|
||||
(define (write-line str . o)
|
||||
(let ((out (if (pair? o) (car o) (current-output-port))))
|
||||
(display str out)
|
||||
(newline out)))
|
||||
|
||||
;;> @subsubsubsection{(read-line [in [n]])}
|
||||
|
||||
;;> Read a line from the input port @var{in}, defaulting to
|
||||
;;> @scheme{(current-input-port)}, and return the result as
|
||||
;;> a string not including the newline. Reads at most @var{n}
|
||||
;;> characters, defaulting to 8192.
|
||||
|
||||
(define (read-line . o)
|
||||
(let ((in (if (pair? o) (car o) (current-input-port)))
|
||||
(n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192)))
|
||||
|
|
@ -43,6 +53,15 @@
|
|||
(substring res 0 (- len 1)))
|
||||
res))))))
|
||||
|
||||
;;> @subsubsubsection{(read-string n [in])}
|
||||
|
||||
;;> Reads @var{n} characters from input-port @var{in},
|
||||
;;> defaulting to @scheme{(current-input-port)}, and
|
||||
;;> returns the result as a string. Returns @scheme{""}
|
||||
;;> if @var{n} is zero. May return a string with fewer
|
||||
;;> than @var{n} characters if the end of file is reached,
|
||||
;;> or the eof-object if no characters are available.
|
||||
|
||||
(define (read-string n . o)
|
||||
(if (zero? n)
|
||||
""
|
||||
|
|
@ -56,7 +75,18 @@
|
|||
(port-line in)))
|
||||
(cadr res)))))))
|
||||
|
||||
;;> @subsubsubsection{(read-string! str n [in])}
|
||||
|
||||
;;> Reads @var{n} characters from port @var{in}, which
|
||||
;;> defaults to @scheme{(current-input-port)}, and writes
|
||||
;;> them into the string @var{str} starting at index 0.
|
||||
;;> Returns the number of characters read.
|
||||
;;> An error is signalled if the length of @var{str} is smaller
|
||||
;;> than @var{n}.
|
||||
|
||||
(define (read-string! str n . o)
|
||||
(if (>= n (string-length str))
|
||||
(error "string to small to read chars" str n))
|
||||
(let* ((in (if (pair? o) (car o) (current-input-port)))
|
||||
(res (%read-string! str n in)))
|
||||
(port-line-set! in (+ (string-count #\newline str 0 n) (port-line in)))
|
||||
|
|
@ -65,6 +95,8 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; higher order port operations
|
||||
|
||||
;;> The fundamental port iterator.
|
||||
|
||||
(define (port-fold kons knil . o)
|
||||
(let ((read (if (pair? o) (car o) read))
|
||||
(in (if (and (pair? o) (pair? (cdr o)))
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@
|
|||
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;; The loop API is compatible with Taylor Campbell's foof-loop, but
|
||||
;; the iterator API is different and subject to change. All loop
|
||||
;; variables may be implicitly destructured with MATCH semantics.
|
||||
;;> The loop API is mostly compatible with Taylor Campbell's
|
||||
;;> @hyperlink["http://mumble.net/~campbell/scheme/foof-loop.txt"]{foof-loop},
|
||||
;;> but the iterator API is different and subject to change.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -49,6 +49,8 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;> @subsubsubsection{@scheme{(loop [name] (vars ...) [=> result] body ...)}}
|
||||
|
||||
(define-syntax loop
|
||||
(syntax-rules ()
|
||||
;; unnamed, implicit recursion
|
||||
|
|
@ -122,21 +124,29 @@
|
|||
. rest))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Iterators
|
||||
;;> @subsubsection{Iterators}
|
||||
|
||||
;; Each gets passed two lists, those items left of the <- and those to
|
||||
;; Each gets passed two lists, those items left of the macro and those to
|
||||
;; the right, followed by a NEXT and REST continuation.
|
||||
|
||||
;;
|
||||
;; Should finish with
|
||||
;;
|
||||
;; @schemeblock{
|
||||
;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
|
||||
;; (loop-vars ...) (final-vars ...) . rest)
|
||||
;; }
|
||||
;;
|
||||
;; OUTER-VARS: bound once outside the loop in a LET*
|
||||
;; CURSOR-VARS: DO-style bindings of the form (name init update)
|
||||
;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t
|
||||
;; LOOP-VARS: inner variables, updated in parallel after the cursors
|
||||
;; FINAL-VARS: final variables, bound only in the => result
|
||||
;; @itemlist[
|
||||
;; @item{@var{outer-vars} - bound once outside the loop in a LET*}
|
||||
;; @item{@var{cursor-vars} - DO-style bindings of the form (name init update)}
|
||||
;; @item{@var{done?-tests} - possibly empty list of forms that terminate the loop on #t}
|
||||
;; @item{@var{loop-vars} - inner variables, updated in parallel after the cursors}
|
||||
;; @item{@var{final-vars} - final variables, bound only in the => result}
|
||||
;; ]
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for var [pair] (in-list ls [cdr]))}}
|
||||
|
||||
;;> Basic list iterator.
|
||||
|
||||
(define-syntax in-list ; called just "IN" in ITER
|
||||
(syntax-rules ()
|
||||
|
|
@ -145,13 +155,13 @@
|
|||
((in-list ((var cursor) source) next . rest)
|
||||
(in-list ((var cursor succ) source) next . rest))
|
||||
((in-list ((var cursor succ) (source)) next . rest)
|
||||
(next () ; outer let bindings
|
||||
((cursor source succ)) ; iterator, init, step
|
||||
((not (pair? cursor))) ; finish tests for iterator vars
|
||||
(next () ; outer let bindings
|
||||
((cursor source succ)) ; iterator, init, step
|
||||
((not (pair? cursor))) ; finish tests for iterator vars
|
||||
;; step variables and values
|
||||
((var (car cursor))
|
||||
(succ (cdr cursor)))
|
||||
() ; final result bindings
|
||||
() ; final result bindings
|
||||
. rest))
|
||||
((in-list ((var cursor succ) (source step)) next . rest)
|
||||
(next ()
|
||||
|
|
@ -162,9 +172,12 @@
|
|||
()
|
||||
. rest))))
|
||||
|
||||
;; Iterator from Taylor R. Campbell. If you know the number of lists
|
||||
;; ahead of time it's much more efficient to iterate over each one
|
||||
;; separately.
|
||||
;;> @subsubsubsection{@scheme{(for elts [pairs] (in-lists lol [cdr [done?]]))}}
|
||||
|
||||
;;> Iterator from Taylor R. Campbell. If you know the number of lists
|
||||
;;> ahead of time it's much more efficient to iterate over each one
|
||||
;;> separately.
|
||||
|
||||
(define-syntax in-lists
|
||||
(syntax-rules ()
|
||||
((in-lists ((elts) lol) next . rest)
|
||||
|
|
@ -202,8 +215,13 @@
|
|||
(%in-idx < (lambda (x i) (- i 1)) (lambda (x) (- (length x) 1)) (lambda (x) 0) ref tmp seq next . rest))))
|
||||
))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for var [index] (in-vector vec))}}
|
||||
;;> @subsubsubsection{@scheme{(for var [index] (in-vector-reverse vec))}}
|
||||
|
||||
(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for ch [cursor] (in-string str))}}
|
||||
|
||||
(define-syntax in-string
|
||||
(syntax-rules ()
|
||||
((in-string s next . rest)
|
||||
|
|
@ -211,6 +229,8 @@
|
|||
string-cursor-start string-cursor-end string-cursor-ref
|
||||
tmp s next . rest))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for ch [cursor] (in-string-reverse str))}}
|
||||
|
||||
(define-syntax in-string-reverse
|
||||
(syntax-rules ()
|
||||
((in-string-reverse s next . rest)
|
||||
|
|
@ -238,6 +258,8 @@
|
|||
. rest))
|
||||
))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for ch (in-port [input-port [reader [eof?]]]))}}
|
||||
|
||||
(define-syntax in-port
|
||||
(syntax-rules ()
|
||||
((in-port ((var) source) next . rest)
|
||||
|
|
@ -256,6 +278,8 @@
|
|||
()
|
||||
. rest))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for ch (in-file [input-port [reader [eof?]]]))}}
|
||||
|
||||
(define-syntax in-file
|
||||
(syntax-rules ()
|
||||
((in-file ((var) source) next . rest)
|
||||
|
|
@ -272,6 +296,8 @@
|
|||
((dummy (close-input-port p)))
|
||||
. rest))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for x (up-from [start] [(to limit)] [(by step)]))}}
|
||||
|
||||
(define-syntax up-from
|
||||
(syntax-rules (to by)
|
||||
((up-from (() . args) next . rest)
|
||||
|
|
@ -296,6 +322,8 @@
|
|||
(next ((s start)) ((var s (+ var 1))) () () () . rest))
|
||||
))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for x (down-from [start] [(to limit)] [(by step)]))}}
|
||||
|
||||
(define-syntax down-from
|
||||
(syntax-rules (to by)
|
||||
((down-from (() . args) next . rest)
|
||||
|
|
@ -343,11 +371,15 @@
|
|||
((var (final cursor)))
|
||||
. rest))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for x [pair] (listing expr))}}
|
||||
|
||||
(define-syntax listing
|
||||
(syntax-rules ()
|
||||
((listing args next . rest)
|
||||
(accumulating (cons reverse '()) args next . rest))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for x [pair] (listing-reverse expr))}}
|
||||
|
||||
(define-syntax listing-reverse
|
||||
(syntax-rules ()
|
||||
((listing-reverse args next . rest)
|
||||
|
|
@ -356,21 +388,29 @@
|
|||
(define (append-reverse rev tail)
|
||||
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for x [pair] (appending expr))}}
|
||||
|
||||
(define-syntax appending
|
||||
(syntax-rules ()
|
||||
((appending args next . rest)
|
||||
(accumulating (append-reverse reverse '()) args next . rest))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for x [pair] (appending-reverse expr))}}
|
||||
|
||||
(define-syntax appending-reverse
|
||||
(syntax-rules ()
|
||||
((appending-reverse args next . rest)
|
||||
(accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for x (summing expr))}}
|
||||
|
||||
(define-syntax summing
|
||||
(syntax-rules ()
|
||||
((summing args next . rest)
|
||||
(accumulating (+ (lambda (x) x) 0) args next . rest))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(for x (multiplying expr))}}
|
||||
|
||||
(define-syntax multiplying
|
||||
(syntax-rules ()
|
||||
((multiplying args next . rest)
|
||||
|
|
|
|||
|
|
@ -1,68 +1,8 @@
|
|||
;; mime.scm -- RFC2045 MIME library
|
||||
;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved.
|
||||
;; Copyright (c) 2005-2011 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; RFC2822 headers
|
||||
|
||||
;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]]
|
||||
;;
|
||||
;; Performs a fold operation on the MIME headers of source which can be
|
||||
;; either a string or port, and defaults to current-input-port. kons
|
||||
;; is called on the three values:
|
||||
;; kons header value accumulator
|
||||
;; where accumulator begins with knil. Neither the header nor the
|
||||
;; value are modified, except wrapped lines are handled for the value.
|
||||
;;
|
||||
;; The optional procedure KONS-FROM is a procedure to be called when
|
||||
;; the first line of the headers is an "From <address> <date>" line, to
|
||||
;; enable this procedure to be used as-is on mbox files and the like.
|
||||
;; It defaults to KONS, and if such a line is found the fold will begin
|
||||
;; with (KONS-FROM "%from" <address> (KONS-FROM "%date" <date> KNIL)).
|
||||
;;
|
||||
;; The optional LIMIT gives a limit on the number of headers to read.
|
||||
|
||||
;; Procedure: mime-headers->list [source]
|
||||
;; Return an alist of the MIME headers from source with headers all
|
||||
;; downcased.
|
||||
|
||||
;; Procedure: mime-parse-content-type str
|
||||
;; Parses STR as a Content-Type style-value returning the list
|
||||
;; (type (attr . val) ...)
|
||||
;; For example:
|
||||
;; (mime-parse-content-type
|
||||
;; "text/html; CHARSET=US-ASCII; filename=index.html")
|
||||
;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html"))
|
||||
|
||||
;; Procedure: mime-decode-header str
|
||||
;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with
|
||||
;; the appropriate decoded and charset converted value.
|
||||
|
||||
;; Procedure: mime-ref headers str [default]
|
||||
;; A case-insensitive assoc-ref.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; RFC2045 MIME encoding
|
||||
|
||||
;; Procedure: mime-message-fold src headers kons knil
|
||||
;; Performs a fold operation on the given string or port SRC as a MIME
|
||||
;; body corresponding to the headers give in HEADERS. KONS is called
|
||||
;; on the successive values:
|
||||
;;
|
||||
;; KONS part-headers part-body accumulator
|
||||
;;
|
||||
;; where part-headers are the headers for the given MIME part (the
|
||||
;; original headers for single-part MIME), part-body is the
|
||||
;; appropriately decoded and charset-converted body of the message,
|
||||
;; and the accumulator begins with KNIL.
|
||||
;;
|
||||
;; TODO: Extend mime-message-fold to (optionally?) pass KONS an
|
||||
;; input-port instead of string for the body to handle very large bodies
|
||||
;; (this is not much of an issue for SMTP since the messages are in
|
||||
;; practice limited, but it could be problematic for large HTTP bodies).
|
||||
;;
|
||||
;; This does a depth-first search, folding in sequence. It should
|
||||
;; probably be doing a tree-fold as in html-parser.
|
||||
;;> A library to parse MIME headers and bodies into SXML.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -85,6 +25,9 @@
|
|||
(cond ((assoc* key ls eq) => cdr)
|
||||
(else default))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(mime-ref headers str [default])}}
|
||||
;;> A case-insensitive @scheme{assoc-ref}.
|
||||
|
||||
(define (mime-ref ls key . o)
|
||||
(assoc-ref ls key (and (pair? o) (car o)) string-ci=?))
|
||||
|
||||
|
|
@ -205,7 +148,24 @@
|
|||
(reverse (cons (substring str i len) res)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; header parsing
|
||||
;;> @subsubsection{RFC2822 Headers}
|
||||
|
||||
;;> @subsubsubsection{@scheme{(mime-header-fold kons knil [source [limit [kons-from]]])}}
|
||||
;;>
|
||||
;;> Performs a fold operation on the MIME headers of source which can be
|
||||
;;> either a string or port, and defaults to current-input-port. @var{kons}
|
||||
;;> is called on the three values:
|
||||
;;> @scheme{(kons header value accumulator)}
|
||||
;;> where accumulator begins with @var{knil}. Neither the header nor the
|
||||
;;> value are modified, except wrapped lines are handled for the value.
|
||||
;;>
|
||||
;;> The optional procedure @var{kons-from} is a procedure to be called when
|
||||
;;> the first line of the headers is an "From <address> <date>" line, to
|
||||
;;> enable this procedure to be used as-is on mbox files and the like.
|
||||
;;> It defaults to @var{kons}, and if such a line is found the fold will begin
|
||||
;;> with @scheme{(kons-from "%from" <address> (kons-from "%date" <date> knil))}.
|
||||
;;>
|
||||
;;> The optional @var{limit} gives a limit on the number of headers to read.
|
||||
|
||||
(define (mime-header-fold kons knil . o)
|
||||
(let ((src (and (pair? o) (car o)))
|
||||
|
|
@ -254,6 +214,10 @@
|
|||
(else
|
||||
(out first-line knil 0)))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(mime-headers->list [source])}}
|
||||
;;> Return an alist of the MIME headers from source with headers all
|
||||
;;> downcased.
|
||||
|
||||
(define (mime-headers->list . o)
|
||||
(reverse
|
||||
(apply
|
||||
|
|
@ -273,9 +237,21 @@
|
|||
(substring s (+ i 1) (string-length s)))))
|
||||
(cons (string-downcase (string-trim-white-space s)) ""))))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(mime-parse-content-type str)}}
|
||||
;;> Parses @var{str} as a Content-Type style-value returning the list
|
||||
;;> @scheme{(type (attr . val) ...)}.
|
||||
|
||||
;;> @example{
|
||||
;;> (mime-parse-content-type "text/html; CHARSET=UTF-8; filename=index.html")
|
||||
;;> }
|
||||
|
||||
(define (mime-parse-content-type str)
|
||||
(map mime-split-name+value (string-split str #\;)))
|
||||
|
||||
;;> @subsubsubsection{@scheme{(mime-decode-header str)}}
|
||||
;;> Replace all occurrences of RFC1522 =?ENC?...?= escapes in @var{str} with
|
||||
;;> the appropriate decoded and charset converted value.
|
||||
|
||||
(define (mime-decode-header str)
|
||||
(let* ((len (string-length str))
|
||||
(limit (- len 8))) ; need at least 8 chars: "=?Q?X??="
|
||||
|
|
@ -334,9 +310,20 @@
|
|||
(lambda (x) (next (mime-convert-part x cte enc)))
|
||||
(lambda (x) (final (mime-convert-part x cte enc)))))
|
||||
|
||||
;; (kons parent-headers part-headers part-body seed)
|
||||
;; (start headers seed)
|
||||
;; (end headers parent-seed seed)
|
||||
;;> @subsubsection{RFC2045 MIME Encoding}
|
||||
|
||||
;;> @subsubsubsection{@scheme{(mime-message-fold src kons knil [start end headers])}}
|
||||
;;> Performs a fold operation on the given string or port @var{src} as a
|
||||
;;> MIME body corresponding to the headers give in @var{headers}. @var{kons}
|
||||
;;> is called on the successive values:
|
||||
;;>
|
||||
;;> @schemeblock{(kons parent-headers part-headers part-body accumulator)}
|
||||
;;>
|
||||
;;> where @var{part-headers} are the headers for the given MIME part (the
|
||||
;;> original headers for single-part MIME), @var{part-body} is the
|
||||
;;> appropriately decoded and charset-converted body of the message,
|
||||
;;> and the @var{accumulator} begins with @var{knil}.
|
||||
|
||||
(define (mime-message-fold src kons init-seed . o)
|
||||
(let ((port (if (string? src) (open-input-string src) src)))
|
||||
(let ((kons-start
|
||||
|
|
@ -392,7 +379,12 @@
|
|||
(lambda (x) (next (kons parent-headers headers x seed)))
|
||||
(lambda (x) (final (kons parent-headers headers x seed)))))))))))
|
||||
|
||||
;; (mime (^ (header . value) ...) parts ...)
|
||||
;;> @subsubsubsection{@scheme{(mime-message->sxml [src])}}
|
||||
;;>
|
||||
;;> Parse the given source as a MIME message and return
|
||||
;;> the result as an SXML object of the form:
|
||||
;;> @scheme{(mime (^ (header . value) ...) parts ...)}.
|
||||
|
||||
(define (mime-message->sxml . o)
|
||||
(car
|
||||
(apply
|
||||
|
|
@ -407,4 +399,3 @@
|
|||
,@(if (pair? seed) (reverse seed) seed))
|
||||
,@parent-seed))
|
||||
(if (pair? o) (cdr o) '()))))
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
(export module-name module-dir module-includes module-shared-includes
|
||||
module-ast module-ast-set! module-ref module-contains?
|
||||
analyze-module containing-module load-module module-exports
|
||||
procedure-analysis)
|
||||
module-name->file procedure-analysis)
|
||||
(import-immutable (scheme) (config))
|
||||
(import (chibi ast))
|
||||
(include "modules.scm"))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,8 @@
|
|||
;; Copyright (c) 2011 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;> Module introspection library.
|
||||
|
||||
(define (file->sexp-list file)
|
||||
(call-with-input-file file
|
||||
(lambda (in)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue