Skip to content
Browse files

Documentation, bug fixes and tweaks

Bug fixes / tweaks:
- fixed typo in foreign-enum-value.
- defcenum: renamed argument, allow a docstring.
- defcvar and defcfun: also accept symbols as names.
- defcvar: added (declare (ignore value)) when read-only is true.
- foreign-funcall: fixed bug; premature canonicalization of the
  return-type. added regression test for this.
- defcfun and defcallback: use the make-gensym-list utility
- defcallback: return the callback name;
- strings.lisp: fixed the docstrings for the :string translators;
- mem-aref: fixed bug/typo in its setf-expander; added regression
  test for this.
- defcstruct and defcunion: allow a docstring.
- new tests: callbacks.qsort and funcall.string.3

Documentation:
- New file doc/Makefile for generating docs and uploading them to
  c-l.net.
- Added every cffi function/macro that is currently exported.
  documented half of them or so.
- colorize-lisp-examples.lisp: little script to colorize the examples
  in the texinfo-generated html docs.
- gendocs.sh: generate the docs in various formats as well as an
  index page from gendocs_template.
- further tweaks to doc/style.css.
  • Loading branch information...
1 parent 8a3da94 commit 67fbc31bdebfb950c566f9fe12c635475ec8c5ef @luismbo luismbo committed
View
40 doc/Makefile
@@ -0,0 +1,40 @@
+# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
+#
+# Makefile --- Make targets for generating the documentation.
+#
+# Copyright (C) 2005, Luis Oliveira <loliveira at common-lisp.net>
+#
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this software and associated documentation
+# files (the "Software"), to deal in the Software without
+# restriction, including without limitation the rights to use, copy,
+# modify, merge, publish, distribute, sublicense, and/or sell copies
+# of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be
+# included in all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
+#
+
+clean:
+ find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" \) -exec rm {} \;
+ rm -rf manual spec
+
+docs:
+ sh gendocs.sh -o manual --html "--css-include=style.css" cffi-manual "CFFI User Manual"
+ sh gendocs.sh -o spec --html "--css-include=style.css" cffi-sys-spec "CFFI-SYS Interface Specification"
+
+upload-docs:
+ rsync -av --delete -e ssh manual spec common-lisp.net:/project/cffi/public_html/
+# scp -r manual spec common-lisp.net:/project/cffi/public_html/
+
+# vim: ft=make ts=3 noet
View
2,007 doc/cffi-manual.texinfo
2,007 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
0 doc/spec.texinfo → doc/cffi-sys-spec.texinfo
File renamed without changes.
View
1,021 doc/colorize-lisp-examples.lisp
@@ -0,0 +1,1021 @@
+;#!/usr/bin/env clisp
+;;; This is code was taken from lisppaste2 and is a quick hack
+;;; to colorize lisp examples in the html generated by Texinfo.
+;;; It is not general-purpose utility, though it could easily be
+;;; turned into one. Also, the script is setup to work with clisp.
+
+;;;; colorize-package.lisp
+
+(defpackage :colorize
+ (:use :common-lisp)
+ (:export :scan-string :format-scan :html-colorization
+ :find-coloring-type :autodetect-coloring-type
+ :coloring-types :scan :scan-any :advance :call-parent-formatter
+ :*coloring-css* :make-background-css :*css-background-class*
+ :colorize-file :colorize-file-to-stream :*version-token*))
+
+;;;; coloring-css.lisp
+
+(in-package :colorize)
+
+(defparameter *coloring-css*
+ ".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;}
+a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+.special { color : #FF5000; background-color : inherit; }
+.keyword { color : #770000; background-color : inherit; }
+.comment { color : #007777; background-color : inherit; }
+.string { color : #777777; background-color : inherit; }
+.character { color : #0055AA; background-color : inherit; }
+.syntaxerror { color : #FF0000; background-color : inherit; }
+span.paren1:hover { color : inherit; background-color : #BAFFFF; }
+span.paren2:hover { color : inherit; background-color : #FFCACA; }
+span.paren3:hover { color : inherit; background-color : #FFFFBA; }
+span.paren4:hover { color : inherit; background-color : #CACAFF; }
+span.paren5:hover { color : inherit; background-color : #CAFFCA; }
+span.paren6:hover { color : inherit; background-color : #FFBAFF; }
+")
+
+(defvar *css-background-class* "lisp-bg")
+
+(defun for-css (thing)
+ (if (symbolp thing) (string-downcase (symbol-name thing))
+ thing))
+
+(defun make-background-css (color &key (class *css-background-class*) (extra nil))
+ (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:*
+.~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%"
+ class color
+ (mapcar #'(lambda (extra)
+ (format nil "~A : ~{~A ~}"
+ (for-css (first extra))
+ (mapcar #'for-css (cdr extra))))
+ extra)))
+
+;;;; colorize.lisp
+
+;(in-package :colorize)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *coloring-types* nil)
+ (defparameter *version-token* (gensym)))
+
+(defclass coloring-type ()
+ ((modes :initarg :modes :accessor coloring-type-modes)
+ (default-mode :initarg :default-mode :accessor coloring-type-default-mode)
+ (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions)
+ (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name)
+ (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter)
+ (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil)
+ (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly ""))
+ (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function
+ :initform (constantly nil))
+ (parent-type :initarg :parent-type :accessor coloring-type-parent-type
+ :initform nil)
+ (visible :initarg :visible :accessor coloring-type-visible
+ :initform t)))
+
+(defun find-coloring-type (type)
+ (if (typep type 'coloring-type)
+ type
+ (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name))))
+
+(defun autodetect-coloring-type (name)
+ (car
+ (find name *coloring-types*
+ :key #'cdr
+ :test #'(lambda (name type)
+ (and (coloring-type-visible type)
+ (funcall (coloring-type-autodetect-function type) name))))))
+
+(defun coloring-types ()
+ (loop for type-pair in *coloring-types*
+ if (coloring-type-visible (cdr type-pair))
+ collect (cons (car type-pair)
+ (coloring-type-fancy-name (cdr type-pair)))))
+
+(defun (setf find-coloring-type) (new-value type)
+ (if new-value
+ (let ((found (assoc type *coloring-types*)))
+ (if found
+ (setf (cdr found) new-value)
+ (setf *coloring-types*
+ (nconc *coloring-types*
+ (list (cons type new-value))))))
+ (setf *coloring-types* (remove type *coloring-types* :key #'car))))
+
+(defvar *scan-calls* 0)
+
+(defvar *reset-position* nil)
+
+(defmacro with-gensyms ((&rest names) &body body)
+ `(let ,(mapcar #'(lambda (name)
+ (list name `(make-symbol ,(symbol-name name)))) names)
+ ,@body))
+
+(defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body)
+ (with-gensyms (num items position not-preceded-by string item new-mode until advancing)
+ `(labels ((advance (,num)
+ (setf ,position-place (+ ,position-place ,num))
+ t)
+ (peek-any (,items &key ,not-preceded-by)
+ (incf *scan-calls*)
+ (let* ((,items (if (stringp ,items)
+ (coerce ,items 'list) ,items))
+ (,not-preceded-by (if (characterp ,not-preceded-by)
+ (string ,not-preceded-by) ,not-preceded-by))
+ (,position ,position-place)
+ (,string ,string-param))
+ (let ((,item (and
+ (< ,position (length ,string))
+ (find ,string ,items
+ :test #'(lambda (,string ,item)
+ #+nil
+ (format t "looking for ~S in ~S starting at ~S~%"
+ ,item ,string ,position)
+ (if (characterp ,item)
+ (char= (elt ,string ,position)
+ ,item)
+ (search ,item ,string :start2 ,position
+ :end2 (min (length ,string)
+ (+ ,position (length ,item))))))))))
+ (if (characterp ,item)
+ (setf ,item (string ,item)))
+ (if
+ (if ,item
+ (if ,not-preceded-by
+ (if (>= (- ,position (length ,not-preceded-by)) 0)
+ (not (string= (subseq ,string
+ (- ,position (length ,not-preceded-by))
+ ,position)
+ ,not-preceded-by))
+ t)
+ t)
+ nil)
+ ,item
+ (progn
+ (and *reset-position*
+ (setf ,position-place *reset-position*))
+ nil)))))
+ (scan-any (,items &key ,not-preceded-by)
+ (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by)))
+ (and ,item (advance (length ,item)))))
+ (peek (,item &key ,not-preceded-by)
+ (peek-any (list ,item) :not-preceded-by ,not-preceded-by))
+ (scan (,item &key ,not-preceded-by)
+ (scan-any (list ,item) :not-preceded-by ,not-preceded-by)))
+ (macrolet ((set-mode (,new-mode &key ,until (,advancing t))
+ (list 'progn
+ (list 'setf ',mode-place ,new-mode)
+ (list 'setf ',mode-wait-place
+ (list 'lambda (list ',position)
+ (list 'let (list (list '*reset-position* ',position))
+ (list 'values ,until ,advancing)))))))
+ ,@body))))
+
+(defvar *formatter-local-variables*)
+
+(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
+ autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
+ invisible)
+ (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
+ `(let ((,parent-type (or (find-coloring-type ,parent)
+ (and ,parent
+ (error "No such coloring type: ~S" ,parent)))))
+ (setf (find-coloring-type ,name)
+ (make-instance 'coloring-type
+ :fancy-name ',fancy-name
+ :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type)))
+ :default-mode (or ',default-mode
+ (if ,parent-type (coloring-type-default-mode ,parent-type)))
+ ,@(if autodetect
+ `(:autodetect-function ,autodetect))
+ :parent-type ,parent-type
+ :visible (not ,invisible)
+ :formatter-initial-values (lambda nil
+ (list* ,@(mapcar #'(lambda (e)
+ `(cons ',(car e) ,(second e)))
+ formatter-variables)
+ (if ,parent-type
+ (funcall (coloring-type-formatter-initial-values ,parent-type))
+ nil)))
+ :formatter-after-hook (lambda nil
+ (symbol-macrolet ,(mapcar #'(lambda (e)
+ `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
+ formatter-variables)
+ (concatenate 'string
+ (funcall ,formatter-after-hook)
+ (if ,parent-type
+ (funcall (coloring-type-formatter-after-hook ,parent-type))
+ ""))))
+ :term-formatter
+ (symbol-macrolet ,(mapcar #'(lambda (e)
+ `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
+ formatter-variables)
+ (lambda (,term)
+ (labels ((call-parent-formatter (&optional (,type (car ,term))
+ (,string (cdr ,term)))
+ (if ,parent-type
+ (funcall (coloring-type-term-formatter ,parent-type)
+ (cons ,type ,string))))
+ (call-formatter (&optional (,type (car ,term))
+ (,string (cdr ,term)))
+ (funcall
+ (case (first ,type)
+ ,@formatters
+ (t (lambda (,type text)
+ (call-parent-formatter ,type text))))
+ ,type ,string)))
+ (call-formatter))))
+ :transition-functions
+ (list
+ ,@(loop for transition in transitions
+ collect (destructuring-bind (mode &rest table) transition
+ `(cons ',mode
+ (lambda (,current-mode ,string ,position)
+ (let ((,mode-wait (constantly nil))
+ (,position-foobage ,position))
+ (with-scanning-functions ,string ,position-foobage
+ ,current-mode ,mode-wait
+ (let ((*reset-position* ,position))
+ (cond ,@table))
+ (values ,position-foobage ,current-mode
+ (lambda (,new-position)
+ (setf ,position-foobage ,new-position)
+ (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage))))
+ (values ,position-foobage ,advance)))))
+ )))))))))))
+
+(defun full-transition-table (coloring-type-object)
+ (let ((parent (coloring-type-parent-type coloring-type-object)))
+ (if parent
+ (append (coloring-type-transition-functions coloring-type-object)
+ (full-transition-table parent))
+ (coloring-type-transition-functions coloring-type-object))))
+
+(defun scan-string (coloring-type string)
+ (let* ((coloring-type-object (or (find-coloring-type coloring-type)
+ (error "No such coloring type: ~S" coloring-type)))
+ (transitions (full-transition-table coloring-type-object))
+ (result nil)
+ (low-bound 0)
+ (current-mode (coloring-type-default-mode coloring-type-object))
+ (mode-stack nil)
+ (current-wait (constantly nil))
+ (wait-stack nil)
+ (current-position 0)
+ (*scan-calls* 0))
+ (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop)
+ (let ((to (if extend new-position current-position)))
+ (if (> to low-bound)
+ (setf result (nconc result
+ (list (cons (cons current-mode mode-stack)
+ (subseq string low-bound
+ to))))))
+ (setf low-bound to)
+ (when pop
+ (pop mode-stack)
+ (pop wait-stack))
+ (when push
+ (push current-mode mode-stack)
+ (push current-wait wait-stack))
+ (setf current-mode new-mode
+ current-position new-position
+ current-wait new-wait))))
+ (loop
+ (if (> current-position (length string))
+ (return-from scan-string
+ (progn
+ (format *trace-output* "Scan was called ~S times.~%"
+ *scan-calls*)
+ (finish-current (length string) nil (constantly nil))
+ result))
+ (or
+ (loop for transition in
+ (mapcar #'cdr
+ (remove current-mode transitions
+ :key #'car
+ :test-not #'(lambda (a b)
+ (or (eql a b)
+ (if (listp b)
+ (member a b))))))
+ if
+ (and transition
+ (multiple-value-bind
+ (new-position new-mode new-wait)
+ (funcall transition current-mode string current-position)
+ (when (> new-position current-position)
+ (finish-current new-position new-mode new-wait :extend nil :push t)
+ t)))
+ return t)
+ (multiple-value-bind
+ (pos advance)
+ (funcall current-wait current-position)
+ #+nil
+ (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
+ (and pos
+ (when (> pos current-position)
+ (finish-current (if advance
+ pos
+ current-position)
+ (car mode-stack)
+ (car wait-stack)
+ :extend advance
+ :pop t)
+ t)))
+ (progn
+ (incf current-position)))
+ )))))
+
+(defun format-scan (coloring-type scan)
+ (let* ((coloring-type-object (or (find-coloring-type coloring-type)
+ (error "No such coloring type: ~S" coloring-type)))
+ (color-formatter (coloring-type-term-formatter coloring-type-object))
+ (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object))))
+ (format nil "~{~A~}~A"
+ (mapcar color-formatter scan)
+ (funcall (coloring-type-formatter-after-hook coloring-type-object)))))
+
+(defun encode-for-pre (string)
+ (declare (simple-string string))
+ (let ((output (make-array (truncate (length string) 2/3)
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0)))
+ (with-output-to-string (out output)
+ (loop for char across string
+ do (case char
+ ((#\&) (write-string "&amp;" out))
+ ((#\<) (write-string "&lt;" out))
+ ((#\>) (write-string "&gt;" out))
+ (t (write-char char out)))))
+ (coerce output 'simple-string)))
+
+(defun string-substitute (string substring replacement-string)
+ "String substitute by Larry Hunter. Obtained from Google"
+ (let ((substring-length (length substring))
+ (last-end 0)
+ (new-string ""))
+ (do ((next-start
+ (search substring string)
+ (search substring string :start2 last-end)))
+ ((null next-start)
+ (concatenate 'string new-string (subseq string last-end)))
+ (setq new-string
+ (concatenate 'string
+ new-string
+ (subseq string last-end next-start)
+ replacement-string))
+ (setq last-end (+ next-start substring-length)))))
+
+(defun decode-from-tt (string)
+ (string-substitute (string-substitute (string-substitute string "&amp;" "&")
+ "&lt;" "<")
+ "&gt;" ">"))
+
+(defun html-colorization (coloring-type string)
+ (format-scan coloring-type
+ (mapcar #'(lambda (p)
+ (cons (car p)
+ (let ((tt (encode-for-pre (cdr p))))
+ (if (and (> (length tt) 0)
+ (char= (elt tt (1- (length tt))) #\>))
+ (format nil "~A~%" tt) tt))))
+ (scan-string coloring-type string))))
+
+(defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default"))
+ (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
+ (merge-pathnames input-file-name)
+ (make-pathname :type "lisp"
+ :defaults (merge-pathnames input-file-name))))
+ (*css-background-class* css-background))
+ (with-open-file (s input-file :direction :input)
+ (let ((lines nil)
+ (string nil))
+ (block done
+ (loop (let ((line (read-line s nil nil)))
+ (if line
+ (push line lines)
+ (return-from done)))))
+ (setf string (format nil "~{~A~%~}"
+ (nreverse lines)))
+ (if wrap
+ (format s2
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
+<html><head><style type=\"text/css\">~A~%~A</style><body>
+<table width=\"100%\"><tr><td class=\"~A\">
+<tt>~A</tt>
+</tr></td></table></body></html>"
+ *coloring-css*
+ (make-background-css "white")
+ *css-background-class*
+ (html-colorization coloring-type string))
+ (write-string (html-colorization coloring-type string) s2))))))
+
+(defun colorize-file (coloring-type input-file-name &optional output-file-name)
+ (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
+ (merge-pathnames input-file-name)
+ (make-pathname :type "lisp"
+ :defaults (merge-pathnames input-file-name))))
+ (output-file (or output-file-name
+ (make-pathname :type "html"
+ :defaults input-file))))
+ (with-open-file (s2 output-file :direction :output :if-exists :supersede)
+ (colorize-file-to-stream coloring-type input-file-name s2))))
+
+;; coloring-types.lisp
+
+;(in-package :colorize)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *version-token* (gensym)))
+
+(defparameter *symbol-characters*
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890")
+
+(defparameter *non-constituent*
+ '(#\space #\tab #\newline #\linefeed #\page #\return
+ #\" #\' #\( #\) #\, #\; #\` #\[ #\]))
+
+(defparameter *special-forms*
+ '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
+ "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
+ "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
+ "return-from" "setq" "multiple-value-call"))
+
+(defparameter *common-macros*
+ '("loop" "cond" "lambda"))
+
+(defparameter *open-parens* '(#\())
+(defparameter *close-parens* '(#\)))
+
+(define-coloring-type :lisp "Basic Lisp"
+ :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment
+ :multiline :character
+ :single-escaped :in-list :syntax-error)
+ :default-mode :first-char-on-line
+ :transitions
+ (((:in-list)
+ ((or
+ (scan-any *symbol-characters*)
+ (and (scan #\.) (scan-any *symbol-characters*))
+ (and (scan #\\) (advance 1)))
+ (set-mode :symbol
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((or (scan #\:) (scan "#:"))
+ (set-mode :keyword
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((scan "#\\")
+ (let ((count 0))
+ (set-mode :character
+ :until (progn
+ (incf count)
+ (if (> count 1)
+ (scan-any *non-constituent*)))
+ :advancing nil)))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((scan #\;)
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#")))
+ ((scan #\()
+ (set-mode :in-list
+ :until (scan #\)))))
+ ((:normal :first-char-on-line)
+ ((scan #\()
+ (set-mode :in-list
+ :until (scan #\)))))
+ (:first-char-on-line
+ ((scan #\;)
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#")))
+ ((advance 1)
+ (set-mode :normal
+ :until (scan #\newline))))
+ (:multiline
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#"))))
+ ((:symbol :keyword :escaped-symbol :string)
+ ((scan #\\)
+ (let ((count 0))
+ (set-mode :single-escaped
+ :until (progn
+ (incf count)
+ (if (< count 2)
+ (advance 1))))))))
+ :formatter-variables ((paren-counter 0))
+ :formatter-after-hook (lambda nil
+ (format nil "~{~A~}"
+ (loop for i from paren-counter downto 1
+ collect "</span></span>")))
+ :formatters
+ (((:normal :first-char-on-line)
+ (lambda (type s)
+ (declare (ignore type))
+ s))
+ ((:in-list)
+ (lambda (type s)
+ (declare (ignore type))
+ (labels ((color-parens (s)
+ (let ((paren-pos (find-if-not #'null
+ (mapcar #'(lambda (c)
+ (position c s))
+ (append *open-parens*
+ *close-parens*)))))
+ (if paren-pos
+ (let ((before-paren (subseq s 0 paren-pos))
+ (after-paren (subseq s (1+ paren-pos)))
+ (paren (elt s paren-pos))
+ (open nil)
+ (count 0))
+ (when (member paren *open-parens* :test #'char=)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter)
+ (setf open t))
+ (when (member paren *close-parens* :test #'char=)
+ (decf paren-counter))
+ (if open
+ (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
+ before-paren
+ (1+ count)
+ paren *css-background-class*
+ (color-parens after-paren))
+ (format nil "~A</span>~C</span>~A"
+ before-paren
+ paren (color-parens after-paren))))
+ s))))
+ (color-parens s))))
+ ((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let* ((colon (position #\: s :from-end t))
+ (new-s (or (and colon (subseq s (1+ colon))) s)))
+ (cond
+ ((or
+ (member new-s *common-macros* :test #'string-equal)
+ (member new-s *special-forms* :test #'string-equal)
+ (some #'(lambda (e)
+ (and (> (length new-s) (length e))
+ (string-equal e (subseq new-s 0 (length e)))))
+ '("WITH-" "DEF")))
+ (format nil "<i><span class=\"symbol\">~A</span></i>" s))
+ ((and (> (length new-s) 2)
+ (char= (elt new-s 0) #\*)
+ (char= (elt new-s (1- (length new-s))) #\*))
+ (format nil "<span class=\"special\">~A</span>" s))
+ (t s)))))
+ (:keyword (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"keyword\">~A</span>"
+ s)))
+ ((:comment :multiline)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ ((:character)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ ((:string)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ ((:single-escaped)
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ ((:syntax-error)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"syntaxerror\">~A</span>"
+ s)))))
+
+(define-coloring-type :scheme "Scheme"
+ :autodetect (lambda (text)
+ (or
+ (search "scheme" text :test #'char-equal)
+ (search "chicken" text :test #'char-equal)))
+ :parent :lisp
+ :transitions
+ (((:normal :in-list)
+ ((scan "...")
+ (set-mode :symbol
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((scan #\[)
+ (set-mode :in-list
+ :until (scan #\])))))
+ :formatters
+ (((:in-list)
+ (lambda (type s)
+ (declare (ignore type s))
+ (let ((*open-parens* (cons #\[ *open-parens*))
+ (*close-parens* (cons #\] *close-parens*)))
+ (call-parent-formatter))))
+ ((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((result (if (find-package :r5rs-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :elisp "Emacs Lisp"
+ :autodetect (lambda (name)
+ (member name '("emacs")
+ :test #'(lambda (name ext)
+ (search ext name :test #'char-equal))))
+ :parent :lisp
+ :formatters
+ (((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((result (if (find-package :elisp-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :common-lisp "Common Lisp"
+ :autodetect (lambda (text)
+ (search "lisp" text :test #'char-equal))
+ :parent :lisp
+ :transitions
+ (((:normal :in-list)
+ ((scan #\|)
+ (set-mode :escaped-symbol
+ :until (scan #\|)))))
+ :formatters
+ (((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let* ((colon (position #\: s :from-end t :test #'char=))
+ (to-lookup (if colon (subseq s (1+ colon)) s))
+ (result (if (find-package :clhs-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
+ to-lookup))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :common-lisp-file "Common Lisp File"
+ :parent :common-lisp
+ :default-mode :in-list
+ :invisible t)
+
+(defvar *c-open-parens* "([{")
+(defvar *c-close-parens* ")]}")
+
+(defvar *c-reserved-words*
+ '("auto" "break" "case" "char" "const"
+ "continue" "default" "do" "double" "else"
+ "enum" "extern" "float" "for" "goto"
+ "if" "int" "long" "register" "return"
+ "short" "signed" "sizeof" "static" "struct"
+ "switch" "typedef" "union" "unsigned" "void"
+ "volatile" "while" "__restrict" "_Bool"))
+
+(defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
+(defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))
+
+(define-coloring-type :basic-c "Basic C"
+ :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor)
+ :default-mode :normal
+ :invisible t
+ :transitions
+ ((:normal
+ ((scan-any *c-begin-word*)
+ (set-mode :word-ish
+ :until (scan-any *c-terminators*)
+ :advancing nil))
+ ((scan "/*")
+ (set-mode :comment
+ :until (scan "*/")))
+
+ ((or
+ (scan-any *c-open-parens*)
+ (scan-any *c-close-parens*))
+ (set-mode :paren-ish
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((or (scan "'\\")
+ (scan #\'))
+ (set-mode :character
+ :until (advance 2))))
+ (:string
+ ((scan #\\)
+ (set-mode :single-escape
+ :until (advance 1)))))
+ :formatter-variables
+ ((paren-counter 0))
+ :formatter-after-hook (lambda nil
+ (format nil "~{~A~}"
+ (loop for i from paren-counter downto 1
+ collect "</span></span>")))
+ :formatters
+ ((:normal
+ (lambda (type s)
+ (declare (ignore type))
+ s))
+ (:comment
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ (:string
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ (:character
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ (:single-escape
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ (:paren-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((open nil)
+ (count 0))
+ (if (eql (length s) 1)
+ (progn
+ (when (member (elt s 0) (coerce *c-open-parens* 'list))
+ (setf open t)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter))
+ (when (member (elt s 0) (coerce *c-close-parens* 'list))
+ (setf open nil)
+ (decf paren-counter)
+ (setf count (mod paren-counter 6)))
+ (if open
+ (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
+ (1+ count) s *css-background-class*)
+ (format nil "</span>~A</span>"
+ s)))
+ s))))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *c-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>" s)
+ s)))
+ ))
+
+(define-coloring-type :c "C"
+ :parent :basic-c
+ :transitions
+ ((:normal
+ ((scan #\#)
+ (set-mode :preprocessor
+ :until (scan-any '(#\return #\newline))))))
+ :formatters
+ ((:preprocessor
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"special\">~A</span>" s)))))
+
+(defvar *c++-reserved-words*
+ '("asm" "auto" "bool" "break" "case"
+ "catch" "char" "class" "const" "const_cast"
+ "continue" "default" "delete" "do" "double"
+ "dynamic_cast" "else" "enum" "explicit" "export"
+ "extern" "false" "float" "for" "friend"
+ "goto" "if" "inline" "int" "long"
+ "mutable" "namespace" "new" "operator" "private"
+ "protected" "public" "register" "reinterpret_cast" "return"
+ "short" "signed" "sizeof" "static" "static_cast"
+ "struct" "switch" "template" "this" "throw"
+ "true" "try" "typedef" "typeid" "typename"
+ "union" "unsigned" "using" "virtual" "void"
+ "volatile" "wchar_t" "while"))
+
+(define-coloring-type :c++ "C++"
+ :parent :c
+ :transitions
+ ((:normal
+ ((scan "//")
+ (set-mode :comment
+ :until (scan-any '(#\return #\newline))))))
+ :formatters
+ ((:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *c++-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>"
+ s)
+ s)))))
+
+(defvar *java-reserved-words*
+ '("abstract" "boolean" "break" "byte" "case"
+ "catch" "char" "class" "const" "continue"
+ "default" "do" "double" "else" "extends"
+ "final" "finally" "float" "for" "goto"
+ "if" "implements" "import" "instanceof" "int"
+ "interface" "long" "native" "new" "package"
+ "private" "protected" "public" "return" "short"
+ "static" "strictfp" "super" "switch" "synchronized"
+ "this" "throw" "throws" "transient" "try"
+ "void" "volatile" "while"))
+
+(define-coloring-type :java "Java"
+ :parent :c++
+ :formatters
+ ((:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *java-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>"
+ s)
+ s)))))
+
+(let ((terminate-next nil))
+ (define-coloring-type :objective-c "Objective C"
+ :autodetect (lambda (text) (search "mac" text :test #'char=))
+ :modes (:begin-message-send :end-message-send)
+ :transitions
+ ((:normal
+ ((scan #\[)
+ (set-mode :begin-message-send
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\])
+ (set-mode :end-message-send
+ :until (advance 1)
+ :advancing nil))
+ ((scan-any *c-begin-word*)
+ (set-mode :word-ish
+ :until (or
+ (and (peek-any '(#\:))
+ (setf terminate-next t))
+ (and terminate-next (progn
+ (setf terminate-next nil)
+ (advance 1)))
+ (scan-any *c-terminators*))
+ :advancing nil)))
+ (:word-ish
+ #+nil
+ ((scan #\:)
+ (format t "hi~%")
+ (set-mode :word-ish :until (advance 1) :advancing nil)
+ (setf terminate-next t))))
+ :parent :c++
+ :formatter-variables ((is-keyword nil) (in-message-send nil))
+ :formatters
+ ((:begin-message-send
+ (lambda (type s)
+ (setf is-keyword nil)
+ (setf in-message-send t)
+ (call-formatter (cons :paren-ish type) s)))
+ (:end-message-send
+ (lambda (type s)
+ (setf is-keyword nil)
+ (setf in-message-send nil)
+ (call-formatter (cons :paren-ish type) s)))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (prog1
+ (let ((result (if (find-package :cocoa-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result s)
+ (if (member s *c-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>" s)
+ (if in-message-send
+ (if is-keyword
+ (format nil "<span class=\"keyword\">~A</span>" s)
+ s)
+ s))))
+ (setf is-keyword (not is-keyword))))))))
+
+
+;#!/usr/bin/clisp
+;#+sbcl
+;(require :asdf)
+;(asdf:oos 'asdf:load-op :colorize)
+
+(defmacro with-each-stream-line ((var stream) &body body)
+ (let ((eof (gensym))
+ (eof-value (gensym))
+ (strm (gensym)))
+ `(let ((,strm ,stream)
+ (,eof ',eof-value))
+ (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
+ ((eql ,var ,eof))
+ ,@body))))
+
+(defun system (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *verbose-out*. Returns the shell's exit code."
+ (let ((command (apply #'format nil control-string args)))
+ (format t "; $ ~A~%" command)
+ #+sbcl
+ (sb-impl::process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *standard-output*))
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*))
+ #+clisp ;XXX not exactly *verbose-out*, I know
+ (ext:run-shell-command command :output :terminal :wait t)
+ ))
+
+(defun strcat (&rest strings)
+ (apply #'concatenate 'string strings))
+
+(defun string-starts-with (start str)
+ (and (>= (length str) (length start))
+ (string-equal start str :end2 (length start))))
+
+(defmacro string-append (outputstr &rest args)
+ `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defconstant +indent+ 2
+ "Indentation used in the examples.")
+
+(defun process-file (from to)
+ (with-open-file (output to :direction :output :if-exists :error)
+ (with-open-file (input from :direction :input)
+ (let ((inside-pre nil)
+ (piece-of-code ""))
+ (with-each-stream-line (line input)
+ (if inside-pre
+ (if (string-starts-with "</pre>" line)
+ (progn
+ ;(format t "-->~A<--~%" (decode-from-tt piece-of-code))
+ (let ((colored (colorize:html-colorization
+ :common-lisp
+ (decode-from-tt piece-of-code))))
+ (with-input-from-string (stream colored)
+ (with-each-stream-line (cline stream)
+ (format output " ~A~%" cline))))
+ (write-line line output)
+ (setq piece-of-code ""
+ inside-pre nil))
+ (let ((to-append (subseq line +indent+)))
+ (string-append piece-of-code
+ (if (string-equal "" to-append)
+ " "
+ to-append)
+ (string #\Newline))))
+ (if (string-starts-with "<pre class=\"lisp\">" line)
+ (progn
+ (setq inside-pre t)
+ (write-string "<pre class=\"lisp\">" output)
+ (string-append piece-of-code (subseq line (+ 18 +indent+))
+ (string #\Newline)))
+ (write-line line output))))))))
+
+(defun process-dir (dir)
+ (dolist (html-file (directory dir))
+ (let* ((name (namestring html-file))
+ (temp-name (strcat name ".temp")))
+ (process-file name temp-name)
+ (system "mv ~A ~A" temp-name name))))
+
+;; (go "/tmp/doc/manual/html_node/*.html")
+
+#+clisp
+(progn
+ (assert (first ext:*args*))
+ (process-dir (first ext:*args*)))
+
+#+sbcl
+(progn
+ (assert (second sb-ext:*posix-argv*))
+ (process-dir (second sb-ext:*posix-argv*))
+ (sb-ext:quit))
View
287 doc/gendocs.sh
@@ -0,0 +1,287 @@
+#!/bin/sh
+# gendocs.sh -- generate a GNU manual in many formats. This script is
+# mentioned in maintain.texi. See the help message below for usage details.
+# $Id: gendocs.sh,v 1.16 2005/05/15 00:00:08 karl Exp $
+#
+# Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, you can either send email to this
+# program's maintainer or write to: The Free Software Foundation,
+# Inc.; 51 Franklin Street, Fifth Floor; Boston, MA 02110-1301, USA.
+#
+# Original author: Mohit Agarwal.
+# Send bug reports and any other correspondence to bug-texinfo@gnu.org.
+
+prog="`basename \"$0\"`"
+srcdir=`pwd`
+
+scripturl="http://common-lisp.net/project/cffi/darcs/cffi/doc/gendocs.sh"
+templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template"
+
+: ${MAKEINFO="makeinfo"}
+: ${TEXI2DVI="texi2dvi -t @finalout"}
+: ${DVIPS="dvips"}
+: ${DOCBOOK2TXT="docbook2txt"}
+: ${DOCBOOK2HTML="docbook2html"}
+: ${DOCBOOK2PDF="docbook2pdf"}
+: ${DOCBOOK2PS="docbook2ps"}
+: ${GENDOCS_TEMPLATE_DIR="."}
+unset CDPATH
+
+rcs_revision='$Revision: 1.16 $'
+rcs_version=`set - $rcs_revision; echo $2`
+program=`echo $0 | sed -e 's!.*/!!'`
+version="gendocs.sh $rcs_version
+
+Copyright (C) 2005 Free Software Foundation, Inc.
+There is NO warranty. You may redistribute this software
+under the terms of the GNU General Public License.
+For more information about these matters, see the files named COPYING."
+
+usage="Usage: $prog [OPTION]... PACKAGE MANUAL-TITLE
+
+Generate various output formats from PACKAGE.texinfo (or .texi or .txi) source.
+See the GNU Maintainers document for a more extensive discussion:
+ http://www.gnu.org/prep/maintain_toc.html
+
+Options:
+ -o OUTDIR write files into OUTDIR, instead of manual/.
+ --docbook convert to DocBook too (xml, txt, html, pdf and ps).
+ --html ARG pass indicated ARG to makeinfo for HTML targets.
+ --help display this help and exit successfully.
+ --version display version information and exit successfully.
+
+Simple example: $prog emacs \"GNU Emacs Manual\"
+
+Typical sequence:
+ cd YOURPACKAGESOURCE/doc
+ wget \"$scripturl\"
+ wget \"$templateurl\"
+ $prog YOURMANUAL \"GNU YOURMANUAL - One-line description\"
+
+Output will be in a new subdirectory \"manual\" (by default, use -o OUTDIR
+to override). Move all the new files into your web CVS tree, as
+explained in the Web Pages node of maintain.texi.
+
+MANUAL-TITLE is included as part of the HTML <title> of the overall
+manual/index.html file. It should include the name of the package being
+documented. manual/index.html is created by substitution from the file
+$GENDOCS_TEMPLATE_DIR/gendocs_template. (Feel free to modify the
+generic template for your own purposes.)
+
+If you have several manuals, you'll need to run this script several
+times with different YOURMANUAL values, specifying a different output
+directory with -o each time. Then write (by hand) an overall index.html
+with links to them all.
+
+You can set the environment variables MAKEINFO, TEXI2DVI, and DVIPS to
+control the programs that get executed, and GENDOCS_TEMPLATE_DIR to
+control where the gendocs_template file is looked for.
+
+Email bug reports or enhancement requests to bug-texinfo@gnu.org.
+"
+
+calcsize()
+{
+ size="`ls -ksl $1 | awk '{print $1}'`"
+ echo $size
+}
+
+outdir=manual
+html=
+PACKAGE=
+MANUAL_TITLE=
+
+while test $# -gt 0; do
+ case $1 in
+ --help) echo "$usage"; exit 0;;
+ --version) echo "$version"; exit 0;;
+ -o) shift; outdir=$1;;
+ --docbook) docbook=yes;;
+ --html) shift; html=$1;;
+ -*)
+ echo "$0: Unknown or ambiguous option \`$1'." >&2
+ echo "$0: Try \`--help' for more information." >&2
+ exit 1;;
+ *)
+ if test -z "$PACKAGE"; then
+ PACKAGE=$1
+ elif test -z "$MANUAL_TITLE"; then
+ MANUAL_TITLE=$1
+ else
+ echo "$0: extra non-option argument \`$1'." >&2
+ exit 1
+ fi;;
+ esac
+ shift
+done
+
+if test -s $srcdir/$PACKAGE.texinfo; then
+ srcfile=$srcdir/$PACKAGE.texinfo
+elif test -s $srcdir/$PACKAGE.texi; then
+ srcfile=$srcdir/$PACKAGE.texi
+elif test -s $srcdir/$PACKAGE.txi; then
+ srcfile=$srcdir/$PACKAGE.txi
+else
+ echo "$0: cannot find .texinfo or .texi or .txi for $PACKAGE in $srcdir." >&2
+ exit 1
+fi
+
+if test ! -r $GENDOCS_TEMPLATE_DIR/gendocs_template; then
+ echo "$0: cannot read $GENDOCS_TEMPLATE_DIR/gendocs_template." >&2
+ echo "$0: it is available from $templateurl." >&2
+ exit 1
+fi
+
+echo Generating output formats for $srcfile
+
+cmd="${MAKEINFO} -o $PACKAGE.info $srcfile"
+echo "Generating info files... ($cmd)"
+eval $cmd
+mkdir -p $outdir/
+tar czf $outdir/$PACKAGE.info.tar.gz $PACKAGE.info*
+info_tgz_size="`calcsize $outdir/$PACKAGE.info.tar.gz`"
+# do not mv the info files, there's no point in having them available
+# separately on the web.
+
+cmd="${TEXI2DVI} $srcfile"
+echo "Generating dvi ... ($cmd)"
+eval $cmd
+
+# now, before we compress dvi:
+echo Generating postscript...
+${DVIPS} $PACKAGE -o
+gzip -f -9 $PACKAGE.ps
+ps_gz_size="`calcsize $PACKAGE.ps.gz`"
+mv $PACKAGE.ps.gz $outdir/
+
+# compress/finish dvi:
+gzip -f -9 $PACKAGE.dvi
+dvi_gz_size="`calcsize $PACKAGE.dvi.gz`"
+mv $PACKAGE.dvi.gz $outdir/
+
+cmd="${TEXI2DVI} --pdf $srcfile"
+echo "Generating pdf ... ($cmd)"
+eval $cmd
+pdf_size="`calcsize $PACKAGE.pdf`"
+mv $PACKAGE.pdf $outdir/
+
+cmd="${MAKEINFO} -o $PACKAGE.txt --no-split --no-headers $srcfile"
+echo "Generating ASCII... ($cmd)"
+eval $cmd
+ascii_size="`calcsize $PACKAGE.txt`"
+gzip -f -9 -c $PACKAGE.txt >$outdir/$PACKAGE.txt.gz
+ascii_gz_size="`calcsize $outdir/$PACKAGE.txt.gz`"
+mv $PACKAGE.txt $outdir/
+
+cmd="${MAKEINFO} --no-split --html -o $PACKAGE.html $html $srcfile"
+echo "Generating monolithic html... ($cmd)"
+rm -rf $PACKAGE.html # in case a directory is left over
+eval $cmd
+sbcl --load colorize-lisp-examples.lisp $PACKAGE.html
+html_mono_size="`calcsize $PACKAGE.html`"
+gzip -f -9 -c $PACKAGE.html >$outdir/$PACKAGE.html.gz
+html_mono_gz_size="`calcsize $outdir/$PACKAGE.html.gz`"
+mv $PACKAGE.html $outdir/
+
+cmd="${MAKEINFO} --html -o $PACKAGE.html $html $srcfile"
+echo "Generating html by node... ($cmd)"
+eval $cmd
+split_html_dir=$PACKAGE.html
+sbcl --load colorize-lisp-examples.lisp "${split_html_dir}/*.html"
+(
+ cd ${split_html_dir} || exit 1
+ tar -czf ../$outdir/${PACKAGE}.html_node.tar.gz -- *.html
+)
+html_node_tgz_size="`calcsize $outdir/${PACKAGE}.html_node.tar.gz`"
+rm -f $outdir/html_node/*.html
+mkdir -p $outdir/html_node/
+mv ${split_html_dir}/*.html $outdir/html_node/
+rmdir ${split_html_dir}
+
+echo Making .tar.gz for sources...
+srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null`
+tar cvzfh $outdir/$PACKAGE.texi.tar.gz $srcfiles
+texi_tgz_size="`calcsize $outdir/$PACKAGE.texi.tar.gz`"
+
+if test -n "$docbook"; then
+ cmd="${MAKEINFO} -o - --docbook $srcfile > ${srcdir}/$PACKAGE-db.xml"
+ echo "Generating docbook XML... $(cmd)"
+ eval $cmd
+ docbook_xml_size="`calcsize $PACKAGE-db.xml`"
+ gzip -f -9 -c $PACKAGE-db.xml >$outdir/$PACKAGE-db.xml.gz
+ docbook_xml_gz_size="`calcsize $outdir/$PACKAGE-db.xml.gz`"
+ mv $PACKAGE-db.xml $outdir/
+
+ cmd="${DOCBOOK2HTML} -o $split_html_db_dir ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook HTML... ($cmd)"
+ eval $cmd
+ split_html_db_dir=html_node_db
+ (
+ cd ${split_html_db_dir} || exit 1
+ tar -czf ../$outdir/${PACKAGE}.html_node_db.tar.gz -- *.html
+ )
+ html_node_db_tgz_size="`calcsize $outdir/${PACKAGE}.html_node_db.tar.gz`"
+ rm -f $outdir/html_node_db/*.html
+ mkdir -p $outdir/html_node_db
+ mv ${split_html_db_dir}/*.html $outdir/html_node_db/
+ rmdir ${split_html_db_dir}
+
+ cmd="${DOCBOOK2TXT} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook ASCII... ($cmd)"
+ eval $cmd
+ docbook_ascii_size="`calcsize $PACKAGE-db.txt`"
+ mv $PACKAGE-db.txt $outdir/
+
+ cmd="${DOCBOOK2PS} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook PS... $(cmd)"
+ eval $cmd
+ gzip -f -9 -c $PACKAGE-db.ps >$outdir/$PACKAGE-db.ps.gz
+ docbook_ps_gz_size="`calcsize $outdir/$PACKAGE-db.ps.gz`"
+ mv $PACKAGE-db.ps $outdir/
+
+ cmd="${DOCBOOK2PDF} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook PDF... ($cmd)"
+ eval $cmd
+ docbook_pdf_size="`calcsize $PACKAGE-db.pdf`"
+ mv $PACKAGE-db.pdf $outdir/
+fi
+
+echo Writing index file...
+curdate="`date '+%B %d, %Y'`"
+sed \
+ -e "s!%%TITLE%%!$MANUAL_TITLE!g" \
+ -e "s!%%DATE%%!$curdate!g" \
+ -e "s!%%PACKAGE%%!$PACKAGE!g" \
+ -e "s!%%HTML_MONO_SIZE%%!$html_mono_size!g" \
+ -e "s!%%HTML_MONO_GZ_SIZE%%!$html_mono_gz_size!g" \
+ -e "s!%%HTML_NODE_TGZ_SIZE%%!$html_node_tgz_size!g" \
+ -e "s!%%INFO_TGZ_SIZE%%!$info_tgz_size!g" \
+ -e "s!%%DVI_GZ_SIZE%%!$dvi_gz_size!g" \
+ -e "s!%%PDF_SIZE%%!$pdf_size!g" \
+ -e "s!%%PS_GZ_SIZE%%!$ps_gz_size!g" \
+ -e "s!%%ASCII_SIZE%%!$ascii_size!g" \
+ -e "s!%%ASCII_GZ_SIZE%%!$ascii_gz_size!g" \
+ -e "s!%%TEXI_TGZ_SIZE%%!$texi_tgz_size!g" \
+ -e "s!%%DOCBOOK_HTML_NODE_TGZ_SIZE%%!$html_node_db_tgz_size!g" \
+ -e "s!%%DOCBOOK_ASCII_SIZE%%!$docbook_ascii_size!g" \
+ -e "s!%%DOCBOOK_PS_GZ_SIZE%%!$docbook_ps_gz_size!g" \
+ -e "s!%%DOCBOOK_PDF_SIZE%%!$docbook_pdf_size!g" \
+ -e "s!%%DOCBOOK_XML_SIZE%%!$docbook_xml_size!g" \
+ -e "s!%%DOCBOOK_XML_GZ_SIZE%%!$docbook_xml_gz_size!g" \
+ -e "s,%%SCRIPTURL%%,$scripturl,g" \
+ -e "s!%%SCRIPTNAME%%!$prog!g" \
+$GENDOCS_TEMPLATE_DIR/gendocs_template >$outdir/index.html
+
+echo "Done! See $outdir/ subdirectory for new files."
View
259 doc/gendocs_template
@@ -0,0 +1,259 @@
+<?xml version="1.0" encoding="utf-8" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<!-- $Id: gendocs_template,v 1.7 2005/05/15 00:00:08 karl Exp $ -->
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
+
+<!--
+
+ This template was adapted from Texinfo:
+ http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template
+
+-->
+
+
+<head>
+<title>%%TITLE%%</title>
+<meta http-equiv="content-type" content='text/html; charset=utf-8' />
+<!-- <link rel="stylesheet" type="text/css" href="/gnu.css" /> -->
+<!-- <link rev="made" href="webmasters@gnu.org" /> -->
+<style>
+/* CSS style taken from http://gnu.org/gnu.css */
+
+html, body {
+ background-color: #FFFFFF;
+ color: #000000;
+ font-family: sans-serif;
+}
+
+a:link {
+ color: #1f00ff;
+ background-color: transparent;
+ text-decoration: underline;
+ }
+
+a:visited {
+ color: #9900dd;
+ background-color: transparent;
+ text-decoration: underline;
+ }
+
+a:hover {
+ color: #9900dd;
+ background-color: transparent;
+ text-decoration: none;
+ }
+
+.center {
+ text-align: center;
+}
+
+.italic {
+ font-style: italic;
+ }
+
+.bold {
+ font-weight: bold;
+ }
+
+.quote {
+ margin-left: 40px;
+ margin-right: 40px;
+}
+
+.hrsmall {
+ width: 80px;
+ height: 1px;
+ margin-left: 20px;
+}
+
+.td_title {
+ border-color: #3366cc;
+ border-style: solid;
+ border-width: thin;
+ color: #3366cc;
+ background-color : #f2f2f9;
+ font-weight: bold;
+}
+
+.td_con {
+ padding-top: 3px;
+ padding-left: 8px;
+ padding-bottom: 3px;
+ color : #303030;
+ background-color : #fefefe;
+ font-size: smaller;
+}
+
+.translations {
+ background-color: transparent;
+ color: black;
+ font-family: serif;
+ font-size: smaller;
+}
+
+.fsflink {
+ font-size: smaller;
+ font-family: monospace;
+ color : #000000;
+ border-left: #3366cc thin solid;
+ border-bottom: #3366cc thin solid;
+ padding-left: 5px;
+ padding-bottom: 5px;
+}
+
+/*
+ * rtl stands for right-to-left layout, as in farsi/persian,
+ * arabic, etc. See also trans_rtl.
+ */
+.fsflink_rtl {
+ font-size: smaller;
+ font-family: monospace;
+ color : #000000;
+ border-right: #3366cc thin solid;
+ border-bottom: #3366cc thin solid;
+ padding-right: 5px;
+ padding-bottom: 5px;
+}
+
+.trans {
+ font-size: smaller;
+ color : #000000;
+ border-left: #3366cc thin solid;
+ padding-left: 20px;
+}
+
+.trans_rtl {
+ font-size: smaller;
+ color : #000000;
+ border-right: #3366cc thin solid;
+ padding-right: 20px;
+}
+
+img {
+ border: none 0;
+}
+
+td.side {
+ color: #3366cc;
+/* background: #f2f2f9;
+ border-color: #3366cc;
+ border-style: solid;
+ border-width: thin; */
+ border-color: white;
+ border-style: none;
+ vertical-align: top;
+ width: 150px;
+}
+
+div.copyright {
+ font-size: 80%;
+ border: 2px solid #3366cc;
+ padding: 4px;
+ background: #f2f2f9;
+ border-style: solid;
+ border-width: thin;
+}
+
+.footnoteref {
+ font-size: smaller;
+ vertical-align: text-top;
+}
+</style>
+</head>
+
+<!-- This document is in XML, and xhtml 1.0 -->
+<!-- Please make sure to properly nest your tags -->
+<!-- and ensure that your final document validates -->
+<!-- consistent with W3C xhtml 1.0 and CSS standards -->
+<!-- See validator.w3.org -->
+
+<body>
+
+<h3>%%TITLE%%</h3>
+
+<!-- <address>Free Software Foundation</address> -->
+<address>last updated %%DATE%%</address>
+
+<!--
+<p>
+<a href="/graphics/gnu-head.jpg">
+ <img src="/graphics/gnu-head-sm.jpg"
+ alt=" [image of the head of a GNU] "
+ width="129" height="122" />
+</a>
+<a href="/philosophy/gif.html">(no gifs due to patent problems)</a>
+</p>
+-->
+
+<hr />
+
+<p>This document <!--(%%PACKAGE%%)--> is available in the following formats:</p>
+
+<ul>
+ <li><a href="%%PACKAGE%%.html">HTML
+ (%%HTML_MONO_SIZE%%K characters)</a> - entirely on one web page.</li>
+ <li><a href="html_node/index.html">HTML</a> - with one web page per
+ node.</li>
+ <li><a href="%%PACKAGE%%.html.gz">HTML compressed
+ (%%HTML_MONO_GZ_SIZE%%K gzipped characters)</a> - entirely on
+ one web page.</li>
+ <li><a href="%%PACKAGE%%.html_node.tar.gz">HTML compressed
+ (%%HTML_NODE_TGZ_SIZE%%K gzipped tar file)</a> -
+ with one web page per node.</li>
+ <li><a href="%%PACKAGE%%.info.tar.gz">Info document
+ (%%INFO_TGZ_SIZE%%K characters gzipped tar file)</a>.</li>
+ <li><a href="%%PACKAGE%%.txt">ASCII text
+ (%%ASCII_SIZE%%K characters)</a>.</li>
+ <li><a href="%%PACKAGE%%.txt.gz">ASCII text compressed
+ (%%ASCII_GZ_SIZE%%K gzipped characters)</a>.</li>
+ <li><a href="%%PACKAGE%%.dvi.gz">TeX dvi file
+ (%%DVI_GZ_SIZE%%K characters gzipped)</a>.</li>
+ <li><a href="%%PACKAGE%%.ps.gz">PostScript file
+ (%%PS_GZ_SIZE%%K characters gzipped)</a>.</li>
+ <li><a href="%%PACKAGE%%.pdf">PDF file
+ (%%PDF_SIZE%%K characters)</a>.</li>
+ <li><a href="%%PACKAGE%%.texi.tar.gz">Texinfo source
+ (%%TEXI_TGZ_SIZE%%K characters gzipped tar file)</a></li>
+</ul>
+
+<p>(This page was generated by the <a href="%%SCRIPTURL%%">%%SCRIPTNAME%%
+script</a>.)</p>
+
+<div class="copyright">
+<p>
+Return to <a href="/project/cffi/">CFFI's home page</a>.
+</p>
+
+<!--
+<p>
+Please send FSF &amp; GNU inquiries to
+<a href="mailto:gnu@gnu.org"><em>gnu@gnu.org</em></a>.
+There are also <a href="/home.html#ContactInfo">other ways to contact</a>
+the FSF.
+<br />
+Please send broken links and other corrections (or suggestions) to
+<a href="mailto:webmasters@gnu.org"><em>webmasters@gnu.org</em></a>.
+</p>
+-->
+
+<p>
+Copyright (C) 2005 James Bielman &lt;jamesjb at jamesjb.com&gt;<br />
+Copyright (C) 2005 Lu&iacute;s Oliveira &lt;loliveira at common-lisp.net&gt;
+<!--
+<br />
+Verbatim copying and distribution of this entire article is
+permitted in any medium, provided this notice is preserved.
+-->
+</p>
+
+<p>
+Updated: %%DATE%%
+<!-- timestamp start -->
+<!-- $Date: 2005/05/15 00:00:08 $ $Author: karl $ -->
+<!-- timestamp end -->
+</p>
+</div>
+
+</body>
+</html>
View
382 doc/manual.texinfo
@@ -1,382 +0,0 @@
-\input texinfo @c -*-texinfo-*-
-@c %**start of header
-@setfilename cffi.info
-@settitle CFFI User Manual
-@c %**end of header
-
-@c Show types in the same index as the functions.
-@synindex tp fn
-
-@copying
-Copyright @copyright{} 2005, James Bielman <jamesjb at jamesjb.com>
-
-@quotation
-Permission is hereby granted, free of charge, to any person
-obtaining a copy of this software and associated documentation
-files (the ``Software''), to deal in the Software without
-restriction, including without limitation the rights to use, copy,
-modify, merge, publish, distribute, sublicense, and/or sell copies
-of the Software, and to permit persons to whom the Software is
-furnished to do so, subject to the following conditions:
-
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
-DEALINGS IN THE SOFTWARE.
-@end quotation
-@end copying
-
-@titlepage
-@title CFFI User Manual
-@c @subtitle Version X.X
-@c @author James Bielman
-
-@page
-@vskip 0pt plus 1filll
-@insertcopying
-@end titlepage
-
-@contents
-
-@ifnottex
-@node Top
-@top cffi
-@insertcopying
-@end ifnottex
-
-@menu
-* Introduction::
-* Foreign Types::
-* Foreign Pointers::
-* Foreign Functions::
-* Foreign Libraries::
-* Limitations::
-* Symbol Index::
-@end menu
-
-@node Introduction
-@chapter Introduction
-
-@section Motivation
-
-@section Design Philosophy
-
-@itemize
-@item Pointers do not carry around type information. Instead, type
- information is supplied when pointers are dereferenced.
-@item A type safe pointer interface can be developed on top of an
- untyped one. It is difficult to do the opposite.
-@item Functions are better than macros. When a macro could be used
- for performance, use a compiler-macro instead.
-@end itemize
-
-
-@node Foreign Types
-@chapter Foreign Types
-
-@section Built-In Types
-
-@deftp {Foreign Type} :char
-@end deftp
-@deftp {Foreign Type} :unsigned-char
-@end deftp
-@deftp {Foreign Type} :short
-@end deftp
-@deftp {Foreign Type} :unsigned-short
-@end deftp
-@deftp {Foreign Type} :int
-@end deftp
-@deftp {Foreign Type} :unsigned-int
-@end deftp
-@deftp {Foreign Type} :long
-@end deftp
-@deftp {Foreign Type} :unsigned-long
-@end deftp
-@deftp {Foreign Type} :long-long
-@end deftp
-@deftp {Foreign Type} :unsigned-long-long
-These types correspond to the native C integer types according to the
-ABI of the system the Lisp implementation is compiled against.
-@end deftp
-
-@deftp {Foreign Type} :int8
-@end deftp
-@deftp {Foreign Type} :uint8
-@end deftp
-@deftp {Foreign Type} :int16
-@end deftp
-@deftp {Foreign Type} :uint16
-@end deftp
-@deftp {Foreign Type} :int32
-@end deftp
-@deftp {Foreign Type} :uint32
-@end deftp
-@deftp {Foreign Type} :int64
-@end deftp
-@deftp {Foreign Type} :uint64
-Foreign integer types of specific sizes, corresponding to the C types
-defined in @code{stdint.h}.
-@end deftp
-
-@deftp {Foreign Type} :size
-@end deftp
-@deftp {Foreign Type} :ssize
-@end deftp
-@deftp {Foreign Type} :ptrdiff
-@end deftp
-@deftp {Foreign Type} :time
-Foreign integer types corresponding to the standard C types (without
-the @code{_t} suffix).
-@end deftp
-
-@emph{I'm sure there are more of these that could be useful, let's
-add any types that can't be defined portably to this list as
-necessary.}
-
-@deftp {Foreign Type} :float
-@end deftp
-@deftp {Foreign Type} :double
-The @code{:float} type represents a C @code{float} and a Lisp
-@code{single-float}. @code{:double} represents a C @code{double} and a
-Lisp @code{double-float}.
-@end deftp
-
-@deftp {Foreign Type} :pointer
-A foreign pointer to an object of any type, corresponding to
-@code{void *}.
-@end deftp
-
-@deftp {Foreign Type} :void
-No type at all. Only valid as the return type of a function.
-@end deftp
-
-@section Defining Typedefs
-
-@defmac defctype name type &optional documentation
-@end defmac
-
-@section Foreign Structure Types
-
-@defmac defcstruct name &body doc-options-and-slots
-@end defmac
-
-A structure slot is either simple, or aggregate.
-
-Simple structure slots contain a single instance of a type that
-canonicalizes to a built-in type, such as @code{:long} or
-@code{:pointer}.
-
-Aggregate slots contain an embedded structure or union, or an array
-of objects.
-
-@subsubheading Example:
-
-@lisp
-(defcstruct timeval
- (tv-sec :long)
- (tv-usec :long))
-@end lisp
-
-@deffn {Accessor} foreign-slot-value ptr type &rest slot-names => object
-For simple slots, @code{foreign-slot-value} returns the value of the
-object, such as a Lisp integer or pointer. In C, this would be
-expressed as @code{ptr->slot}.
-
-For aggregate slots, a pointer inside the structure to the beginning
-of the slot's data is returned. In C, this would be expressed as
-@code{&ptr->slot}. This pointer and the memory it points to have the
-same extent as @code{ptr}.
-
-There are compiler macros for @code{foreign-slot-value} and its
-@code{setf} expansion that open code the memory access when
-@code{type} and @code{slot-names} are constant at compile-time.
-@end deffn
-
-@defmac explain-foreign-slot-value ptr type &rest slot-names
-This macro translates the slot access that would occur by calling
-@code{FOREIGN-SLOT-VALUE} with the same arguments into an equivalent
-expression in C and prints it to @code{*STANDARD-OUTPUT*}.
-@end defmac
-
-@subsubheading Examples:
-
-@lisp
-CFFI> (explain-foreign-slot-value ptr 'timeval 'tv-secs)
-ptr->tv_secs
-
-CFFI> (explain-foreign-slot-value emp 'employee 'hire-date 'tv-usecs)
-emp->hire_date.tv_usecs
-@end lisp
-
-@defun foreign-slot-pointer ptr type &rest slot-names => pointer
-Returns a pointer to a slot referred by @code{slot-names} in a foreign
-object of type @code{type} at @code{ptr}. The returned pointer points
-inside the structure. Both the pointer and the memory it points to
-have the same extent as @code{ptr}.
-
-For aggregate slots, this is the same value returned by
-@code{foreign-slot-value}.
-@end defun
-
-@subheading Foreign Structure Example
-
-@lisp
-;; A hairy structure definition that illustrates some of the rules
-;; governing foreign structs.
-(defcstruct person
- "A person in the employee database."
- ;; the first argument after the name may be a docstring
- :alignment :packed ;; keyword options allowed before first slot
- (id :int)
- ;; these are defined as char[255]'s in the c code
- (first-name :char 255)
- (last-name :char 255)
- ;; an embedded structure
- (birthdate timeval)
- ;; a pointer to another PERSON
- (supervisor :pointer))
-
-;;; If P is a pointer to a PERSON structure:
-
-;; This returns p->first_name, a pointer.
-(foreign-slot-value p 'person 'first-name)
-
-;; This returns &p->birthdate, a pointer.
-(foreign-slot-value p 'person 'birthdate)
-
-;; This returns p->birthdate.tv_secs as a Lisp integer.
-(foreign-slot-value p 'person 'birthdate 'tv-secs)
-
-;; The previous form is equivalent to (but may be faster than):
-(foreign-slot-value
- (foreign-slot-value p 'person 'birthdate) 'timeval 'tv-secs)
-
-;; Attempting to set the slot value of an embedded structure or
-;; embedded array causes an error. Eventually, there may be a
-;; type converter that can handle this situation for some types.
-;; This would be: p->birthdate = ... in C.
-(setf (foreign-slot-value p 'person 'timeval) ...) => error
-@end lisp
-
-@section Operations on Types
-
-@defun builtin-foreign-type-p type => boolean
-@end defun
-
-@defun canonicalize-foreign-type type => built-in-type
-@end defun
-
-@defun foreign-type-size type => size
-@end defun
-
-@defun foreign-type-alignment type => alignment
-@end defun
-
-@emph{Should these functions be part of the documented interface? They
-may be useful for libraries built on top of CFFI---defining a type-safe
-interface on top of CFFI pointers, for example.}
-
-@section Allocating Foreign Objects
-
-@defun foreign-object-alloc type &optional (count 1) => ptr
-@end defun
-
-@lisp
-(let ((ptr (foreign-object-alloc <type> <count>)))
- ...)
-
-==>
-
-@{
- void *ptr = malloc(sizeof(<type>) * <count>);
-
- if (ptr == NULL)
- raise_storage_condition();
-
- ...
-@}
-@end lisp
-
-@defun foreign-object-free ptr => unspecified
-@end defun
-
-@lisp
-(foreign-object-free ptr)
-
-==>
-
-free(ptr);
-@end lisp
-
-@defmac with-foreign-object (var type &optional (count 1)) &body body
-@end defmac
-
-@lisp
-(with-foreign-object (ptr <type> <count>)
- ...)
-
-==>
-@{
- void *ptr = alloca(sizeof(<type>) * <count>);
- ...
-@}
-@end lisp
-
-
-@node Foreign Pointers
-@chapter Foreign Pointers
-
-@emph{Describe the theory of how foreign variables work---they are
-always pointers, even when accessing integer types or embedded
-structures. You cannot represent a structure by value.}
-
-@section Basic Pointer Operations
-
-@section Allocating Foreign Memory
-
-@section Accessing Foreign Memory
-
-
-@node Foreign Functions
-@chapter Foreign Functions
-
-@section Calling Foreign Functions
-
-@section Defining Foreign Functions
-
-@section Foreign Type Translators
-
-@subsubheading Example:
-
-@lisp
-;; Here is how the CFFI:BOOLEAN type translator is defined:
-(define-type-translator boolean :in (arg result-var)
- "Type translator to convert t/nil to a C boolean."
- (values `(if ,arg 1 0) nil))
-
-(define-type-translator boolean :result (arg result-var)
- "Type translator to convert C booleans to t/nil."
- (values `(if (zerop ,arg) nil t)))
-@end lisp
-
-
-@node Foreign Libraries
-@chapter Foreign Libraries
-
-
-@node Limitations
-@chapter Limitations
-
-
-@node Symbol Index
-@unnumbered Symbol Index
-@printindex fn
-
-@bye
View
34 doc/style.css
@@ -5,9 +5,43 @@ body {font-family: century schoolbook, serif;
table {border-collapse: collapse}
span.roman { font-family: century schoolbook, serif; font-weight: normal; }
h1, h2, h3, h4, h5, h6 {font-family: Helvetica, sans-serif}
+/*h4 {padding-top: 0.75em;}*/
dfn {font-family: inherit; font-variant: italic; font-weight: bolder }
kbd {font-family: monospace; text-decoration: underline}
var {font-family: Helvetica, sans-serif; font-variant: slanted}
td {padding-right: 1em; padding-left: 1em}
sub {font-size: smaller}
.node {padding: 0; margin: 0}
+
+.lisp { font-family: monospace;
+ background-color: #F4F4F4; border: 1px solid #AAA;
+ padding-top: 0.5em; padding-bottom: 0.5em; }
+
+/* coloring */
+
+.lisp-bg { background-color: #F4F4F4 ; color: black; }
+.lisp-bg:hover { background-color: #F4F4F4 ; color: black; }
+
+.symbol { font-weight: bold; color: #770055; background-color : transparent; border: 0px; margin: 0px;}
+a.symbol:link { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:active { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:visited { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:hover { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+.special { font-weight: bold; color: #FF5000; background-color: inherit; }
+.keyword { font-weight: bold; color: #770000; background-color: inherit; }
+.comment { font-weight: normal; color: #007777; background-color: inherit; }
+.string { font-weight: bold; color: #777777; background-color: inherit; }
+.character { font-weight: bold; color: #0055AA; background-color: inherit; }
+.syntaxerror { font-weight: bold; color: #FF0000; background-color: inherit; }
+span.paren1 { font-weight: bold; color: #777777; }
+span.paren1:hover { color: #777777; background-color: #BAFFFF; }
+span.paren2 { color: #777777; }
+span.paren2:hover { color: #777777; background-color: #FFCACA; }
+span.paren3 { color: #777777; }
+span.paren3:hover { color: #777777; background-color: #FFFFBA; }
+span.paren4 { color: #777777; }
+span.paren4:hover { color: #777777; background-color: #CACAFF; }
+span.paren5 { color: #777777; }
+span.paren5:hover { color: #777777; background-color: #CAFFCA; }
+span.paren6 { color: #777777; }
+span.paren6:hover { color: #777777; background-color: #FFBAFF; }
View
7 src/enum.lisp
@@ -79,7 +79,7 @@
(error "~S is not defined as a keyword for enym type ~S."
keyword type)))
-(defun foreign-enum-values (type keyword)
+(defun foreign-enum-value (type keyword)
(let ((type-obj (parse-type type)))
(if (not (typep type-obj 'foreign-enum))
(error "~S is not a foreign enum type." type)
@@ -97,11 +97,12 @@
(error "~S is not a foreign enum type." type)
(%foreign-enum-keyword type-obj value))))
-(defmacro defcenum (name &body values)
+(defmacro defcenum (name &body enum-list)
"Define an foreign enumerated type."
+ (discard-docstring enum-list)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(notice-foreign-type
- (make-foreign-enum ',name :int ',values))
+ (make-foreign-enum ',name :int ',enum-list))
;; to-c translator
(define-type-translator ,name :to-c (type value)
`(if (keywordp ,value)
View
12 src/foreign-vars.lisp
@@ -37,12 +37,17 @@
(format nil "*~A*"
(string-upcase (substitute #\- #\_ name)))))))
-;; TODO: also convert lisp-name -> foreign-name? --luis
(defun foreign-var-name (name)
"Return the foreign var name of NAME."
(etypecase name
(list (first name))
- (string name)))
+ (string name)
+ (symbol
+ (let ((sn (substitute #\_ #\- (string-downcase (symbol-name name)))))
+ (if (eql (char sn 0) #\*)
+ ;; remove asterisks around the var name
+ (subseq 1 (1- (length sn)))
+ sn)))))
(defun get-var-ptr (symbol)
"Return a pointer to the foreign global variable relative to SYMBOL."
@@ -52,7 +57,7 @@
"Define a foreign global variable."
(let* ((lisp-name (lisp-var-name name))
(foreign-name (foreign-var-name name))
- (fn (intern (concatenate 'string "%access-var-" foreign-name))))
+ (fn (symbolicate "%VAR-ACCESSOR-" lisp-name)))
`(progn
(setf (get ',lisp-name 'cffi-ptr-to-var)
(foreign-var-ptr ,foreign-name))
@@ -61,6 +66,7 @@
(var (mem-ref (get-var-ptr ',lisp-name) ',type) ,type :from-c)
var))
(defun (setf ,fn) (value)
+ ,(if read-only '(declare (ignore value)) (values))
,(if read-only
`(error ,(format nil "Trying to modify read-only foreign var: ~A."
lisp-name))
View
34 src/functions.lisp
@@ -62,18 +62,18 @@
if arg collect type into types
and collect (canonicalize-foreign-type type) into ctypes
and collect arg into fargs
- else do (setf return-type (canonicalize-foreign-type type))
+ else do (setf return-type type)
finally (return (values types ctypes fargs return-type)))))
(defmacro foreign-funcall (name &rest args)
"Wrapper around %FOREIGN-FUNCALL that translates its arguments."
(multiple-value-bind (types ctypes fargs rettype)
(parse-args-and-types args)
- (let ((syms (loop repeat (length fargs) collect (gensym))))
- `(translate-objects ,syms ,fargs ,types ,rettype
- (%foreign-funcall ,name
- ,@(mapcan #'list ctypes syms)
- ,rettype)))))
+ (let ((syms (make-gensym-list (length fargs))))
+ `(translate-objects
+ ,syms ,fargs ,types ,rettype
+ (%foreign-funcall ,name ,@(mapcan #'list ctypes syms)
+ ,(canonicalize-foreign-type rettype))))))
;;;# Defining Foreign Functions
;;;
@@ -84,13 +84,15 @@
"Return the Lisp function name for foreign function NAME."
(etypecase name
(list (second name))
- (string (intern (string-upcase (substitute #\- #\_ name))))))
+ (string (intern (string-upcase (substitute #\- #\_ name))))
+ (symbol name)))
(defun foreign-function-name (name)
"Return the foreign function name of NAME."
(etypecase name
(list (first name))
- (string name)))
+ (string name)
+ (symbol (substitute #\_ #\- (string-downcase (symbol-name name))))))
;; If cffi-sys doesn't provide a defcfun-helper-forms,
;; we define one that uses %foreign-funcall.
@@ -108,7 +110,7 @@
(foreign-name (foreign-function-name name))
(arg-names (mapcar #'car args))
(arg-types (mapcar #'cadr args))
- (syms (loop repeat (length args) collect (gensym))))
+ (syms (make-gensym-list (length args))))
(multiple-value-bind (prelude caller)
(defcfun-helper-forms
foreign-name lisp-name (canonicalize-foreign-type return-type)
@@ -145,9 +147,11 @@
(discard-docstring body)
(let ((arg-names (mapcar #'car args))
(arg-types (mapcar #'cadr args)))
- `(setf (callback ,name)
- (make-callback
- ,name ,(canonicalize-foreign-type return-type)
- ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
- (inverse-translate-objects ,arg-names ,arg-types ,return-type
- (block ,name ,@body))))))
+ `(progn
+ (setf (callback ,name)
+ (make-callback
+ ,name ,(canonicalize-foreign-type return-type)
+ ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
+ (inverse-translate-objects ,arg-names ,arg-types ,return-type
+ (block ,name ,@body))))
+ ',name)))
View
6 src/strings.lisp
@@ -90,16 +90,16 @@ the return value of an implcit PROGN around BODY."
(defctype :string :pointer)
(define-type-translator :string :to-c-dynamic (type value var body)
- "Type translator for string input arguments."
+ "Convert a lisp string to a foreign string with dynamic extent."
`(with-foreign-string (,var ,value)
,@body))
(define-type-translator :string :to-c (type value)
- "Type translator for string arguments."
+ "Convert a lisp string to a foreign string."
`(foreign-string-alloc ,value))
(define-type-translator :string :from-c (type value)
- "Type translator for string arguments."
+ "Convert a foreign string to a lisp string."
`(foreign-string-to-lisp ,value))
;;; It'd be pretty nice if returning multiple values from translators
View
4 src/types.lisp
@@ -113,7 +113,7 @@ to open-code (SETF MEM-REF) forms."
(if (constantp index)
`(mem-set ,store ,getter ,type
,(* (eval index) (foreign-type-size (eval type))))
- `(mem-ref ,store ,getter ,type
+ `(mem-set ,store ,getter ,type
(* ,index ,(foreign-type-size (eval type)))))
`(mem-set ,store ,getter ,type
(* ,index (foreign-type-size ,type))))
@@ -253,6 +253,7 @@ to open-code (SETF MEM-REF) forms."
(defmacro defcstruct (name &body fields)
"Define the layout of a foreign structure."
+ (discard-docstring fields)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(notice-foreign-struct-definition ',name ',fields)))
@@ -353,6 +354,7 @@ foreign slots in PTR of TYPE. Similar to WITH-SLOTS."
(defmacro defcunion (name &body fields)
"Define the layout of a foreign union."
+ (discard-docstring fields)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(notice-foreign-union-definition ',name ',fields)))
View
26 tests/callbacks.lisp
@@ -137,3 +137,29 @@
(deftest callbacks.string
(expect-strcat (callback lisp-strcat))
1)
+
+;;; This one tests mem-aref too.
+(defcfun "qsort" :void
+ (base :pointer)
+ (nmemb :int)
+ (size :int)
+ (fun-compar :pointer))
+
+(defcallback < :int ((a :pointer) (b :pointer))
+ (let ((x (mem-ref a :int))
+ (y (mem-ref b :int)))
+ (cond ((> x y) 1)
+ ((< x y) -1)
+ (t 0))))
+
+(deftest callbacks.qsort
+ (with-foreign-object (array :int 10)
+ ;; Initialize array.
+ (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8)
+ do (setf (mem-aref array :int i) n))
+ ;; Sort it.
+ (qsort array 10 (foreign-type-size :int) (callback <))
+ ;; Return it as a list.
+ (loop for i from 0 below 10
+ collect (mem-aref array :int i)))
+ (1 2 3 4 5 6 7 8 9 10))
View
8 tests/funcall.lisp
@@ -68,6 +68,12 @@
(foreign-funcall "strcat" :pointer s :string ", world!" :pointer))
"Hello, world!")
+(deftest funcall.string.3
+ (with-foreign-ptr (ptr 100)
+ (lisp-string-to-foreign "Hello, " ptr 8)
+ (foreign-funcall "strcat" :pointer ptr :string "world!" :string))
+ "Hello, world!")
+
;;;# Calling Varargs Functions
;; The CHAR argument must be passed as :INT because chars are promoted
@@ -107,4 +113,4 @@
:string "Hello" :string "world" :void))
"Hello, world!")
-) ;; #-cffi/no-foreign-funcall
+) ;; #-cffi/no-foreign-funcall

0 comments on commit 67fbc31

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