summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGES4
-rw-r--r--docs/src/cmdline.txt6
-rw-r--r--pygments/lexers/_clbuiltins.py232
-rw-r--r--pygments/lexers/_mapping.py4
-rw-r--r--pygments/lexers/agile.py2
-rw-r--r--pygments/lexers/functional.py182
-rw-r--r--pygments/lexers/text.py62
-rw-r--r--tests/examplefiles/type.lisp1202
8 files changed, 1683 insertions, 11 deletions
diff --git a/CHANGES b/CHANGES
index 1213e59d..33686aa0 100644
--- a/CHANGES
+++ b/CHANGES
@@ -10,11 +10,13 @@ Version 0.9
* Erlang
* ActionScript
* Literate Haskell
+ * Common Lisp
* Various assembly languages
* Gettext catalogs
* Squid configuration
+ * Debian control files
+ * MySQL-style SQL
* MOOCode
- * MySQL
- Lexers improved:
diff --git a/docs/src/cmdline.txt b/docs/src/cmdline.txt
index 6cdec40e..5950d425 100644
--- a/docs/src/cmdline.txt
+++ b/docs/src/cmdline.txt
@@ -44,9 +44,9 @@ quote the option value in this case too, so that the shell doesn't split it).
Since the ``-O`` option argument is split at commas and expects the split values
to be of the form ``name=value``, you can't give an option value that contains
-commas or equals signs. Therefore, an option ``-P`` is provided that works like
-``-O`` but can only pass one option per ``-P``. Its value can then contain all
-characters::
+commas or equals signs. Therefore, an option ``-P`` is provided (as of Pygments
+0.9) that works like ``-O`` but can only pass one option per ``-P``. Its value
+can then contain all characters::
$ pygmentize -P "heading=Pygments, the Python highlighter" ...
diff --git a/pygments/lexers/_clbuiltins.py b/pygments/lexers/_clbuiltins.py
new file mode 100644
index 00000000..0792798e
--- /dev/null
+++ b/pygments/lexers/_clbuiltins.py
@@ -0,0 +1,232 @@
+# -*- coding: utf-8 -*-
+"""
+ pygments.lexers._clbuiltins
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ ANSI Common Lisp builtins.
+
+ :copyright: 2006-2007 by Matteo Sasso.
+ :license: BSD, see LICENSE for more details.
+"""
+
+BUILTIN_FUNCTIONS = [ # 638 functions
+ '<', '<=', '=', '>', '>=', '-', '/', '/=', '*', '+', '1-', '1+',
+ 'abort', 'abs', 'acons', 'acos', 'acosh', 'add-method', 'adjoin',
+ 'adjustable-array-p', 'adjust-array', 'allocate-instance',
+ 'alpha-char-p', 'alphanumericp', 'append', 'apply', 'apropos',
+ 'apropos-list', 'aref', 'arithmetic-error-operands',
+ 'arithmetic-error-operation', 'array-dimension', 'array-dimensions',
+ 'array-displacement', 'array-element-type', 'array-has-fill-pointer-p',
+ 'array-in-bounds-p', 'arrayp', 'array-rank', 'array-row-major-index',
+ 'array-total-size', 'ash', 'asin', 'asinh', 'assoc', 'assoc-if',
+ 'assoc-if-not', 'atan', 'atanh', 'atom', 'bit', 'bit-and', 'bit-andc1',
+ 'bit-andc2', 'bit-eqv', 'bit-ior', 'bit-nand', 'bit-nor', 'bit-not',
+ 'bit-orc1', 'bit-orc2', 'bit-vector-p', 'bit-xor', 'boole',
+ 'both-case-p', 'boundp', 'break', 'broadcast-stream-streams',
+ 'butlast', 'byte', 'byte-position', 'byte-size', 'caaaar', 'caaadr',
+ 'caaar', 'caadar', 'caaddr', 'caadr', 'caar', 'cadaar', 'cadadr',
+ 'cadar', 'caddar', 'cadddr', 'caddr', 'cadr', 'call-next-method', 'car',
+ 'cdaaar', 'cdaadr', 'cdaar', 'cdadar', 'cdaddr', 'cdadr', 'cdar',
+ 'cddaar', 'cddadr', 'cddar', 'cdddar', 'cddddr', 'cdddr', 'cddr', 'cdr',
+ 'ceiling', 'cell-error-name', 'cerror', 'change-class', 'char', 'char<',
+ 'char<=', 'char=', 'char>', 'char>=', 'char/=', 'character',
+ 'characterp', 'char-code', 'char-downcase', 'char-equal',
+ 'char-greaterp', 'char-int', 'char-lessp', 'char-name',
+ 'char-not-equal', 'char-not-greaterp', 'char-not-lessp', 'char-upcase',
+ 'cis', 'class-name', 'class-of', 'clear-input', 'clear-output',
+ 'close', 'clrhash', 'code-char', 'coerce', 'compile',
+ 'compiled-function-p', 'compile-file', 'compile-file-pathname',
+ 'compiler-macro-function', 'complement', 'complex', 'complexp',
+ 'compute-applicable-methods', 'compute-restarts', 'concatenate',
+ 'concatenated-stream-streams', 'conjugate', 'cons', 'consp',
+ 'constantly', 'constantp', 'continue', 'copy-alist', 'copy-list',
+ 'copy-pprint-dispatch', 'copy-readtable', 'copy-seq', 'copy-structure',
+ 'copy-symbol', 'copy-tree', 'cos', 'cosh', 'count', 'count-if',
+ 'count-if-not', 'decode-float', 'decode-universal-time', 'delete',
+ 'delete-duplicates', 'delete-file', 'delete-if', 'delete-if-not',
+ 'delete-package', 'denominator', 'deposit-field', 'describe',
+ 'describe-object', 'digit-char', 'digit-char-p', 'directory',
+ 'directory-namestring', 'disassemble', 'documentation', 'dpb',
+ 'dribble', 'echo-stream-input-stream', 'echo-stream-output-stream',
+ 'ed', 'eighth', 'elt', 'encode-universal-time', 'endp',
+ 'enough-namestring', 'ensure-directories-exist',
+ 'ensure-generic-function', 'eq', 'eql', 'equal', 'equalp', 'error',
+ 'eval', 'evenp', 'every', 'exp', 'export', 'expt', 'fboundp',
+ 'fceiling', 'fdefinition', 'ffloor', 'fifth', 'file-author',
+ 'file-error-pathname', 'file-length', 'file-namestring',
+ 'file-position', 'file-string-length', 'file-write-date',
+ 'fill', 'fill-pointer', 'find', 'find-all-symbols', 'find-class',
+ 'find-if', 'find-if-not', 'find-method', 'find-package', 'find-restart',
+ 'find-symbol', 'finish-output', 'first', 'float', 'float-digits',
+ 'floatp', 'float-precision', 'float-radix', 'float-sign', 'floor',
+ 'fmakunbound', 'force-output', 'format', 'fourth', 'fresh-line',
+ 'fround', 'ftruncate', 'funcall', 'function-keywords',
+ 'function-lambda-expression', 'functionp', 'gcd', 'gensym', 'gentemp',
+ 'get', 'get-decoded-time', 'get-dispatch-macro-character', 'getf',
+ 'gethash', 'get-internal-real-time', 'get-internal-run-time',
+ 'get-macro-character', 'get-output-stream-string', 'get-properties',
+ 'get-setf-expansion', 'get-universal-time', 'graphic-char-p',
+ 'hash-table-count', 'hash-table-p', 'hash-table-rehash-size',
+ 'hash-table-rehash-threshold', 'hash-table-size', 'hash-table-test',
+ 'host-namestring', 'identity', 'imagpart', 'import',
+ 'initialize-instance', 'input-stream-p', 'inspect',
+ 'integer-decode-float', 'integer-length', 'integerp',
+ 'interactive-stream-p', 'intern', 'intersection',
+ 'invalid-method-error', 'invoke-debugger', 'invoke-restart',
+ 'invoke-restart-interactively', 'isqrt', 'keywordp', 'last', 'lcm',
+ 'ldb', 'ldb-test', 'ldiff', 'length', 'lisp-implementation-type',
+ 'lisp-implementation-version', 'list', 'list*', 'list-all-packages',
+ 'listen', 'list-length', 'listp', 'load',
+ 'load-logical-pathname-translations', 'log', 'logand', 'logandc1',
+ 'logandc2', 'logbitp', 'logcount', 'logeqv', 'logical-pathname',
+ 'logical-pathname-translations', 'logior', 'lognand', 'lognor',
+ 'lognot', 'logorc1', 'logorc2', 'logtest', 'logxor', 'long-site-name',
+ 'lower-case-p', 'machine-instance', 'machine-type', 'machine-version',
+ 'macroexpand', 'macroexpand-1', 'macro-function', 'make-array',
+ 'make-broadcast-stream', 'make-concatenated-stream', 'make-condition',
+ 'make-dispatch-macro-character', 'make-echo-stream', 'make-hash-table',
+ 'make-instance', 'make-instances-obsolete', 'make-list',
+ 'make-load-form', 'make-load-form-saving-slots', 'make-package',
+ 'make-pathname', 'make-random-state', 'make-sequence', 'make-string',
+ 'make-string-input-stream', 'make-string-output-stream', 'make-symbol',
+ 'make-synonym-stream', 'make-two-way-stream', 'makunbound', 'map',
+ 'mapc', 'mapcan', 'mapcar', 'mapcon', 'maphash', 'map-into', 'mapl',
+ 'maplist', 'mask-field', 'max', 'member', 'member-if', 'member-if-not',
+ 'merge', 'merge-pathnames', 'method-combination-error',
+ 'method-qualifiers', 'min', 'minusp', 'mismatch', 'mod',
+ 'muffle-warning', 'name-char', 'namestring', 'nbutlast', 'nconc',
+ 'next-method-p', 'nintersection', 'ninth', 'no-applicable-method',
+ 'no-next-method', 'not', 'notany', 'notevery', 'nreconc', 'nreverse',
+ 'nset-difference', 'nset-exclusive-or', 'nstring-capitalize',
+ 'nstring-downcase', 'nstring-upcase', 'nsublis', 'nsubst', 'nsubst-if',
+ 'nsubst-if-not', 'nsubstitute', 'nsubstitute-if', 'nsubstitute-if-not',
+ 'nth', 'nthcdr', 'null', 'numberp', 'numerator', 'nunion', 'oddp',
+ 'open', 'open-stream-p', 'output-stream-p', 'package-error-package',
+ 'package-name', 'package-nicknames', 'packagep',
+ 'package-shadowing-symbols', 'package-used-by-list', 'package-use-list',
+ 'pairlis', 'parse-integer', 'parse-namestring', 'pathname',
+ 'pathname-device', 'pathname-directory', 'pathname-host',
+ 'pathname-match-p', 'pathname-name', 'pathnamep', 'pathname-type',
+ 'pathname-version', 'peek-char', 'phase', 'plusp', 'position',
+ 'position-if', 'position-if-not', 'pprint', 'pprint-dispatch',
+ 'pprint-fill', 'pprint-indent', 'pprint-linear', 'pprint-newline',
+ 'pprint-tab', 'pprint-tabular', 'prin1', 'prin1-to-string', 'princ',
+ 'princ-to-string', 'print', 'print-object', 'probe-file', 'proclaim',
+ 'provide', 'random', 'random-state-p', 'rassoc', 'rassoc-if',
+ 'rassoc-if-not', 'rational', 'rationalize', 'rationalp', 'read',
+ 'read-byte', 'read-char', 'read-char-no-hang', 'read-delimited-list',
+ 'read-from-string', 'read-line', 'read-preserving-whitespace',
+ 'read-sequence', 'readtable-case', 'readtablep', 'realp', 'realpart',
+ 'reduce', 'reinitialize-instance', 'rem', 'remhash', 'remove',
+ 'remove-duplicates', 'remove-if', 'remove-if-not', 'remove-method',
+ 'remprop', 'rename-file', 'rename-package', 'replace', 'require',
+ 'rest', 'restart-name', 'revappend', 'reverse', 'room', 'round',
+ 'row-major-aref', 'rplaca', 'rplacd', 'sbit', 'scale-float', 'schar',
+ 'search', 'second', 'set', 'set-difference',
+ 'set-dispatch-macro-character', 'set-exclusive-or',
+ 'set-macro-character', 'set-pprint-dispatch', 'set-syntax-from-char',
+ 'seventh', 'shadow', 'shadowing-import', 'shared-initialize',
+ 'short-site-name', 'signal', 'signum', 'simple-bit-vector-p',
+ 'simple-condition-format-arguments', 'simple-condition-format-control',
+ 'simple-string-p', 'simple-vector-p', 'sin', 'sinh', 'sixth', 'sleep',
+ 'slot-boundp', 'slot-exists-p', 'slot-makunbound', 'slot-missing',
+ 'slot-unbound', 'slot-value', 'software-type', 'software-version',
+ 'some', 'sort', 'special-operator-p', 'sqrt', 'stable-sort',
+ 'standard-char-p', 'store-value', 'stream-element-type',
+ 'stream-error-stream', 'stream-external-format', 'streamp', 'string',
+ 'string<', 'string<=', 'string=', 'string>', 'string>=', 'string/=',
+ 'string-capitalize', 'string-downcase', 'string-equal',
+ 'string-greaterp', 'string-left-trim', 'string-lessp',
+ 'string-not-equal', 'string-not-greaterp', 'string-not-lessp',
+ 'stringp', 'string-right-trim', 'string-trim', 'string-upcase',
+ 'sublis', 'subseq', 'subsetp', 'subst', 'subst-if', 'subst-if-not',
+ 'substitute', 'substitute-if', 'substitute-if-not', 'subtypep','svref',
+ 'sxhash', 'symbol-function', 'symbol-name', 'symbolp', 'symbol-package',
+ 'symbol-plist', 'symbol-value', 'synonym-stream-symbol', 'syntax:',
+ 'tailp', 'tan', 'tanh', 'tenth', 'terpri', 'third',
+ 'translate-logical-pathname', 'translate-pathname', 'tree-equal',
+ 'truename', 'truncate', 'two-way-stream-input-stream',
+ 'two-way-stream-output-stream', 'type-error-datum',
+ 'type-error-expected-type', 'type-of', 'typep', 'unbound-slot-instance',
+ 'unexport', 'unintern', 'union', 'unread-char', 'unuse-package',
+ 'update-instance-for-different-class',
+ 'update-instance-for-redefined-class', 'upgraded-array-element-type',
+ 'upgraded-complex-part-type', 'upper-case-p', 'use-package',
+ 'user-homedir-pathname', 'use-value', 'values', 'values-list', 'vector',
+ 'vectorp', 'vector-pop', 'vector-push', 'vector-push-extend', 'warn',
+ 'wild-pathname-p', 'write', 'write-byte', 'write-char', 'write-line',
+ 'write-sequence', 'write-string', 'write-to-string', 'yes-or-no-p',
+ 'y-or-n-p', 'zerop',
+]
+
+SPECIAL_FORMS = [
+ 'block', 'catch', 'declare', 'eval-when', 'flet', 'function', 'go', 'if',
+ 'labels', 'lambda', 'let', 'let*', 'load-time-value', 'locally', 'macrolet',
+ 'multiple-value-call', 'multiple-value-prog1', 'progn', 'progv', 'quote',
+ 'return-from', 'setq', 'symbol-macrolet', 'tagbody', 'the', 'throw',
+ 'unwind-protect',
+]
+
+MACROS = [
+ 'and', 'assert', 'call-method', 'case', 'ccase', 'check-type', 'cond',
+ 'ctypecase', 'decf', 'declaim', 'defclass', 'defconstant', 'defgeneric',
+ 'define-compiler-macro', 'define-condition', 'define-method-combination',
+ 'define-modify-macro', 'define-setf-expander', 'define-symbol-macro',
+ 'defmacro', 'defmethod', 'defpackage', 'defparameter', 'defsetf',
+ 'defstruct', 'deftype', 'defun', 'defvar', 'destructuring-bind', 'do',
+ 'do*', 'do-all-symbols', 'do-external-symbols', 'dolist', 'do-symbols',
+ 'dotimes', 'ecase', 'etypecase', 'formatter', 'handler-bind',
+ 'handler-case', 'ignore-errors', 'incf', 'in-package', 'lambda', 'loop',
+ 'loop-finish', 'make-method', 'multiple-value-bind', 'multiple-value-list',
+ 'multiple-value-setq', 'nth-value', 'or', 'pop',
+ 'pprint-exit-if-list-exhausted', 'pprint-logical-block', 'pprint-pop',
+ 'print-unreadable-object', 'prog', 'prog*', 'prog1', 'prog2', 'psetf',
+ 'psetq', 'push', 'pushnew', 'remf', 'restart-bind', 'restart-case',
+ 'return', 'rotatef', 'setf', 'shiftf', 'step', 'time', 'trace', 'typecase',
+ 'unless', 'untrace', 'when', 'with-accessors', 'with-compilation-unit',
+ 'with-condition-restarts', 'with-hash-table-iterator',
+ 'with-input-from-string', 'with-open-file', 'with-open-stream',
+ 'with-output-to-string', 'with-package-iterator', 'with-simple-restart',
+ 'with-slots', 'with-standard-io-syntax',
+]
+
+LAMBDA_LIST_KEYWORDS = [
+ '&allow-other-keys', '&aux', '&body', '&environment', '&key', '&optional',
+ '&rest', '&whole',
+]
+
+DECLARATIONS = [
+ 'dynamic-extent', 'ignore', 'optimize', 'ftype', 'inline', 'special',
+ 'ignorable', 'notinline', 'type',
+]
+
+BUILTIN_TYPES = [
+ 'atom', 'boolean', 'base-char', 'base-string', 'bignum', 'bit',
+ 'compiled-function', 'extended-char', 'fixnum', 'keyword', 'nil',
+ 'signed-byte', 'short-float', 'single-float', 'double-float', 'long-float',
+ 'simple-array', 'simple-base-string', 'simple-bit-vector', 'simple-string',
+ 'simple-vector', 'standard-char', 'unsigned-byte',
+
+ # Condition Types
+ 'arithmetic-error', 'cell-error', 'condition', 'control-error',
+ 'division-by-zero', 'end-of-file', 'error', 'file-error',
+ 'floating-point-inexact', 'floating-point-overflow',
+ 'floating-point-underflow', 'floating-point-invalid-operation',
+ 'parse-error', 'package-error', 'print-not-readable', 'program-error',
+ 'reader-error', 'serious-condition', 'simple-condition', 'simple-error',
+ 'simple-type-error', 'simple-warning', 'stream-error', 'storage-condition',
+ 'style-warning', 'type-error', 'unbound-variable', 'unbound-slot',
+ 'undefined-function', 'warning',
+]
+
+BUILTIN_CLASSES = [
+ 'array', 'broadcast-stream', 'bit-vector', 'built-in-class', 'character',
+ 'class', 'complex', 'concatenated-stream', 'cons', 'echo-stream',
+ 'file-stream', 'float', 'function', 'generic-function', 'hash-table',
+ 'integer', 'list', 'logical-pathname', 'method-combination', 'method',
+ 'null', 'number', 'package', 'pathname', 'ratio', 'rational', 'readtable',
+ 'real', 'random-state', 'restart', 'sequence', 'standard-class',
+ 'standard-generic-function', 'standard-method', 'standard-object',
+ 'string-stream', 'stream', 'string', 'structure-class', 'structure-object',
+ 'symbol', 'synonym-stream', 't', 'two-way-stream', 'vector',
+]
diff --git a/pygments/lexers/_mapping.py b/pygments/lexers/_mapping.py
index 7a8eae3f..3691377c 100644
--- a/pygments/lexers/_mapping.py
+++ b/pygments/lexers/_mapping.py
@@ -25,6 +25,7 @@ LEXERS = {
'CLexer': ('pygments.lexers.compiled', 'C', ('c',), ('*.c', '*.h'), ('text/x-chdr', 'text/x-csrc')),
'CObjdumpLexer': ('pygments.lexers.asm', 'c-objdump', ('c-objdump',), ('*.c-objdump',), ('text/x-c-objdump',)),
'CSharpLexer': ('pygments.lexers.dotnet', 'C#', ('csharp', 'c#'), ('*.cs',), ('text/x-csharp',)),
+ 'CommonLispLexer': ('pygments.lexers.functional', 'Common Lisp', ('common-lisp', 'cl'), ('*.cl', '*.lisp', '*.el'), ('text/x-common-lisp',)),
'CppLexer': ('pygments.lexers.compiled', 'C++', ('cpp', 'c++'), ('*.cpp', '*.hpp', '*.c++', '*.h++'), ('text/x-c++hdr', 'text/x-c++src')),
'CppObjdumpLexer': ('pygments.lexers.asm', 'cpp-objdump', ('cpp-objdump', 'c++-objdumb', 'cxx-objdump'), ('*.cpp-objdump', '*.c++-objdump', '*.cxx-objdump'), ('text/x-cpp-objdump',)),
'CssDjangoLexer': ('pygments.lexers.templates', 'CSS+Django/Jinja', ('css+django', 'css+jinja'), (), ('text/css+django', 'text/css+jinja')),
@@ -35,6 +36,7 @@ LEXERS = {
'CssSmartyLexer': ('pygments.lexers.templates', 'CSS+Smarty', ('css+smarty',), (), ('text/css+smarty',)),
'DLexer': ('pygments.lexers.compiled', 'D', ('d',), ('*.d', '*.di'), ('text/x-dsrc',)),
'DObjdumpLexer': ('pygments.lexers.asm', 'd-objdump', ('d-objdump',), ('*.d-objdump',), ('text/x-d-objdump',)),
+ 'DebianControlLexer': ('pygments.lexers.text', 'Debian Control file', ('control',), ('control',), ()),
'DelphiLexer': ('pygments.lexers.compiled', 'Delphi', ('delphi', 'pas', 'pascal', 'objectpascal'), ('*.pas',), ('text/x-pascal',)),
'DiffLexer': ('pygments.lexers.text', 'Diff', ('diff',), ('*.diff', '*.patch'), ('text/x-diff', 'text/x-patch')),
'DjangoLexer': ('pygments.lexers.templates', 'Django/Jinja', ('django', 'jinja'), (), ('application/x-django-templating', 'application/x-jinja')),
@@ -88,7 +90,7 @@ LEXERS = {
'PerlLexer': ('pygments.lexers.agile', 'Perl', ('perl', 'pl'), ('*.pl', '*.pm'), ('text/x-perl', 'application/x-perl')),
'PhpLexer': ('pygments.lexers.web', 'PHP', ('php', 'php3', 'php4', 'php5'), ('*.php', '*.php[345]'), ('text/x-php',)),
'PythonConsoleLexer': ('pygments.lexers.agile', 'Python console session', ('pycon',), (), ('text/x-python-doctest',)),
- 'PythonLexer': ('pygments.lexers.agile', 'Python', ('python', 'py'), ('*.py', '*.pyw', '*.sc'), ('text/x-python', 'application/x-python')),
+ 'PythonLexer': ('pygments.lexers.agile', 'Python', ('python', 'py'), ('*.py', '*.pyw', '*.sc', 'SConstruct', 'SConscript'), ('text/x-python', 'application/x-python')),
'PythonTracebackLexer': ('pygments.lexers.agile', 'Python Traceback', ('pytb',), ('*.pytb',), ('text/x-python-traceback',)),
'RawTokenLexer': ('pygments.lexers.special', 'Raw token data', ('raw',), ('*.raw',), ('application/x-pygments-tokens',)),
'RedcodeLexer': ('pygments.lexers.other', 'Redcode', ('redcode',), ('*.cw',), ()),
diff --git a/pygments/lexers/agile.py b/pygments/lexers/agile.py
index d1dc0d30..30adea9a 100644
--- a/pygments/lexers/agile.py
+++ b/pygments/lexers/agile.py
@@ -41,7 +41,7 @@ class PythonLexer(RegexLexer):
name = 'Python'
aliases = ['python', 'py']
- filenames = ['*.py', '*.pyw', '*.sc'] # .sc is for SCons
+ filenames = ['*.py', '*.pyw', '*.sc', 'SConstruct', 'SConscript']
mimetypes = ['text/x-python', 'application/x-python']
tokens = {
diff --git a/pygments/lexers/functional.py b/pygments/lexers/functional.py
index 626910a3..c2305f68 100644
--- a/pygments/lexers/functional.py
+++ b/pygments/lexers/functional.py
@@ -6,7 +6,7 @@
Lexers for functional languages.
:copyright: 2006-2007 by Georg Brandl, Marek Kubica,
- Adam Blinkinsop <blinks@acm.org>.
+ Adam Blinkinsop <blinks@acm.org>, Matteo Sasso.
:license: BSD, see LICENSE for more details.
"""
@@ -19,10 +19,10 @@ except NameError:
from pygments.lexer import Lexer, RegexLexer, bygroups, using, this, include, \
do_insertions
from pygments.token import Text, Comment, Operator, Keyword, Name, \
- String, Number, Punctuation
+ String, Number, Punctuation, Literal
-__all__ = ['SchemeLexer', 'HaskellLexer', 'LiterateHaskellLexer',
+__all__ = ['SchemeLexer', 'CommonLispLexer', 'HaskellLexer', 'LiterateHaskellLexer',
'OcamlLexer', 'ErlangLexer']
@@ -154,6 +154,182 @@ class SchemeLexer(RegexLexer):
}
+class CommonLispLexer(RegexLexer):
+ """
+ A Common Lisp lexer.
+
+ *New in Pygments 0.9.*
+ """
+ name = 'Common Lisp'
+ aliases = ['common-lisp', 'cl']
+ filenames = ['*.cl', '*.lisp', '*.el'] # use for Elisp too
+ mimetypes = ['text/x-common-lisp']
+
+ flags = re.IGNORECASE | re.MULTILINE
+
+ ### couple of useful regexes
+
+ # characters that are not macro-characters and can be used to begin a symbol
+ nonmacro = r'\\.|[a-zA-Z0-9!$%&*+-/<=>?@\[\]^_{}~]'
+ constituent = nonmacro + '|[#.:]'
+ terminated = r'(?=[ "()\'\n,;`])' # whitespace or terminating macro characters
+
+ ### symbol token, reverse-engineered from hyperspec
+ # Take a deep breath...
+ symbol = r'(\|[^|]+\||(?:%s)(?:%s)*)' % (nonmacro, constituent)
+
+ def __init__(self, **options):
+ from pygments.lexers._clbuiltins import BUILTIN_FUNCTIONS, \
+ SPECIAL_FORMS, MACROS, LAMBDA_LIST_KEYWORDS, DECLARATIONS, \
+ BUILTIN_TYPES, BUILTIN_CLASSES
+ self.builtin_function = BUILTIN_FUNCTIONS
+ self.special_forms = SPECIAL_FORMS
+ self.macros = MACROS
+ self.lambda_list_keywords = LAMBDA_LIST_KEYWORDS
+ self.declarations = DECLARATIONS
+ self.builtin_types = BUILTIN_TYPES
+ self.builtin_classes = BUILTIN_CLASSES
+ RegexLexer.__init__(self, **options)
+
+ def get_tokens_unprocessed(self, text):
+ stack = ['root']
+ for index, token, value in RegexLexer.get_tokens_unprocessed(self, text, stack):
+ if token is Name.Variable:
+ if value in self.builtin_function:
+ yield index, Name.Builtin, value
+ continue
+ if value in self.special_forms:
+ yield index, Keyword, value
+ continue
+ if value in self.macros:
+ yield index, Name.Builtin, value
+ continue
+ if value in self.lambda_list_keywords:
+ yield index, Keyword, value
+ continue
+ if value in self.declarations:
+ yield index, Keyword, value
+ continue
+ if value in self.builtin_types:
+ yield index, Keyword.Type, value
+ continue
+ if value in self.builtin_classes:
+ yield index, Name.Class, value
+ continue
+ yield index, token, value
+
+ tokens = {
+ 'root' : [
+ ('', Text, 'body'),
+ ],
+ 'multiline-comment' : [
+ (r'#\|', Comment.Multiline, '#push'), # (cf. Hyperspec 2.4.8.19)
+ (r'\|#', Comment.Multiline, '#pop'),
+ (r'[^|#]+', Comment.Multiline),
+ (r'[|#]', Comment.Multiline),
+ ],
+ 'commented-form' : [
+ (r'\(', Comment.Preproc, '#push'),
+ (r'\)', Comment.Preproc, '#pop'),
+ (r'[^()]+', Comment.Preproc),
+ ],
+ 'body' : [
+ # whitespace
+ (r'\s+', Text),
+
+ # single-line comment
+ (r';.*$', Comment.Single),
+
+ # multi-line comment
+ (r'#\|', Comment.Multiline, 'multiline-comment'),
+
+ # encoding comment (?)
+ (r'#\d*Y.*$', Comment.Special),
+
+ # strings and characters
+ (r'"(\\.|[^"])*"', String),
+ # quoting
+ (r":" + symbol, String.Symbol),
+ (r"'" + symbol, String.Symbol),
+ (r"'", Operator),
+ (r"`", Operator),
+
+ # decimal numbers
+ (r'[-+]?\d+\.?' + terminated, Number.Integer),
+ (r'[-+]?\d+/\d+' + terminated, Number),
+ (r'[-+]?(\d*\.\d+([defls][-+]?\d+)?|\d+(\.\d*)?[defls][-+]?\d+)' \
+ + terminated, Number.Float),
+
+ # sharpsign strings and characters
+ (r"#\\." + terminated, String.Char),
+ (r"#\\" + symbol, String.Char),
+
+ # vector
+ (r'#\(', Operator, 'body'),
+
+ # bitstring
+ (r'#\d*\*[01]*', Literal.Other),
+
+ # uninterned symbol
+ (r'#:' + symbol, String.Symbol),
+
+ # read-time and load-time evaluation
+ (r'#[.,]', Operator),
+
+ # function shorthand
+ (r'#\'', Name.Function),
+
+ # binary rational
+ (r'#[bB][+-]?[01]+(/[01]+)?', Number),
+
+ # octal rational
+ (r'#[oO][+-]?[0-7]+(/[0-7]+)?', Number.Oct),
+
+ # hex rational
+ (r'#[xX][+-]?[0-9a-fA-F]+(/[0-9a-fA-F]+)?', Number.Hex),
+
+ # radix rational
+ (r'#\d+[rR][+-]?[0-9a-zA-Z]+(/[0-9a-zA-Z]+)?', Number),
+
+ # complex
+ (r'(#[cC])(\()', bygroups(Number, Punctuation), 'body'),
+
+ # array
+ (r'(#\d+[aA])(\()', bygroups(Literal.Other, Punctuation), 'body'),
+
+ # structure
+ (r'(#[sS])(\()', bygroups(Literal.Other, Punctuation), 'body'),
+
+ # path
+ (r'#[pP]?"(\\.|[^"])*"', Literal.Other),
+
+ # reference
+ (r'#\d+=', Operator),
+ (r'#\d+#', Operator),
+
+ # read-time comment
+ (r'#+nil' + terminated + '\s*\(', Comment.Preproc, 'commented-form'),
+
+ # read-time conditional
+ (r'#[+-]', Operator),
+
+ # special operators that should have been parsed already
+ (r'(,@|,|\.)', Operator),
+
+ # special constants
+ (r'(t|nil)' + terminated, Name.Constant),
+
+ # functions and variables
+ (r'\*' + symbol + '\*', Name.Variable.Global),
+ (symbol, Name.Variable),
+
+ # parentheses
+ (r'\(', Punctuation, 'body'),
+ (r'\)', Punctuation, '#pop'),
+ ],
+ }
+
+
class HaskellLexer(RegexLexer):
"""
A Haskell lexer based on the lexemes defined in the Haskell 98 Report.
diff --git a/pygments/lexers/text.py b/pygments/lexers/text.py
index c4422a2f..2b18cf2d 100644
--- a/pygments/lexers/text.py
+++ b/pygments/lexers/text.py
@@ -8,7 +8,9 @@
:copyright: 2006-2007 by Armin Ronacher, Georg Brandl,
Tim Hatch <tim@timhatch.com>,
Ronny Pfannschmidt,
- Dennis Kaarsemaker.
+ Dennis Kaarsemaker,
+ Kumar Appaiah <akumar@ee.iitm.ac.in>,
+ Varun Hiremath <varunhiremath@gmail.com>.
:license: BSD, see LICENSE for more details.
"""
@@ -30,7 +32,7 @@ from pygments.util import get_bool_opt
__all__ = ['IniLexer', 'SourcesListLexer', 'MakefileLexer', 'DiffLexer',
'IrcLogsLexer', 'TexLexer', 'GroffLexer', 'ApacheConfLexer',
'BBCodeLexer', 'MoinWikiLexer', 'RstLexer', 'VimLexer',
- 'GettextLexer', 'SquidConfLexer']
+ 'GettextLexer', 'SquidConfLexer', 'DebianControlLexer']
class IniLexer(RegexLexer):
@@ -847,3 +849,59 @@ class SquidConfLexer(RegexLexer):
(r'.*', Comment, '#pop'),
],
}
+
+
+class DebianControlLexer(RegexLexer):
+ """
+ Lexer for Debian ``control`` files and ``apt-cache show <pkg>`` outputs.
+
+ *New in Pygments 0.9.*
+ """
+ name = 'Debian Control file'
+ aliases = ['control']
+ filenames = ['control']
+
+ tokens = {
+ 'root': [
+ (r'^(Description)', Keyword, 'description'),
+ (r'^(Maintainer)(:\s*)', bygroups(Keyword, Text), 'maintainer'),
+ (r'^((Build-)?Depends)', Keyword, 'depends'),
+ (r'^((?:Python-)?Version)(:\s*)([^\s]+)$',
+ bygroups(Keyword, Text, Number)),
+ (r'^((?:Installed-)?Size)(:\s*)([^\s]+)$',
+ bygroups(Keyword, Text, Number)),
+ (r'^(MD5Sum|SHA1|SHA256)(:\s*)([^\s]+)$',
+ bygroups(Keyword, Text, Number)),
+ (r'^([a-zA-Z\-0-9\.]*?)(:\s*)(.*?)$',
+ bygroups(Keyword, Whitespace, String)),
+ ],
+ 'maintainer': [
+ (r'<[^>]+>', Generic.Strong),
+ (r'<[^>]+>$', Generic.Strong, '#pop'),
+ (r',\n?', Text),
+ (r'.', Text),
+ ],
+ 'description': [
+ (r'(.*)(Homepage)(: )([^\s]+)', bygroups(Text, String, Name, Name.Class)),
+ (r':.*\n', Generic.Strong),
+ (r' .*\n', Text),
+ ('', Text, '#pop'),
+ ],
+ 'depends': [
+ (r':\s*', Text),
+ (r'(\$)(\{)(\w+\s*:\s*\w+)', bygroups(Operator, Text, Name.Entity)),
+ (r'\(', Text, 'depend_vers'),
+ (r',', Text),
+ (r'\|', Operator),
+ (r'[\s]+', Text),
+ (r'[}\)]\s*$', Text, '#pop'),
+ (r'[}]', Text),
+ (r'[^,]$', Name.Function, '#pop'),
+ (r'([\+\.a-zA-Z0-9-][\s\n]*)', Name.Function),
+ ],
+ 'depend_vers': [
+ (r'\),', Text, '#pop'),
+ (r'\)[^,]', Text, '#pop:2'),
+ (r'([><=]+)(\s*)([^\)]+)', bygroups(Operator, Text, Number))
+ ]
+ }
diff --git a/tests/examplefiles/type.lisp b/tests/examplefiles/type.lisp
new file mode 100644
index 00000000..9c769379
--- /dev/null
+++ b/tests/examplefiles/type.lisp
@@ -0,0 +1,1202 @@
+;;;; TYPEP und Verwandtes
+;;;; Michael Stoll, 21. 10. 1988
+;;;; Bruno Haible, 10.6.1989
+;;;; Sam Steingold 2000-2005
+
+;;; Datenstrukturen für TYPEP:
+;;; - Ein Type-Specifier-Symbol hat auf seiner Propertyliste unter dem
+;;; Indikator SYS::TYPE-SYMBOL eine Funktion von einem Argument, die
+;;; testet, ob ein Objekt vom richtigen Typ ist.
+;;; - Ein Symbol, das eine Type-Specifier-Liste beginnen kann, hat auf seiner
+;;; Propertyliste unter dem Indikator SYS::TYPE-LIST eine Funktion von
+;;; einem Argument für das zu testende Objekt und zusätzlichen Argumenten
+;;; für die Listenelemente.
+;;; - Ein Symbol, das als Typmacro definiert wurde, hat auf seiner Property-
+;;; liste unter dem Indikator SYSTEM::DEFTYPE-EXPANDER den zugehörigen
+;;; Expander: eine Funktion, die den zu expandierenden Type-Specifier (eine
+;;; mindestens einelementige Liste) als Argument bekommt.
+
+(in-package "EXT")
+(export '(type-expand))
+(in-package "SYSTEM")
+
+; vorläufig, solange bis clos.lisp geladen wird:
+(eval-when (eval)
+ (predefun clos::built-in-class-p (object) (declare (ignore object)) nil))
+(unless (fboundp 'clos::class-name)
+ (defun clos::class-name (c) (declare (ignore c)) nil)
+)
+
+(defun typespec-error (fun type)
+ (error-of-type 'error
+ (TEXT "~S: invalid type specification ~S")
+ fun type
+) )
+
+;; ============================================================================
+
+;; return the CLOS class named by TYPESPEC or NIL
+(defun clos-class (typespec)
+ (let ((cc (get typespec 'CLOS::CLOSCLASS)))
+ (when (and cc (clos::defined-class-p cc) (eq (clos:class-name cc) typespec))
+ cc)))
+
+;;; TYPEP, CLTL S. 72, S. 42-51
+(defun typep (x y &optional env &aux f) ; x = Objekt, y = Typ
+ (declare (ignore env))
+ (setq y (expand-deftype y))
+ (cond
+ ((symbolp y)
+ (cond ((setq f (get y 'TYPE-SYMBOL)) (funcall f x))
+ ((setq f (get y 'TYPE-LIST)) (funcall f x))
+ ((setq f (get y 'DEFSTRUCT-DESCRIPTION)) (ds-typep x y f))
+ ((setq f (clos-class y))
+ ; It's not worth handling structure classes specially here.
+ (clos::typep-class x f))
+ (t (typespec-error 'typep y))
+ ) )
+ ((and (consp y) (symbolp (first y)))
+ (cond
+ ((and (eq (first y) 'SATISFIES) (eql (length y) 2))
+ (unless (symbolp (second y))
+ (error-of-type 'error
+ (TEXT "~S: argument to SATISFIES must be a symbol: ~S")
+ 'typep (second y)
+ ) )
+ (if (funcall (symbol-function (second y)) x) t nil)
+ )
+ ((eq (first y) 'MEMBER)
+ (if (member x (rest y)) t nil)
+ )
+ ((and (eq (first y) 'EQL) (eql (length y) 2))
+ (eql x (second y))
+ )
+ ((and (eq (first y) 'NOT) (eql (length y) 2))
+ (not (typep x (second y)))
+ )
+ ((eq (first y) 'AND)
+ (dolist (type (rest y) t)
+ (unless (typep x type) (return nil))
+ ) )
+ ((eq (first y) 'OR)
+ (dolist (type (rest y) nil)
+ (when (typep x type) (return t))
+ ) )
+ ((setq f (get (first y) 'TYPE-LIST)) (apply f x (rest y)))
+ (t (typespec-error 'typep y))
+ ) )
+ ((clos::defined-class-p y) (clos::typep-class x y))
+ ((clos::eql-specializer-p y) (eql x (clos::eql-specializer-singleton y)))
+ ((encodingp y) (charset-typep x y))
+ (t (typespec-error 'typep y))
+) )
+
+;; ----------------------------------------------------------------------------
+
+;; UPGRADED-ARRAY-ELEMENT-TYPE is a lattice homomorphism, see
+;; ANSI CL 15.1.2.1.
+(defun upgraded-array-element-type (type &optional environment)
+ (declare (ignore environment))
+ ;; see array.d
+ (case type
+ ((BIT) 'BIT)
+ ((CHARACTER) 'CHARACTER)
+ ((T) 'T)
+ ((NIL) 'NIL)
+ (t (if (subtypep type 'NIL)
+ 'NIL
+ (multiple-value-bind (low high) (sys::subtype-integer type)
+ ; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high)))
+ (if (and (integerp low) (not (minusp low)) (integerp high))
+ (let ((l (integer-length high)))
+ ; Es gilt (subtypep type `(UNSIGNED-BYTE ,l))
+ (cond ((<= l 1) 'BIT)
+ ((<= l 2) '(UNSIGNED-BYTE 2))
+ ((<= l 4) '(UNSIGNED-BYTE 4))
+ ((<= l 8) '(UNSIGNED-BYTE 8))
+ ((<= l 16) '(UNSIGNED-BYTE 16))
+ ((<= l 32) '(UNSIGNED-BYTE 32))
+ (t 'T)))
+ (if (subtypep type 'CHARACTER)
+ 'CHARACTER
+ 'T)))))))
+
+;; ----------------------------------------------------------------------------
+
+;; UPGRADED-COMPLEX-PART-TYPE is a lattice homomorphism, see
+;; HyperSpec/Body/fun_complex.html and HyperSpec/Body/syscla_complex.html,
+;; and an idempotent. Therefore
+;; (subtypep (upgraded-complex-part-type T1) (upgraded-complex-part-type T2))
+;; is equivalent to
+;; (subtypep T1 (upgraded-complex-part-type T2))
+;; (Proof: Let U T be an abbreviation for (upgraded-complex-part-type T).
+;; If U T1 <= U T2, then T1 <= U T1 <= U T2.
+;; If T1 <= U T2, then by homomorphism U T1 <= U U T2 = U T2.)
+;;
+;; For _any_ CL implementation, you could define
+;; (defun upgraded-complex-part-type (type) 'REAL)
+;; Likewise for _any_ CL implementation, you could define
+;; (defun upgraded-complex-part-type (type) type)
+;; or - again for _any_ CL implementation:
+;; (defun upgraded-complex-part-type (type)
+;; (cond ((subtypep type 'NIL) 'NIL)
+;; ((subtypep type 'SHORT-FLOAT) 'SHORT-FLOAT)
+;; ((subtypep type 'SINGLE-FLOAT) 'SINGLE-FLOAT)
+;; ((subtypep type 'DOUBLE-FLOAT) 'DOUBLE-FLOAT)
+;; ((subtypep type 'LONG-FLOAT) 'LONG-FLOAT)
+;; ((subtypep type 'RATIONAL) 'RATIONAL)
+;; ((subtypep type 'REAL) 'REAL)
+;; (t (error ...))))
+;; The reason is that a complex number is immutable: no setters for the
+;; realpart and imagpart exist.
+;;
+;; We choose the second implementation because it allows the most precise
+;; type inference.
+(defun upgraded-complex-part-type (type &optional environment)
+ (declare (ignore environment))
+ (if (subtypep type 'REAL)
+ type
+ (error-of-type 'error
+ (TEXT "~S: type ~S is not a subtype of ~S")
+ 'upgraded-complex-part-type type 'real)))
+
+;; ----------------------------------------------------------------------------
+
+;; Macros for defining the various built-in "atomic type specifier"s and
+;; "compound type specifier"s. The following macros add information for both
+;; the TYPEP function above and the c-TYPEP in the compiler.
+
+; Alist symbol -> funname, used by the compiler.
+(defparameter c-typep-alist1 '())
+; Alist symbol -> lambdabody, used by the compiler.
+(defparameter c-typep-alist2 '())
+; Alist symbol -> expander function, used by the compiler.
+(defparameter c-typep-alist3 '())
+
+; (def-atomic-type symbol function-name)
+; defines an atomic type. The function-name designates a function taking one
+; argument and returning a generalized boolean value. It can be either a
+; symbol or a lambda expression.
+(defmacro def-atomic-type (symbol funname)
+ (let ((lambdap (and (consp funname) (eq (car funname) 'LAMBDA))))
+ `(PROGN
+ (SETF (GET ',symbol 'TYPE-SYMBOL)
+ ,(if lambdap
+ `(FUNCTION ,(concat-pnames "TYPE-SYMBOL-" symbol) ,funname)
+ `(FUNCTION ,funname)
+ )
+ )
+ ,(if lambdap
+ `(SETQ C-TYPEP-ALIST2
+ (NCONC C-TYPEP-ALIST2 (LIST (CONS ',symbol ',(cdr funname))))
+ )
+ `(SETQ C-TYPEP-ALIST1
+ (NCONC C-TYPEP-ALIST1 (LIST (CONS ',symbol ',funname)))
+ )
+ )
+ ',symbol
+ )
+) )
+
+; (def-compound-type symbol lambda-list (x) check-form typep-form c-typep-form)
+; defines a compound type. The lambda-list is of the form (&optional ...)
+; where the arguments come from the CDR of the type specifier.
+; For typep-form, x is an object.
+; For c-typep-form, x is a multiply evaluatable form (actually a gensym).
+; check-form is a form performing error checking, may call `error'.
+; typep-form should return a generalized boolean value.
+; c-typep-form should produce a form returning a generalized boolean value.
+(defmacro def-compound-type (symbol lambdalist (var) check-form typep-form c-typep-form)
+ `(PROGN
+ (SETF (GET ',symbol 'TYPE-LIST)
+ (FUNCTION ,(concat-pnames "TYPE-LIST-" symbol)
+ (LAMBDA (,var ,@lambdalist)
+ ,@(if check-form
+ `((MACROLET ((ERROR (&REST ERROR-ARGS)
+ (LIST* 'ERROR-OF-TYPE ''ERROR ERROR-ARGS)
+ ))
+ ,check-form
+ ))
+ )
+ ,typep-form
+ ) ) )
+ (SETQ C-TYPEP-ALIST3
+ (NCONC C-TYPEP-ALIST3
+ (LIST (CONS ',symbol
+ #'(LAMBDA (,var ,@lambdalist &REST ILLEGAL-ARGS)
+ (DECLARE (IGNORE ILLEGAL-ARGS))
+ ,@(if check-form
+ `((MACROLET ((ERROR (&REST ERROR-ARGS)
+ (LIST 'PROGN
+ (LIST* 'C-WARN ERROR-ARGS)
+ '(THROW 'C-TYPEP NIL)
+ )) )
+ ,check-form
+ ))
+ )
+ ,c-typep-form
+ )
+ ) ) ) )
+ ',symbol
+ )
+)
+
+; CLtL1 p. 43
+(def-atomic-type ARRAY arrayp)
+(def-atomic-type ATOM atom)
+(def-atomic-type BASE-CHAR
+ #+BASE-CHAR=CHARACTER
+ characterp
+ #-BASE-CHAR=CHARACTER
+ (lambda (x) (and (characterp x) (base-char-p x)))
+)
+(def-atomic-type BASE-STRING
+ (lambda (x)
+ (and (stringp x)
+ (eq (array-element-type x)
+ #+BASE-CHAR=CHARACTER 'CHARACTER #-BASE-CHAR=CHARACTER 'BASE-CHAR
+) ) ) )
+(def-atomic-type BIGNUM
+ (lambda (x) (and (integerp x) (not (fixnump x))))
+)
+(def-atomic-type BIT
+ (lambda (x) (or (eql x 0) (eql x 1)))
+)
+(def-atomic-type BIT-VECTOR bit-vector-p)
+(def-atomic-type BOOLEAN
+ (lambda (x) (or (eq x 'nil) (eq x 't)))
+)
+(def-atomic-type CHARACTER characterp)
+(def-atomic-type COMPILED-FUNCTION compiled-function-p)
+(def-atomic-type COMPLEX complexp)
+(def-atomic-type CONS consp)
+(def-atomic-type DOUBLE-FLOAT double-float-p)
+(def-atomic-type ENCODING encodingp)
+(def-atomic-type EXTENDED-CHAR
+ #+BASE-CHAR=CHARACTER
+ (lambda (x) (declare (ignore x)) nil)
+ #-BASE-CHAR=CHARACTER
+ (lambda (x) (and (characterp x) (not (base-char-p x))))
+)
+(def-atomic-type FIXNUM fixnump)
+(def-atomic-type FLOAT floatp)
+(def-atomic-type FUNCTION functionp)
+(def-atomic-type HASH-TABLE hash-table-p)
+(def-atomic-type INTEGER integerp)
+(def-atomic-type KEYWORD keywordp)
+(def-atomic-type LIST listp)
+#+LOGICAL-PATHNAMES
+(def-atomic-type LOGICAL-PATHNAME logical-pathname-p)
+(def-atomic-type LONG-FLOAT long-float-p)
+(def-atomic-type NIL
+ (lambda (x) (declare (ignore x)) nil)
+)
+(def-atomic-type NULL null)
+(def-atomic-type NUMBER numberp)
+(def-atomic-type PACKAGE packagep)
+(def-atomic-type PATHNAME pathnamep)
+(def-atomic-type RANDOM-STATE random-state-p)
+(def-atomic-type RATIO
+ (lambda (x) (and (rationalp x) (not (integerp x))))
+)
+(def-atomic-type RATIONAL rationalp)
+(def-atomic-type READTABLE readtablep)
+(def-atomic-type REAL realp)
+(def-atomic-type SEQUENCE sequencep)
+(def-atomic-type SHORT-FLOAT short-float-p)
+(def-atomic-type SIMPLE-ARRAY simple-array-p)
+(def-atomic-type SIMPLE-BASE-STRING
+ (lambda (x)
+ (and (simple-string-p x)
+ (eq (array-element-type x)
+ #+BASE-CHAR=CHARACTER 'CHARACTER #-BASE-CHAR=CHARACTER 'BASE-CHAR
+) ) ) )
+(def-atomic-type SIMPLE-BIT-VECTOR simple-bit-vector-p)
+(def-atomic-type SIMPLE-STRING simple-string-p)
+(def-atomic-type SIMPLE-VECTOR simple-vector-p)
+(def-atomic-type SINGLE-FLOAT single-float-p)
+(defun %standard-char-p (x) (and (characterp x) (standard-char-p x))) ; ABI
+(def-atomic-type STANDARD-CHAR %standard-char-p)
+(def-atomic-type CLOS:STANDARD-OBJECT clos::std-instance-p)
+(def-atomic-type STREAM streamp)
+(def-atomic-type FILE-STREAM file-stream-p)
+(def-atomic-type SYNONYM-STREAM synonym-stream-p)
+(def-atomic-type BROADCAST-STREAM broadcast-stream-p)
+(def-atomic-type CONCATENATED-STREAM concatenated-stream-p)
+(def-atomic-type TWO-WAY-STREAM two-way-stream-p)
+(def-atomic-type ECHO-STREAM echo-stream-p)
+(def-atomic-type STRING-STREAM string-stream-p)
+(def-atomic-type STRING stringp)
+(def-atomic-type STRING-CHAR characterp)
+(def-atomic-type CLOS:STRUCTURE-OBJECT clos::structure-object-p)
+(def-atomic-type SYMBOL symbolp)
+(def-atomic-type T (lambda (x) (declare (ignore x)) t))
+;; foreign1.lisp is loaded after this file,
+;; so these symbols are not external yet
+#+ffi
+(def-atomic-type ffi::foreign-function
+ (lambda (x) (eq 'ffi::foreign-function (type-of x))))
+#+ffi
+(def-atomic-type ffi::foreign-variable
+ (lambda (x) (eq 'ffi::foreign-variable (type-of x))))
+#+ffi
+(def-atomic-type ffi::foreign-address
+ (lambda (x) (eq 'ffi::foreign-address (type-of x))))
+;; see lispbibl.d (#define FOREIGN) and predtype.d (TYPE-OF):
+#+(or unix ffi affi win32)
+(def-atomic-type foreign-pointer
+ (lambda (x) (eq 'foreign-pointer (type-of x))))
+(def-atomic-type VECTOR vectorp)
+(def-atomic-type PLIST
+ (lambda (x) (multiple-value-bind (length tail) (list-length-dotted x)
+ (and (null tail) (evenp length)))))
+
+(defmacro ensure-dim (type dim)
+ ;; make sure DIM is a valid dimension
+ `(unless (or (eq ,dim '*) (typep ,dim `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))))
+ (error (TEXT "~S: dimension ~S is invalid") ',type ,dim)))
+
+(defmacro ensure-rank (type rank)
+ ;; make sure RANK is a valid rank
+ `(unless (typep ,rank `(INTEGER 0 (,ARRAY-RANK-LIMIT)))
+ (error (TEXT "~S: rank ~S is invalid") ',type ,rank)))
+
+; CLtL1 p. 46-50
+(defun c-typep-array (tester el-type dims x)
+ `(AND (,tester ,x)
+ ,@(if (eq el-type '*)
+ '()
+ `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
+ )
+ ,@(if (eq dims '*)
+ '()
+ (if (numberp dims)
+ `((EQL ,dims (ARRAY-RANK ,x)))
+ `((EQL ,(length dims) (ARRAY-RANK ,x))
+ ,@(let ((i 0))
+ (mapcap #'(lambda (dim)
+ (prog1
+ (if (eq dim '*)
+ '()
+ `((EQL ',dim (ARRAY-DIMENSION ,x ,i)))
+ )
+ (incf i)
+ ) )
+ dims
+ ) )
+ )
+ ) )
+ )
+)
+(defun c-typep-vector (tester size x)
+ `(AND (,tester ,x)
+ ,@(if (eq size '*)
+ '()
+ `((EQL ',size (ARRAY-DIMENSION ,x 0)))
+ )
+ )
+)
+(defun typep-number-test (x low high test type)
+ (and (funcall test x)
+ (cond ((eq low '*))
+ ((funcall test low) (<= low x))
+ ((and (consp low) (null (rest low)) (funcall test (first low)))
+ (< (first low) x)
+ )
+ (t (error-of-type 'error
+ #1=(TEXT "~S: argument to ~S must be *, ~S or a list of ~S: ~S")
+ 'typep type type type low
+ ) ) )
+ (cond ((eq high '*))
+ ((funcall test high) (>= high x))
+ ((and (consp high) (null (rest high)) (funcall test (first high)))
+ (> (first high) x)
+ )
+ (t (error-of-type 'error
+ #1# 'typep type type type high
+) ) ) ) )
+(defun c-typep-number (caller tester low high x)
+ `(AND (,tester ,x)
+ ,@(cond ((eq low '*) '())
+ ((funcall tester low) `((<= ,low ,x)))
+ ((and (consp low) (null (rest low)) (funcall tester (first low)))
+ `((< ,(first low) ,x))
+ )
+ (t (c-warn #1=(TEXT "~S: argument to ~S must be *, ~S or a list of ~S: ~S")
+ 'typep caller caller caller low
+ )
+ (throw 'c-TYPEP nil)
+ ) )
+ ,@(cond ((eq high '*) '())
+ ((funcall tester high) `((>= ,high ,x)))
+ ((and (consp high) (null (rest high)) (funcall tester (first high)))
+ `((> ,(first high) ,x))
+ )
+ (t (c-warn #1# 'typep caller caller caller high)
+ (throw 'c-TYPEP nil)
+ ) )
+ )
+)
+(def-compound-type ARRAY (&optional (el-type '*) (dims '*)) (x)
+ (unless (eq dims '*)
+ (if (numberp dims)
+ (ensure-rank ARRAY dims)
+ (dolist (dim dims) (ensure-dim ARRAY dim))))
+ (and (arrayp x)
+ (or (eq el-type '*)
+ (equal (array-element-type x) (upgraded-array-element-type el-type))
+ )
+ (or (eq dims '*)
+ (if (numberp dims)
+ (eql dims (array-rank x))
+ (and (eql (length dims) (array-rank x))
+ (every #'(lambda (a b) (or (eq a '*) (eql a b)))
+ dims (array-dimensions x)
+ ) ) ) ) )
+ (c-typep-array 'ARRAYP el-type dims x)
+)
+(def-compound-type SIMPLE-ARRAY (&optional (el-type '*) (dims '*)) (x)
+ (unless (eq dims '*)
+ (if (numberp dims)
+ (ensure-rank SIMPLE-ARRAY dims)
+ (dolist (dim dims) (ensure-dim SIMPLE-ARRAY dim))))
+ (and (simple-array-p x)
+ (or (eq el-type '*)
+ (equal (array-element-type x) (upgraded-array-element-type el-type))
+ )
+ (or (eq dims '*)
+ (if (numberp dims)
+ (eql dims (array-rank x))
+ (and (eql (length dims) (array-rank x))
+ (every #'(lambda (a b) (or (eq a '*) (eql a b)))
+ dims (array-dimensions x)
+ ) ) ) ) )
+ (c-typep-array 'SIMPLE-ARRAY-P el-type dims x)
+)
+(def-compound-type VECTOR (&optional (el-type '*) (size '*)) (x)
+ (ensure-dim VECTOR size)
+ (and (vectorp x)
+ (or (eq el-type '*)
+ (equal (array-element-type x) (upgraded-array-element-type el-type))
+ )
+ (or (eq size '*) (eql (array-dimension x 0) size))
+ )
+ `(AND (VECTORP ,x)
+ ,@(if (eq el-type '*)
+ '()
+ `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
+ )
+ ,@(if (eq size '*)
+ '()
+ `((EQL (ARRAY-DIMENSION ,x 0) ',size))
+ )
+ )
+)
+(def-compound-type SIMPLE-VECTOR (&optional (size '*)) (x)
+ (ensure-dim SIMLPE-VECTOR size)
+ (and (simple-vector-p x)
+ (or (eq size '*) (eql size (array-dimension x 0)))
+ )
+ (c-typep-vector 'SIMPLE-VECTOR-P size x)
+)
+(def-compound-type COMPLEX (&optional (rtype '*) (itype rtype)) (x)
+ nil
+ (and (complexp x)
+ (or (eq rtype '*)
+ (typep (realpart x) (upgraded-complex-part-type rtype)))
+ (or (eq itype '*)
+ (typep (imagpart x) (upgraded-complex-part-type itype))))
+ `(AND (COMPLEXP ,x)
+ ,@(if (eq rtype '*)
+ '()
+ `((TYPEP (REALPART ,x) ',(upgraded-complex-part-type rtype))))
+ ,@(if (eq itype '*)
+ '()
+ `((TYPEP (IMAGPART ,x) ',(upgraded-complex-part-type itype))))))
+(def-compound-type INTEGER (&optional (low '*) (high '*)) (x)
+ nil
+ (typep-number-test x low high #'integerp 'INTEGER)
+ (c-typep-number 'INTEGER 'INTEGERP low high x)
+)
+(def-compound-type MOD (n) (x)
+ (unless (integerp n)
+ (error (TEXT "~S: argument to MOD must be an integer: ~S")
+ 'typep n
+ ) )
+ (and (integerp x) (<= 0 x) (< x n))
+ `(AND (INTEGERP ,x) (NOT (MINUSP ,x)) (< ,x ,n))
+)
+(def-compound-type SIGNED-BYTE (&optional (n '*)) (x)
+ (unless (or (eq n '*) (integerp n))
+ (error (TEXT "~S: argument to SIGNED-BYTE must be an integer or * : ~S")
+ 'typep n
+ ) )
+ (and (integerp x) (or (eq n '*) (< (integer-length x) n)))
+ `(AND (INTEGERP ,x)
+ ,@(if (eq n '*) '() `((< (INTEGER-LENGTH ,x) ,n)))
+ )
+)
+(def-compound-type UNSIGNED-BYTE (&optional (n '*)) (x)
+ (unless (or (eq n '*) (integerp n))
+ (error (TEXT "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S")
+ 'typep n
+ ) )
+ (and (integerp x)
+ (not (minusp x))
+ (or (eq n '*) (<= (integer-length x) n))
+ )
+ `(AND (INTEGERP ,x) (NOT (MINUSP ,x))
+ ,@(if (eq n '*) '() `((<= (INTEGER-LENGTH ,x) ,n)))
+ )
+)
+(def-compound-type REAL (&optional (low '*) (high '*)) (x)
+ nil
+ (typep-number-test x low high #'realp 'REAL)
+ (c-typep-number 'REAL 'REALP low high x)
+)
+(def-compound-type RATIONAL (&optional (low '*) (high '*)) (x)
+ nil
+ (typep-number-test x low high #'rationalp 'RATIONAL)
+ (c-typep-number 'RATIONAL 'RATIONALP low high x)
+)
+(def-compound-type FLOAT (&optional (low '*) (high '*)) (x)
+ nil
+ (typep-number-test x low high #'floatp 'FLOAT)
+ (c-typep-number 'FLOAT 'FLOATP low high x)
+)
+(def-compound-type SHORT-FLOAT (&optional (low '*) (high '*)) (x)
+ nil
+ (typep-number-test x low high #'short-float-p 'SHORT-FLOAT)
+ (c-typep-number 'SHORT-FLOAT 'SHORT-FLOAT-P low high x)
+)
+(def-compound-type SINGLE-FLOAT (&optional (low '*) (high '*)) (x)
+ nil
+ (typep-number-test x low high #'single-float-p 'SINGLE-FLOAT)
+ (c-typep-number 'SINGLE-FLOAT 'SINGLE-FLOAT-P low high x)
+)
+(def-compound-type DOUBLE-FLOAT (&optional (low '*) (high '*)) (x)
+ nil
+ (typep-number-test x low high #'double-float-p 'DOUBLE-FLOAT)
+ (c-typep-number 'DOUBLE-FLOAT 'DOUBLE-FLOAT-P low high x)
+)
+(def-compound-type LONG-FLOAT (&optional (low '*) (high '*)) (x)
+ nil
+ (typep-number-test x low high #'long-float-p 'LONG-FLOAT)
+ (c-typep-number 'LONG-FLOAT 'LONG-FLOAT-P low high x)
+)
+(def-compound-type STRING (&optional (size '*)) (x)
+ (ensure-dim STRING size)
+ (and (stringp x)
+ (or (eq size '*) (eql size (array-dimension x 0)))
+ )
+ (c-typep-vector 'STRINGP size x)
+)
+(def-compound-type SIMPLE-STRING (&optional (size '*)) (x)
+ (ensure-dim SIMPLE-STRING size)
+ (and (simple-string-p x)
+ (or (eq size '*) (eql size (array-dimension x 0)))
+ )
+ (c-typep-vector 'SIMPLE-STRING-P size x)
+)
+(def-compound-type BASE-STRING (&optional (size '*)) (x)
+ (ensure-dim BASE-STRING size)
+ (and (stringp x)
+ (or (eq size '*) (eql size (array-dimension x 0)))
+ )
+ (c-typep-vector 'STRINGP size x)
+)
+(def-compound-type SIMPLE-BASE-STRING (&optional (size '*)) (x)
+ (ensure-dim SIMPLE-BASE-STRING size)
+ (and (simple-string-p x)
+ (or (eq size '*) (eql size (array-dimension x 0)))
+ )
+ (c-typep-vector 'SIMPLE-STRING-P size x)
+)
+(def-compound-type BIT-VECTOR (&optional (size '*)) (x)
+ (ensure-dim BIT-VECTOR size)
+ (and (bit-vector-p x)
+ (or (eq size '*) (eql size (array-dimension x 0)))
+ )
+ (c-typep-vector 'BIT-VECTOR-P size x)
+)
+(def-compound-type SIMPLE-BIT-VECTOR (&optional (size '*)) (x)
+ (ensure-dim SIMPLE-BIT-VECTOR size)
+ (and (simple-bit-vector-p x)
+ (or (eq size '*) (eql size (array-dimension x 0)))
+ )
+ (c-typep-vector 'SIMPLE-BIT-VECTOR-P size x)
+)
+(def-compound-type CONS (&optional (car-type '*) (cdr-type '*)) (x)
+ nil
+ (and (consp x)
+ (or (eq car-type '*) (typep (car x) car-type))
+ (or (eq cdr-type '*) (typep (cdr x) cdr-type))
+ )
+ `(AND (CONSP ,x)
+ ,@(if (eq car-type '*) '() `((TYPEP (CAR ,x) ',car-type)))
+ ,@(if (eq cdr-type '*) '() `((TYPEP (CDR ,x) ',cdr-type)))
+ )
+)
+
+(fmakunbound 'def-compound-type)
+
+;; ----------------------------------------------------------------------------
+
+; Typtest ohne Gefahr einer Fehlermeldung. Für SIGNAL und HANDLER-BIND.
+(defun safe-typep (x y &optional env)
+ (let ((*error-handler*
+ #'(lambda (&rest error-args)
+ (declare (ignore error-args))
+ (return-from safe-typep (values nil nil))
+ )) )
+ (values (typep x y env) t)
+) )
+
+; Umwandlung eines "type for declaration" in einen "type for discrimination".
+(defun type-for-discrimination (y &optional (notp nil) &aux f)
+ (cond ((symbolp y)
+ (cond ((get y 'TYPE-SYMBOL) y)
+ ((get y 'TYPE-LIST) y)
+ ((setq f (get y 'DEFTYPE-EXPANDER))
+ (let* ((z (funcall f (list y)))
+ (zx (type-for-discrimination z notp)))
+ (if (eql zx z) y zx)
+ ))
+ (t y)
+ ) )
+ ((and (consp y) (symbolp (first y)))
+ (case (first y)
+ ((SATISFIES MEMBER EQL) y)
+ (NOT
+ (let* ((z (second y))
+ (zx (type-for-discrimination z (not notp))))
+ (if (eql zx z) y `(NOT ,zx))
+ ))
+ ((AND OR COMPLEX VALUES)
+ (let* ((z (rest y))
+ (zx (mapcar #'(lambda (x) (type-for-discrimination x notp)) z)))
+ (if (every #'eql z zx) y (cons (first y) zx))
+ ))
+ (FUNCTION
+ ;; (FUNCTION arg-types res-type) is somewhere between
+ ;; NIL and FUNCTION, but undecidable.
+ (if notp 'NIL 'FUNCTION)
+ )
+ (t (cond ((get (first y) 'TYPE-LIST) y)
+ ((setq f (get (first y) 'DEFTYPE-EXPANDER))
+ (let* ((z (funcall f y))
+ (zx (type-for-discrimination z notp)))
+ (if (eql zx z) y zx)
+ ))
+ (t y)
+ ) ) ) )
+ (t y)
+) )
+
+; Testet eine Liste von Werten auf Erfüllen eines Type-Specifiers. Für THE.
+(defun %the (values type) ; ABI
+ (macrolet ((near-typep (objform typform)
+ ;; near-typep ist wie typep, nur dass das Objekt auch ein
+ ;; Read-Label sein darf. Das tritt z.B. auf bei
+ ;; (read-from-string "#1=#S(FOO :X #1#)")
+ ;; im Konstruktor MAKE-FOO. Die Implementation ist aber
+ ;; nicht gezwungen, bei fehlerhaftem THE zwingend einen
+ ;; Fehler zu melden, darum ist ein lascherer Typcheck hier
+ ;; erlaubt.
+ (let ((g (gensym)))
+ `(let ((,g ,objform))
+ (or (typep ,g ,typform) (eq (type-of ,g) 'READ-LABEL))))))
+ (if (and (consp type) (eq (car type) 'VALUES))
+ ;; The VALUES type specifier is ill-defined in ANSI CL.
+ ;;
+ ;; There are two possibilities to define a VALUES type specifier in a
+ ;; sane way:
+ ;; - (EXACT-VALUES type1 ... [&optional ...]) describes the exact shape
+ ;; of the values list, as received by MULTIPLE-VALUE-LIST.
+ ;; For example, (EXACT-VALUES SYMBOL) is matched by (values 'a) but not
+ ;; by (values 'a 'b) or (values).
+ ;; - (ASSIGNABLE-VALUES type1 ... [&optional ...]) describes the values
+ ;; as received by a set of variables through MULTIPLE-VALUE-BIND or
+ ;; MULTIPLE-VALUE-SETQ. For example, (ASSIGNABLE-VALUES SYMBOL) is
+ ;; defined by whether
+ ;; (MULTIPLE-VALUE-BIND (var1) values (DECLARE (TYPE SYMBOL var1)) ...)
+ ;; is valid or not; therefore (ASSIGNABLE-VALUES SYMBOL) is matched by
+ ;; (values 'a) and (values 'a 'b) and (values).
+ ;; Note that &OPTIONAL is actually redundant here:
+ ;; (ASSIGNABLE-VALUES type1 ... &optional otype1 ...)
+ ;; is equivalent to
+ ;; (ASSIGNABLE-VALUES type1 ... (OR NULL otype1) ...)
+ ;; HyperSpec/Body/typspe_values.html indicates that VALUES means
+ ;; EXACT-VALUES; however, HyperSpec/Body/speope_the.html indicates that
+ ;; VALUES means ASSIGNABLE-VALUES.
+ ;;
+ ;; SBCL interprets the VALUES type specifier to mean EXACT-VALUES when
+ ;; it contains &OPTIONAL or &REST, but ASSIGNABLE-VALUES when it has
+ ;; only a tuple of type specifiers. This is utter nonsense, in particular
+ ;; because it makes (VALUES type1 ... typek &OPTIONAL)
+ ;; different from (VALUES type1 ... typek).
+ ;;
+ ;; Here we use the ASSIGNABLE-VALUES interpretation.
+ ;; In SUBTYPEP we just punt and don't assume any interpretation.
+ (let ((vals values) (types (cdr type)))
+ ;; required:
+ (loop
+ (when (or (atom types) (atom vals)) (return-from %the t))
+ (when (memq (car types) lambda-list-keywords) (return))
+ (unless (near-typep (pop vals) (pop types))
+ (return-from %the nil)))
+ ;; &optional:
+ (when (and (consp types) (eq (car types) '&optional))
+ (setq types (cdr types))
+ (loop
+ (when (or (atom types) (atom vals)) (return-from %the t))
+ (when (memq (car types) lambda-list-keywords) (return))
+ (unless (near-typep (pop vals) (pop types))
+ (return-from %the nil))))
+ ;; &rest &key:
+ (case (car types)
+ (&rest
+ (setq types (cdr types))
+ (when (atom types) (typespec-error 'the type))
+ (unless (near-typep (pop vals) (pop types))
+ (return-from %the nil)))
+ (&key)
+ (t (typespec-error 'the type)))
+ (if (eq (car types) '&key)
+ (progn
+ (setq types (cdr types))
+ (when (oddp (length vals)) (return-from %the nil))
+ (let ((keywords nil))
+ (loop
+ (when (or (atom types) (atom vals)) (return-from %the t))
+ (when (memq (car types) lambda-list-keywords) (return))
+ (let ((item (pop types)))
+ (unless (and (listp item) (eql (length item) 2)
+ (symbolp (first item)))
+ (typespec-error 'the type))
+ (let ((kw (symbol-to-keyword (first item))))
+ (unless (near-typep (getf vals kw) (second item))
+ (return-from %the nil))
+ (push kw keywords))))
+ (if (and (consp types) (eq (car types) '&allow-other-keys))
+ (setq types (cdr types))
+ (unless (getf vals ':allow-other-keys)
+ (do ((L vals (cddr L)))
+ ((atom L))
+ (unless (memq (car L) keywords)
+ (return-from %the nil)))))))
+ (when (consp types) (typespec-error 'the type)))
+ t)
+ (near-typep (if (consp values) (car values) nil) type))))
+
+;;; ===========================================================================
+
+;; SUBTYPEP
+(load "subtypep")
+
+
+;; Returns the number of bytes that are needed to represent #\Null in a
+;; given encoding.
+(defun encoding-zeroes (encoding)
+ #+UNICODE
+ ;; this should use min_bytes_per_char for cache, not the hash table
+ (let ((name (ext:encoding-charset encoding))
+ (table #.(make-hash-table :key-type '(or string symbol) :value-type 'fixnum
+ :test 'stablehash-equal :warn-if-needs-rehash-after-gc t
+ :initial-contents '(("UTF-7" . 1))))
+ (tester #.(make-string 2 :initial-element (code-char 0))))
+ (or (gethash name table)
+ (setf (gethash name table)
+ (- (length (ext:convert-string-to-bytes tester encoding))
+ (length (ext:convert-string-to-bytes tester encoding
+ :end 1))))))
+ #-UNICODE 1)
+
+;; Determines two values low,high such that
+;; (subtypep type `(INTEGER ,low ,high))
+;; holds and low is as large as possible and high is as small as possible.
+;; low = * means -infinity, high = * means infinity.
+;; When (subtypep type 'INTEGER) is false, the values NIL,NIL are returned.
+;; We need this function only for MAKE-ARRAY, UPGRADED-ARRAY-ELEMENT-TYPE and
+;; OPEN and can therefore w.l.o.g. replace
+;; type with `(OR ,type (MEMBER 0))
+#| ;; The original implementation calls canonicalize-type and then applies
+ ;; a particular SUBTYPE variant:
+ (defun subtype-integer (type)
+ (macrolet ((yes () '(return-from subtype-integer (values low high)))
+ (no () '(return-from subtype-integer nil))
+ (unknown () '(return-from subtype-integer nil)))
+ (setq type (canonicalize-type type))
+ (if (consp type)
+ (case (first type)
+ (MEMBER ; (MEMBER &rest objects)
+ ;; All elements must be of type INTEGER.
+ (let ((low 0) (high 0)) ; wlog!
+ (dolist (x (rest type) (yes))
+ (unless (typep x 'INTEGER) (return (no)))
+ (setq low (min low x) high (max high x)))))
+ (OR ; (OR type*)
+ ;; Every type must be subtype of INTEGER.
+ (let ((low 0) (high 0)) ; wlog!
+ (dolist (type1 (rest type) (yes))
+ (multiple-value-bind (low1 high1) (subtype-integer type1)
+ (unless low1 (return (no)))
+ (setq low (if (or (eq low '*) (eq low1 '*)) '* (min low low1))
+ high (if (or (eq high '*) (eq high1 '*))
+ '* (max high high1)))))))
+ (AND ; (AND type*)
+ ;; If one of the types is subtype of INTEGER, then yes,
+ ;; otherwise unknown.
+ (let ((low nil) (high nil))
+ (dolist (type1 (rest type))
+ (multiple-value-bind (low1 high1) (subtype-integer type1)
+ (when low1
+ (if low
+ (setq low (if (eq low '*) low1 (if (eq low1 '*) low (max low low1)))
+ high (if (eq high '*) high1 (if (eq high1 '*) high (min high high1))))
+ (setq low low1 high high1)))))
+ (if low
+ (progn
+ (when (and (numberp low) (numberp high) (not (<= low high)))
+ (setq low 0 high 0) ; type equivalent to NIL)
+ (yes))
+ (unknown)))))
+ (setq type (list type)))
+ (if (eq (first type) 'INTEGER)
+ (let ((low (if (rest type) (second type) '*))
+ (high (if (cddr type) (third type) '*)))
+ (when (consp low)
+ (setq low (first low))
+ (when (numberp low) (incf low)))
+ (when (consp high)
+ (setq high (first high))
+ (when (numberp high) (decf high)))
+ (when (and (numberp low) (numberp high) (not (<= low high))) ; type leer?
+ (setq low 0 high 0))
+ (yes))
+ (if (and (eq (first type) 'INTERVALS) (eq (second type) 'INTEGER))
+ (let ((low (third type))
+ (high (car (last type))))
+ (when (consp low)
+ (setq low (first low))
+ (when (numberp low) (incf low)))
+ (when (consp high)
+ (setq high (first high))
+ (when (numberp high) (decf high)))
+ (yes))
+ (unknown)))))
+|# ;; This implementation inlines the (tail-recursive) canonicalize-type
+ ;; function. Its advantage is that it doesn't cons as much.
+ ;; (For example, (subtype-integer '(UNSIGNED-BYTE 8)) doesn't cons.)
+(defun subtype-integer (type)
+ (macrolet ((yes () '(return-from subtype-integer (values low high)))
+ (no () '(return-from subtype-integer nil))
+ (unknown () '(return-from subtype-integer nil)))
+ (setq type (expand-deftype type))
+ (cond ((symbolp type)
+ (case type
+ (BIT (let ((low 0) (high 1)) (yes)))
+ (FIXNUM
+ (let ((low '#,most-negative-fixnum)
+ (high '#,most-positive-fixnum))
+ (yes)))
+ ((INTEGER BIGNUM SIGNED-BYTE)
+ (let ((low '*) (high '*)) (yes)))
+ (UNSIGNED-BYTE
+ (let ((low 0) (high '*)) (yes)))
+ ((NIL)
+ (let ((low 0) (high 0)) (yes))) ; wlog!
+ (t (no))))
+ ((and (consp type) (symbolp (first type)))
+ (unless (and (list-length type) (null (cdr (last type))))
+ (typespec-error 'subtypep type))
+ (case (first type)
+ (MEMBER ; (MEMBER &rest objects)
+ ;; All elements must be of type INTEGER.
+ (let ((low 0) (high 0)) ; wlog!
+ (dolist (x (rest type) (yes))
+ (unless (typep x 'INTEGER) (return (no)))
+ (setq low (min low x) high (max high x)))))
+ (EQL ; (EQL object)
+ (let ((x (second type)))
+ (if (typep x 'INTEGER)
+ (let ((low (min 0 x)) (high (max 0 x))) (yes))
+ (no))))
+ (OR ; (OR type*)
+ ;; Every type must be subtype of INTEGER.
+ (let ((low 0) (high 0)) ; wlog!
+ (dolist (type1 (rest type) (yes))
+ (multiple-value-bind (low1 high1) (subtype-integer type1)
+ (unless low1 (return (no)))
+ (setq low (if (or (eq low '*) (eq low1 '*))
+ '* (min low low1))
+ high (if (or (eq high '*) (eq high1 '*))
+ '* (max high high1)))))))
+ (AND ; (AND type*)
+ ;; If one of the types is subtype of INTEGER, then yes,
+ ;; otherwise unknown.
+ (let ((low nil) (high nil))
+ (dolist (type1 (rest type))
+ (multiple-value-bind (low1 high1) (subtype-integer type1)
+ (when low1
+ (if low
+ (setq low (if (eq low '*) low1
+ (if (eq low1 '*) low
+ (max low low1)))
+ high (if (eq high '*) high1
+ (if (eq high1 '*) high
+ (min high high1))))
+ (setq low low1
+ high high1)))))
+ (if low
+ (progn
+ (when (and (numberp low) (numberp high)
+ (not (<= low high)))
+ (setq low 0 high 0)) ; type equivalent to NIL
+ (yes))
+ (unknown))))
+ (INTEGER
+ (let ((low (if (rest type) (second type) '*))
+ (high (if (cddr type) (third type) '*)))
+ (when (consp low)
+ (setq low (first low))
+ (when (numberp low) (incf low)))
+ (when (consp high)
+ (setq high (first high))
+ (when (numberp high) (decf high)))
+ (when (and (numberp low) (numberp high) (not (<= low high)))
+ (setq low 0 high 0)) ; type equivalent to NIL
+ (yes)))
+ (INTERVALS
+ (if (eq (second type) 'INTEGER)
+ (let ((low (third type))
+ (high (car (last type))))
+ (when (consp low)
+ (setq low (first low))
+ (when (numberp low) (incf low)))
+ (when (consp high)
+ (setq high (first high))
+ (when (numberp high) (decf high)))
+ (yes))
+ (unknown)))
+ (MOD ; (MOD n)
+ (let ((n (second type)))
+ (unless (and (integerp n) (>= n 0))
+ (typespec-error 'subtypep type))
+ (if (eql n 0)
+ (no)
+ (let ((low 0) (high (1- n)))
+ (yes)))))
+ (SIGNED-BYTE ; (SIGNED-BYTE &optional s)
+ (let ((s (if (cdr type) (second type) '*)))
+ (if (eq s '*)
+ (let ((low '*) (high '*)) (yes))
+ (progn
+ (unless (and (integerp s) (plusp s))
+ (typespec-error 'subtypep type))
+ (let ((n (ash 1 (1- s)))) ; (ash 1 *) == (expt 2 *)
+ (let ((low (- n)) (high (1- n)))
+ (yes)))))))
+ (UNSIGNED-BYTE ; (UNSIGNED-BYTE &optional s)
+ (let ((s (if (cdr type) (second type) '*)))
+ (if (eq s '*)
+ (let ((low 0) (high '*)) (yes))
+ (progn
+ (unless (and (integerp s) (>= s 0))
+ (typespec-error 'subtypep type))
+ (let ((n (ash 1 s))) ; (ash 1 *) == (expt 2 *)
+ (let ((low 0) (high (1- n)))
+ (yes)))))))
+ (t (no))))
+ ((clos::defined-class-p type)
+ (if (and (clos::built-in-class-p type)
+ (eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type))
+ (return-from subtype-integer
+ (subtype-integer (clos:class-name type)))
+ (no)))
+ ((clos::eql-specializer-p type)
+ (let ((x (clos::eql-specializer-singleton type)))
+ (if (typep x 'INTEGER)
+ (let ((low (min 0 x)) (high (max 0 x))) (yes))
+ (no))))
+ ((encodingp type) (no))
+ (t (typespec-error 'subtypep type)))))
+
+#| TODO: Fix subtype-integer such that this works.
+Henry Baker:
+ (defun type-null (x)
+ (values (and (eq 'bit (upgraded-array-element-type `(or bit ,x)))
+ (not (typep 0 x))
+ (not (typep 1 x)))
+ t))
+ (type-null '(and symbol number))
+ (type-null '(and integer symbol))
+ (type-null '(and integer character))
+|#
+
+;; Determines a sequence kind (an atom, as defined in defseq.lisp: one of
+;; LIST - stands for LIST
+;; VECTOR - stands for (VECTOR T)
+;; STRING - stands for (VECTOR CHARACTER)
+;; 1, 2, 4, 8, 16, 32 - stands for (VECTOR (UNSIGNED-BYTE n))
+;; 0 - stands for (VECTOR NIL))
+;; that indicates the sequence type meant by the given type. Other possible
+;; return values are
+;; SEQUENCE - denoting a type whose intersection with (OR LIST VECTOR) is not
+;; subtype of LIST or VECTOR, or
+;; NIL - indicating a type whose intersection with (OR LIST VECTOR) is empty.
+;; When the type is (OR (VECTOR eltype1) ... (VECTOR eltypeN)), the chosen
+;; element type is the smallest element type that contains all of eltype1 ...
+;; eltypeN.
+;;
+;; User-defined sequence types are not supported here.
+;;
+;; This implementation inlines the (tail-recursive) canonicalize-type
+;; function. Its advantage is that it doesn't cons as much. Also it employs
+;; some heuristics and does not have the full power of SUBTYPEP.
+(defun subtype-sequence (type)
+ (setq type (expand-deftype type))
+ (cond ((symbolp type)
+ (case type
+ ((LIST CONS NULL) 'LIST)
+ ((NIL) 'NIL)
+ ((BIT-VECTOR SIMPLE-BIT-VECTOR) '1)
+ ((STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING) 'STRING)
+ ((VECTOR SIMPLE-VECTOR ARRAY SIMPLE-ARRAY) 'VECTOR)
+ ((SEQUENCE) 'SEQUENCE)
+ (t 'NIL)))
+ ((and (consp type) (symbolp (first type)))
+ (unless (and (list-length type) (null (cdr (last type))))
+ (typespec-error 'subtypep type))
+ (case (first type)
+ (MEMBER ; (MEMBER &rest objects)
+ (let ((kind 'NIL))
+ (dolist (x (rest type))
+ (setq kind (sequence-type-union kind (type-of-sequence x))))
+ kind))
+ (EQL ; (EQL object)
+ (unless (eql (length type) 2)
+ (typespec-error 'subtypep type))
+ (type-of-sequence (second type)))
+ (OR ; (OR type*)
+ (let ((kind 'NIL))
+ (dolist (x (rest type))
+ (setq kind (sequence-type-union kind (subtype-sequence x))))
+ kind))
+ (AND ; (AND type*)
+ (let ((kind 'SEQUENCE))
+ (dolist (x (rest type))
+ (setq kind (sequence-type-intersection kind (subtype-sequence x))))
+ kind))
+ ((SIMPLE-BIT-VECTOR BIT-VECTOR) ; (SIMPLE-BIT-VECTOR &optional size)
+ (when (cddr type)
+ (typespec-error 'subtypep type))
+ '1)
+ ((SIMPLE-STRING STRING SIMPLE-BASE-STRING BASE-STRING) ; (SIMPLE-STRING &optional size)
+ (when (cddr type)
+ (typespec-error 'subtypep type))
+ 'STRING)
+ (SIMPLE-VECTOR ; (SIMPLE-VECTOR &optional size)
+ (when (cddr type)
+ (typespec-error 'subtypep type))
+ 'VECTOR)
+ ((VECTOR ARRAY SIMPLE-ARRAY) ; (VECTOR &optional el-type size), (ARRAY &optional el-type dimensions)
+ (when (cdddr type)
+ (typespec-error 'subtypep type))
+ (let ((el-type (if (cdr type) (second type) '*)))
+ (if (eq el-type '*)
+ 'VECTOR
+ (let ((eltype (upgraded-array-element-type el-type)))
+ (cond ((eq eltype 'T) 'VECTOR)
+ ((eq eltype 'CHARACTER) 'STRING)
+ ((eq eltype 'BIT) '1)
+ ((and (consp eltype) (eq (first eltype) 'UNSIGNED-BYTE)) (second eltype))
+ ((eq eltype 'NIL) '0)
+ (t (error (TEXT "~S is not up-to-date with ~S for element type ~S")
+ 'subtypep-sequence 'upgraded-array-element-type eltype)))))))
+ ((CONS) ; (CONS &optional cartype cdrtype)
+ (when (cdddr type)
+ (typespec-error 'subtypep type))
+ 'LIST)
+ (t 'NIL)))
+ ((clos::defined-class-p type)
+ (if (and (clos::built-in-class-p type)
+ (eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type))
+ (subtype-sequence (clos:class-name type))
+ 'NIL))
+ ((clos::eql-specializer-p type)
+ (type-of-sequence (clos::eql-specializer-singleton type)))
+ (t 'NIL)))
+(defun type-of-sequence (x)
+ (cond ((listp x) 'LIST)
+ ((vectorp x)
+ (let ((eltype (array-element-type x)))
+ (cond ((eq eltype 'T) 'VECTOR)
+ ((eq eltype 'CHARACTER) 'STRING)
+ ((eq eltype 'BIT) '1)
+ ((and (consp eltype) (eq (first eltype) 'UNSIGNED-BYTE)) (second eltype))
+ ((eq eltype 'NIL) '0)
+ (t (error (TEXT "~S is not up-to-date with ~S for element type ~S")
+ 'type-of-sequence 'array-element-type eltype)))))
+ (t 'NIL)))
+(defun sequence-type-union (t1 t2)
+ (cond ; Simple general rules.
+ ((eql t1 t2) t1)
+ ((eq t1 'NIL) t2)
+ ((eq t2 'NIL) t1)
+ ; Now the union of two different types.
+ ((or (eq t1 'SEQUENCE) (eq t2 'SEQUENCE)) 'SEQUENCE)
+ ((or (eq t1 'LIST) (eq t2 'LIST))
+ ; union of LIST and a vector type
+ 'SEQUENCE)
+ ((or (eq t1 'VECTOR) (eq t2 'VECTOR)) 'VECTOR)
+ ((eql t1 0) t2)
+ ((eql t2 0) t1)
+ ((or (eq t1 'STRING) (eq t2 'STRING))
+ ; union of STRING and an integer-vector type
+ 'VECTOR)
+ (t (max t1 t2))))
+(defun sequence-type-intersection (t1 t2)
+ (cond ; Simple general rules.
+ ((eql t1 t2) t1)
+ ((or (eq t1 'NIL) (eq t2 'NIL)) 'NIL)
+ ; Now the intersection of two different types.
+ ((eq t1 'SEQUENCE) t2)
+ ((eq t2 'SEQUENCE) t1)
+ ((or (eq t1 'LIST) (eq t2 'LIST))
+ ; intersection of LIST and a vector type
+ 'NIL)
+ ((eq t1 'VECTOR) t2)
+ ((eq t2 'VECTOR) t1)
+ ((or (eql t1 0) (eql t2 0)) '0)
+ ((or (eq t1 'STRING) (eq t2 'STRING))
+ ; intersection of STRING and an integer-vector type
+ '0)
+ (t (min t1 t2))))
+
+;; ============================================================================
+
+(defun type-expand (typespec &optional once-p)
+ (multiple-value-bind (expanded user-defined-p)
+ (expand-deftype typespec once-p)
+ (if user-defined-p (values expanded user-defined-p)
+ (cond ((symbolp typespec)
+ (cond ((or (get typespec 'TYPE-SYMBOL) (get typespec 'TYPE-LIST))
+ (values typespec nil))
+ ((or (get typespec 'DEFSTRUCT-DESCRIPTION)
+ (clos-class typespec))
+ (values typespec nil))
+ (t (typespec-error 'type-expand typespec))))
+ ((and (consp typespec) (symbolp (first typespec)))
+ (case (first typespec)
+ ((SATISFIES MEMBER EQL NOT AND OR) (values typespec nil))
+ (t (cond ((get (first typespec) 'TYPE-LIST)
+ (values typespec nil))
+ (t (typespec-error 'type-expand typespec))))))
+ ((clos::defined-class-p typespec) (values typespec nil))
+ (t (typespec-error 'type-expand typespec))))))
+
+;; ============================================================================
+
+(unless (clos::funcallable-instance-p #'clos::class-name)
+ (fmakunbound 'clos::class-name))
View Lorry Controller Status