gitlab-pygments.rb 0.3.2
Sign up to get free protection for your applications and to get access to all the features.
- data/.gitignore +6 -0
- data/Gemfile +2 -0
- data/README.md +91 -0
- data/Rakefile +78 -0
- data/bench.rb +22 -0
- data/cache-lexers.rb +8 -0
- data/lexers +0 -0
- data/lib/pygments/lexer.rb +148 -0
- data/lib/pygments/mentos.py +344 -0
- data/lib/pygments/popen.rb +389 -0
- data/lib/pygments/version.rb +3 -0
- data/lib/pygments.rb +8 -0
- data/pygments.rb.gemspec +24 -0
- data/test/test_data.c +2581 -0
- data/test/test_data.py +514 -0
- data/test/test_data_generated +2582 -0
- data/test/test_pygments.rb +276 -0
- data/vendor/custom_formatters/gitlab.py +171 -0
- data/vendor/custom_lexers/github.py +362 -0
- data/vendor/pygments-main/AUTHORS +115 -0
- data/vendor/pygments-main/CHANGES +762 -0
- data/vendor/pygments-main/LICENSE +25 -0
- data/vendor/pygments-main/MANIFEST.in +6 -0
- data/vendor/pygments-main/Makefile +59 -0
- data/vendor/pygments-main/REVISION +1 -0
- data/vendor/pygments-main/TODO +15 -0
- data/vendor/pygments-main/docs/generate.py +472 -0
- data/vendor/pygments-main/docs/pygmentize.1 +94 -0
- data/vendor/pygments-main/docs/src/api.txt +270 -0
- data/vendor/pygments-main/docs/src/authors.txt +5 -0
- data/vendor/pygments-main/docs/src/changelog.txt +5 -0
- data/vendor/pygments-main/docs/src/cmdline.txt +147 -0
- data/vendor/pygments-main/docs/src/filterdevelopment.txt +70 -0
- data/vendor/pygments-main/docs/src/filters.txt +42 -0
- data/vendor/pygments-main/docs/src/formatterdevelopment.txt +169 -0
- data/vendor/pygments-main/docs/src/formatters.txt +48 -0
- data/vendor/pygments-main/docs/src/index.txt +69 -0
- data/vendor/pygments-main/docs/src/installation.txt +71 -0
- data/vendor/pygments-main/docs/src/integrate.txt +43 -0
- data/vendor/pygments-main/docs/src/lexerdevelopment.txt +551 -0
- data/vendor/pygments-main/docs/src/lexers.txt +67 -0
- data/vendor/pygments-main/docs/src/moinmoin.txt +39 -0
- data/vendor/pygments-main/docs/src/plugins.txt +93 -0
- data/vendor/pygments-main/docs/src/quickstart.txt +202 -0
- data/vendor/pygments-main/docs/src/rstdirective.txt +22 -0
- data/vendor/pygments-main/docs/src/styles.txt +143 -0
- data/vendor/pygments-main/docs/src/tokens.txt +349 -0
- data/vendor/pygments-main/docs/src/unicode.txt +49 -0
- data/vendor/pygments-main/external/markdown-processor.py +67 -0
- data/vendor/pygments-main/external/moin-parser.py +112 -0
- data/vendor/pygments-main/external/pygments.bashcomp +38 -0
- data/vendor/pygments-main/external/rst-directive-old.py +77 -0
- data/vendor/pygments-main/external/rst-directive.py +83 -0
- data/vendor/pygments-main/ez_setup.py +276 -0
- data/vendor/pygments-main/pygmentize +7 -0
- data/vendor/pygments-main/pygments/__init__.py +91 -0
- data/vendor/pygments-main/pygments/cmdline.py +433 -0
- data/vendor/pygments-main/pygments/console.py +74 -0
- data/vendor/pygments-main/pygments/filter.py +74 -0
- data/vendor/pygments-main/pygments/filters/__init__.py +357 -0
- data/vendor/pygments-main/pygments/formatter.py +92 -0
- data/vendor/pygments-main/pygments/formatters/__init__.py +68 -0
- data/vendor/pygments-main/pygments/formatters/_mapping.py +94 -0
- data/vendor/pygments-main/pygments/formatters/bbcode.py +109 -0
- data/vendor/pygments-main/pygments/formatters/gitlab.py +171 -0
- data/vendor/pygments-main/pygments/formatters/html.py +750 -0
- data/vendor/pygments-main/pygments/formatters/img.py +553 -0
- data/vendor/pygments-main/pygments/formatters/latex.py +378 -0
- data/vendor/pygments-main/pygments/formatters/other.py +117 -0
- data/vendor/pygments-main/pygments/formatters/rtf.py +136 -0
- data/vendor/pygments-main/pygments/formatters/svg.py +154 -0
- data/vendor/pygments-main/pygments/formatters/terminal.py +112 -0
- data/vendor/pygments-main/pygments/formatters/terminal256.py +222 -0
- data/vendor/pygments-main/pygments/lexer.py +697 -0
- data/vendor/pygments-main/pygments/lexers/__init__.py +229 -0
- data/vendor/pygments-main/pygments/lexers/_asybuiltins.py +1645 -0
- data/vendor/pygments-main/pygments/lexers/_clbuiltins.py +232 -0
- data/vendor/pygments-main/pygments/lexers/_luabuiltins.py +249 -0
- data/vendor/pygments-main/pygments/lexers/_mapping.py +298 -0
- data/vendor/pygments-main/pygments/lexers/_phpbuiltins.py +3787 -0
- data/vendor/pygments-main/pygments/lexers/_postgres_builtins.py +232 -0
- data/vendor/pygments-main/pygments/lexers/_scilab_builtins.py +29 -0
- data/vendor/pygments-main/pygments/lexers/_vimbuiltins.py +3 -0
- data/vendor/pygments-main/pygments/lexers/agile.py +1803 -0
- data/vendor/pygments-main/pygments/lexers/asm.py +360 -0
- data/vendor/pygments-main/pygments/lexers/compiled.py +2891 -0
- data/vendor/pygments-main/pygments/lexers/dotnet.py +636 -0
- data/vendor/pygments-main/pygments/lexers/functional.py +1832 -0
- data/vendor/pygments-main/pygments/lexers/github.py +362 -0
- data/vendor/pygments-main/pygments/lexers/hdl.py +356 -0
- data/vendor/pygments-main/pygments/lexers/jvm.py +847 -0
- data/vendor/pygments-main/pygments/lexers/math.py +1072 -0
- data/vendor/pygments-main/pygments/lexers/other.py +3339 -0
- data/vendor/pygments-main/pygments/lexers/parsers.py +695 -0
- data/vendor/pygments-main/pygments/lexers/shell.py +361 -0
- data/vendor/pygments-main/pygments/lexers/special.py +100 -0
- data/vendor/pygments-main/pygments/lexers/sql.py +559 -0
- data/vendor/pygments-main/pygments/lexers/templates.py +1631 -0
- data/vendor/pygments-main/pygments/lexers/text.py +1753 -0
- data/vendor/pygments-main/pygments/lexers/web.py +2864 -0
- data/vendor/pygments-main/pygments/plugin.py +74 -0
- data/vendor/pygments-main/pygments/scanner.py +104 -0
- data/vendor/pygments-main/pygments/style.py +117 -0
- data/vendor/pygments-main/pygments/styles/__init__.py +70 -0
- data/vendor/pygments-main/pygments/styles/autumn.py +65 -0
- data/vendor/pygments-main/pygments/styles/borland.py +51 -0
- data/vendor/pygments-main/pygments/styles/bw.py +49 -0
- data/vendor/pygments-main/pygments/styles/colorful.py +81 -0
- data/vendor/pygments-main/pygments/styles/default.py +73 -0
- data/vendor/pygments-main/pygments/styles/emacs.py +72 -0
- data/vendor/pygments-main/pygments/styles/friendly.py +72 -0
- data/vendor/pygments-main/pygments/styles/fruity.py +42 -0
- data/vendor/pygments-main/pygments/styles/manni.py +75 -0
- data/vendor/pygments-main/pygments/styles/monokai.py +106 -0
- data/vendor/pygments-main/pygments/styles/murphy.py +80 -0
- data/vendor/pygments-main/pygments/styles/native.py +65 -0
- data/vendor/pygments-main/pygments/styles/pastie.py +75 -0
- data/vendor/pygments-main/pygments/styles/perldoc.py +69 -0
- data/vendor/pygments-main/pygments/styles/rrt.py +33 -0
- data/vendor/pygments-main/pygments/styles/tango.py +141 -0
- data/vendor/pygments-main/pygments/styles/trac.py +63 -0
- data/vendor/pygments-main/pygments/styles/vim.py +63 -0
- data/vendor/pygments-main/pygments/styles/vs.py +38 -0
- data/vendor/pygments-main/pygments/token.py +195 -0
- data/vendor/pygments-main/pygments/unistring.py +130 -0
- data/vendor/pygments-main/pygments/util.py +232 -0
- data/vendor/pygments-main/scripts/check_sources.py +242 -0
- data/vendor/pygments-main/scripts/detect_missing_analyse_text.py +30 -0
- data/vendor/pygments-main/scripts/epydoc.css +280 -0
- data/vendor/pygments-main/scripts/find_codetags.py +205 -0
- data/vendor/pygments-main/scripts/find_error.py +171 -0
- data/vendor/pygments-main/scripts/get_vimkw.py +43 -0
- data/vendor/pygments-main/scripts/pylintrc +301 -0
- data/vendor/pygments-main/scripts/reindent.py +291 -0
- data/vendor/pygments-main/scripts/vim2pygments.py +933 -0
- data/vendor/pygments-main/setup.cfg +6 -0
- data/vendor/pygments-main/setup.py +88 -0
- data/vendor/pygments-main/tests/dtds/HTML4-f.dtd +37 -0
- data/vendor/pygments-main/tests/dtds/HTML4-s.dtd +869 -0
- data/vendor/pygments-main/tests/dtds/HTML4.dcl +88 -0
- data/vendor/pygments-main/tests/dtds/HTML4.dtd +1092 -0
- data/vendor/pygments-main/tests/dtds/HTML4.soc +9 -0
- data/vendor/pygments-main/tests/dtds/HTMLlat1.ent +195 -0
- data/vendor/pygments-main/tests/dtds/HTMLspec.ent +77 -0
- data/vendor/pygments-main/tests/dtds/HTMLsym.ent +241 -0
- data/vendor/pygments-main/tests/examplefiles/ANTLRv3.g +608 -0
- data/vendor/pygments-main/tests/examplefiles/AcidStateAdvanced.hs +209 -0
- data/vendor/pygments-main/tests/examplefiles/AlternatingGroup.mu +102 -0
- data/vendor/pygments-main/tests/examplefiles/CPDictionary.j +611 -0
- data/vendor/pygments-main/tests/examplefiles/Constants.mo +158 -0
- data/vendor/pygments-main/tests/examplefiles/DancingSudoku.lhs +411 -0
- data/vendor/pygments-main/tests/examplefiles/Errors.scala +18 -0
- data/vendor/pygments-main/tests/examplefiles/File.hy +174 -0
- data/vendor/pygments-main/tests/examplefiles/Intro.java +1660 -0
- data/vendor/pygments-main/tests/examplefiles/Makefile +1131 -0
- data/vendor/pygments-main/tests/examplefiles/Object.st +4394 -0
- data/vendor/pygments-main/tests/examplefiles/OrderedMap.hx +584 -0
- data/vendor/pygments-main/tests/examplefiles/SmallCheck.hs +378 -0
- data/vendor/pygments-main/tests/examplefiles/Sorting.mod +470 -0
- data/vendor/pygments-main/tests/examplefiles/Sudoku.lhs +382 -0
- data/vendor/pygments-main/tests/examplefiles/addressbook.proto +30 -0
- data/vendor/pygments-main/tests/examplefiles/antlr_throws +1 -0
- data/vendor/pygments-main/tests/examplefiles/apache2.conf +393 -0
- data/vendor/pygments-main/tests/examplefiles/as3_test.as +143 -0
- data/vendor/pygments-main/tests/examplefiles/as3_test2.as +46 -0
- data/vendor/pygments-main/tests/examplefiles/as3_test3.as +3 -0
- data/vendor/pygments-main/tests/examplefiles/aspx-cs_example +27 -0
- data/vendor/pygments-main/tests/examplefiles/badcase.java +2 -0
- data/vendor/pygments-main/tests/examplefiles/batchfile.bat +49 -0
- data/vendor/pygments-main/tests/examplefiles/boot-9.scm +1557 -0
- data/vendor/pygments-main/tests/examplefiles/cells.ps +515 -0
- data/vendor/pygments-main/tests/examplefiles/ceval.c +2604 -0
- data/vendor/pygments-main/tests/examplefiles/cheetah_example.html +13 -0
- data/vendor/pygments-main/tests/examplefiles/classes.dylan +40 -0
- data/vendor/pygments-main/tests/examplefiles/condensed_ruby.rb +10 -0
- data/vendor/pygments-main/tests/examplefiles/coq_RelationClasses +447 -0
- data/vendor/pygments-main/tests/examplefiles/database.pytb +20 -0
- data/vendor/pygments-main/tests/examplefiles/de.MoinMoin.po +2461 -0
- data/vendor/pygments-main/tests/examplefiles/demo.ahk +181 -0
- data/vendor/pygments-main/tests/examplefiles/demo.cfm +38 -0
- data/vendor/pygments-main/tests/examplefiles/django_sample.html+django +68 -0
- data/vendor/pygments-main/tests/examplefiles/dwarf.cw +17 -0
- data/vendor/pygments-main/tests/examplefiles/erl_session +10 -0
- data/vendor/pygments-main/tests/examplefiles/escape_semicolon.clj +1 -0
- data/vendor/pygments-main/tests/examplefiles/evil_regex.js +48 -0
- data/vendor/pygments-main/tests/examplefiles/example.c +2080 -0
- data/vendor/pygments-main/tests/examplefiles/example.cls +15 -0
- data/vendor/pygments-main/tests/examplefiles/example.cpp +2363 -0
- data/vendor/pygments-main/tests/examplefiles/example.gs +106 -0
- data/vendor/pygments-main/tests/examplefiles/example.gst +7 -0
- data/vendor/pygments-main/tests/examplefiles/example.kt +47 -0
- data/vendor/pygments-main/tests/examplefiles/example.lua +250 -0
- data/vendor/pygments-main/tests/examplefiles/example.moo +26 -0
- data/vendor/pygments-main/tests/examplefiles/example.moon +629 -0
- data/vendor/pygments-main/tests/examplefiles/example.nim +1010 -0
- data/vendor/pygments-main/tests/examplefiles/example.ns2 +69 -0
- data/vendor/pygments-main/tests/examplefiles/example.p +34 -0
- data/vendor/pygments-main/tests/examplefiles/example.pas +2708 -0
- data/vendor/pygments-main/tests/examplefiles/example.rb +1852 -0
- data/vendor/pygments-main/tests/examplefiles/example.rhtml +561 -0
- data/vendor/pygments-main/tests/examplefiles/example.sh-session +19 -0
- data/vendor/pygments-main/tests/examplefiles/example.sml +156 -0
- data/vendor/pygments-main/tests/examplefiles/example.snobol +15 -0
- data/vendor/pygments-main/tests/examplefiles/example.tea +34 -0
- data/vendor/pygments-main/tests/examplefiles/example.u +548 -0
- data/vendor/pygments-main/tests/examplefiles/example.weechatlog +9 -0
- data/vendor/pygments-main/tests/examplefiles/example.xhtml +376 -0
- data/vendor/pygments-main/tests/examplefiles/example.yaml +302 -0
- data/vendor/pygments-main/tests/examplefiles/example2.aspx +29 -0
- data/vendor/pygments-main/tests/examplefiles/example_elixir.ex +363 -0
- data/vendor/pygments-main/tests/examplefiles/example_file.fy +128 -0
- data/vendor/pygments-main/tests/examplefiles/firefox.mak +586 -0
- data/vendor/pygments-main/tests/examplefiles/flipflop.sv +19 -0
- data/vendor/pygments-main/tests/examplefiles/foo.sce +6 -0
- data/vendor/pygments-main/tests/examplefiles/format.ml +1213 -0
- data/vendor/pygments-main/tests/examplefiles/fucked_up.rb +77 -0
- data/vendor/pygments-main/tests/examplefiles/function.mu +1 -0
- data/vendor/pygments-main/tests/examplefiles/functional.rst +1472 -0
- data/vendor/pygments-main/tests/examplefiles/genclass.clj +510 -0
- data/vendor/pygments-main/tests/examplefiles/genshi_example.xml+genshi +193 -0
- data/vendor/pygments-main/tests/examplefiles/genshitext_example.genshitext +33 -0
- data/vendor/pygments-main/tests/examplefiles/glsl.frag +7 -0
- data/vendor/pygments-main/tests/examplefiles/glsl.vert +13 -0
- data/vendor/pygments-main/tests/examplefiles/html+php_faulty.php +1 -0
- data/vendor/pygments-main/tests/examplefiles/http_request_example +14 -0
- data/vendor/pygments-main/tests/examplefiles/http_response_example +27 -0
- data/vendor/pygments-main/tests/examplefiles/import.hs +4 -0
- data/vendor/pygments-main/tests/examplefiles/intro.ik +24 -0
- data/vendor/pygments-main/tests/examplefiles/ints.php +10 -0
- data/vendor/pygments-main/tests/examplefiles/intsyn.fun +675 -0
- data/vendor/pygments-main/tests/examplefiles/intsyn.sig +286 -0
- data/vendor/pygments-main/tests/examplefiles/irb_heredoc +8 -0
- data/vendor/pygments-main/tests/examplefiles/irc.lsp +214 -0
- data/vendor/pygments-main/tests/examplefiles/java.properties +16 -0
- data/vendor/pygments-main/tests/examplefiles/jbst_example1.jbst +28 -0
- data/vendor/pygments-main/tests/examplefiles/jbst_example2.jbst +45 -0
- data/vendor/pygments-main/tests/examplefiles/jinjadesignerdoc.rst +713 -0
- data/vendor/pygments-main/tests/examplefiles/lighttpd_config.conf +13 -0
- data/vendor/pygments-main/tests/examplefiles/linecontinuation.py +47 -0
- data/vendor/pygments-main/tests/examplefiles/ltmain.sh +2849 -0
- data/vendor/pygments-main/tests/examplefiles/main.cmake +42 -0
- data/vendor/pygments-main/tests/examplefiles/markdown.lsp +679 -0
- data/vendor/pygments-main/tests/examplefiles/matlab_noreturn +3 -0
- data/vendor/pygments-main/tests/examplefiles/matlab_sample +27 -0
- data/vendor/pygments-main/tests/examplefiles/matlabsession_sample.txt +37 -0
- data/vendor/pygments-main/tests/examplefiles/minimal.ns2 +4 -0
- data/vendor/pygments-main/tests/examplefiles/moin_SyntaxReference.txt +340 -0
- data/vendor/pygments-main/tests/examplefiles/multiline_regexes.rb +38 -0
- data/vendor/pygments-main/tests/examplefiles/nasm_aoutso.asm +96 -0
- data/vendor/pygments-main/tests/examplefiles/nasm_objexe.asm +30 -0
- data/vendor/pygments-main/tests/examplefiles/nemerle_sample.n +87 -0
- data/vendor/pygments-main/tests/examplefiles/nginx_nginx.conf +118 -0
- data/vendor/pygments-main/tests/examplefiles/numbers.c +12 -0
- data/vendor/pygments-main/tests/examplefiles/objc_example.m +25 -0
- data/vendor/pygments-main/tests/examplefiles/objc_example2.m +24 -0
- data/vendor/pygments-main/tests/examplefiles/perl_misc +62 -0
- data/vendor/pygments-main/tests/examplefiles/perl_perl5db +998 -0
- data/vendor/pygments-main/tests/examplefiles/perl_regex-delims +120 -0
- data/vendor/pygments-main/tests/examplefiles/perlfunc.1 +856 -0
- data/vendor/pygments-main/tests/examplefiles/phpcomplete.vim +567 -0
- data/vendor/pygments-main/tests/examplefiles/pleac.in.rb +1223 -0
- data/vendor/pygments-main/tests/examplefiles/postgresql_test.txt +47 -0
- data/vendor/pygments-main/tests/examplefiles/pppoe.applescript +10 -0
- data/vendor/pygments-main/tests/examplefiles/psql_session.txt +122 -0
- data/vendor/pygments-main/tests/examplefiles/py3_test.txt +2 -0
- data/vendor/pygments-main/tests/examplefiles/pycon_test.pycon +14 -0
- data/vendor/pygments-main/tests/examplefiles/pytb_test2.pytb +2 -0
- data/vendor/pygments-main/tests/examplefiles/python25-bsd.mak +234 -0
- data/vendor/pygments-main/tests/examplefiles/qsort.prolog +13 -0
- data/vendor/pygments-main/tests/examplefiles/r-console-transcript.Rout +38 -0
- data/vendor/pygments-main/tests/examplefiles/ragel-cpp_rlscan +280 -0
- data/vendor/pygments-main/tests/examplefiles/ragel-cpp_snippet +2 -0
- data/vendor/pygments-main/tests/examplefiles/regex.js +22 -0
- data/vendor/pygments-main/tests/examplefiles/reversi.lsp +427 -0
- data/vendor/pygments-main/tests/examplefiles/ruby_func_def.rb +11 -0
- data/vendor/pygments-main/tests/examplefiles/scilab.sci +30 -0
- data/vendor/pygments-main/tests/examplefiles/sibling.prolog +19 -0
- data/vendor/pygments-main/tests/examplefiles/simple.md +747 -0
- data/vendor/pygments-main/tests/examplefiles/smarty_example.html +209 -0
- data/vendor/pygments-main/tests/examplefiles/source.lgt +343 -0
- data/vendor/pygments-main/tests/examplefiles/sources.list +62 -0
- data/vendor/pygments-main/tests/examplefiles/sphere.pov +18 -0
- data/vendor/pygments-main/tests/examplefiles/sqlite3.sqlite3-console +27 -0
- data/vendor/pygments-main/tests/examplefiles/squid.conf +30 -0
- data/vendor/pygments-main/tests/examplefiles/string.jl +1031 -0
- data/vendor/pygments-main/tests/examplefiles/string_delimiters.d +21 -0
- data/vendor/pygments-main/tests/examplefiles/stripheredoc.sh +3 -0
- data/vendor/pygments-main/tests/examplefiles/test.R +119 -0
- data/vendor/pygments-main/tests/examplefiles/test.adb +211 -0
- data/vendor/pygments-main/tests/examplefiles/test.asy +131 -0
- data/vendor/pygments-main/tests/examplefiles/test.awk +121 -0
- data/vendor/pygments-main/tests/examplefiles/test.bas +29 -0
- data/vendor/pygments-main/tests/examplefiles/test.bmx +145 -0
- data/vendor/pygments-main/tests/examplefiles/test.boo +39 -0
- data/vendor/pygments-main/tests/examplefiles/test.bro +250 -0
- data/vendor/pygments-main/tests/examplefiles/test.cs +374 -0
- data/vendor/pygments-main/tests/examplefiles/test.css +54 -0
- data/vendor/pygments-main/tests/examplefiles/test.d +135 -0
- data/vendor/pygments-main/tests/examplefiles/test.dart +23 -0
- data/vendor/pygments-main/tests/examplefiles/test.dtd +89 -0
- data/vendor/pygments-main/tests/examplefiles/test.ec +605 -0
- data/vendor/pygments-main/tests/examplefiles/test.ecl +58 -0
- data/vendor/pygments-main/tests/examplefiles/test.eh +315 -0
- data/vendor/pygments-main/tests/examplefiles/test.erl +169 -0
- data/vendor/pygments-main/tests/examplefiles/test.evoque +33 -0
- data/vendor/pygments-main/tests/examplefiles/test.fan +818 -0
- data/vendor/pygments-main/tests/examplefiles/test.flx +57 -0
- data/vendor/pygments-main/tests/examplefiles/test.gdc +13 -0
- data/vendor/pygments-main/tests/examplefiles/test.groovy +97 -0
- data/vendor/pygments-main/tests/examplefiles/test.html +339 -0
- data/vendor/pygments-main/tests/examplefiles/test.ini +10 -0
- data/vendor/pygments-main/tests/examplefiles/test.java +653 -0
- data/vendor/pygments-main/tests/examplefiles/test.jsp +24 -0
- data/vendor/pygments-main/tests/examplefiles/test.maql +45 -0
- data/vendor/pygments-main/tests/examplefiles/test.mod +374 -0
- data/vendor/pygments-main/tests/examplefiles/test.moo +51 -0
- data/vendor/pygments-main/tests/examplefiles/test.myt +166 -0
- data/vendor/pygments-main/tests/examplefiles/test.nim +93 -0
- data/vendor/pygments-main/tests/examplefiles/test.pas +743 -0
- data/vendor/pygments-main/tests/examplefiles/test.php +505 -0
- data/vendor/pygments-main/tests/examplefiles/test.plot +333 -0
- data/vendor/pygments-main/tests/examplefiles/test.ps1 +108 -0
- data/vendor/pygments-main/tests/examplefiles/test.pypylog +1839 -0
- data/vendor/pygments-main/tests/examplefiles/test.r3 +94 -0
- data/vendor/pygments-main/tests/examplefiles/test.rb +177 -0
- data/vendor/pygments-main/tests/examplefiles/test.rhtml +43 -0
- data/vendor/pygments-main/tests/examplefiles/test.scaml +8 -0
- data/vendor/pygments-main/tests/examplefiles/test.ssp +12 -0
- data/vendor/pygments-main/tests/examplefiles/test.tcsh +830 -0
- data/vendor/pygments-main/tests/examplefiles/test.vb +407 -0
- data/vendor/pygments-main/tests/examplefiles/test.vhdl +161 -0
- data/vendor/pygments-main/tests/examplefiles/test.xqy +138 -0
- data/vendor/pygments-main/tests/examplefiles/test.xsl +23 -0
- data/vendor/pygments-main/tests/examplefiles/truncated.pytb +15 -0
- data/vendor/pygments-main/tests/examplefiles/type.lisp +1202 -0
- data/vendor/pygments-main/tests/examplefiles/underscore.coffee +603 -0
- data/vendor/pygments-main/tests/examplefiles/unicode.applescript +5 -0
- data/vendor/pygments-main/tests/examplefiles/unicodedoc.py +11 -0
- data/vendor/pygments-main/tests/examplefiles/webkit-transition.css +3 -0
- data/vendor/pygments-main/tests/examplefiles/while.pov +13 -0
- data/vendor/pygments-main/tests/examplefiles/wiki.factor +384 -0
- data/vendor/pygments-main/tests/examplefiles/xml_example +1897 -0
- data/vendor/pygments-main/tests/examplefiles/zmlrpc.f90 +798 -0
- data/vendor/pygments-main/tests/old_run.py +138 -0
- data/vendor/pygments-main/tests/run.py +48 -0
- data/vendor/pygments-main/tests/support.py +15 -0
- data/vendor/pygments-main/tests/test_basic_api.py +294 -0
- data/vendor/pygments-main/tests/test_clexer.py +31 -0
- data/vendor/pygments-main/tests/test_cmdline.py +105 -0
- data/vendor/pygments-main/tests/test_examplefiles.py +97 -0
- data/vendor/pygments-main/tests/test_html_formatter.py +162 -0
- data/vendor/pygments-main/tests/test_latex_formatter.py +55 -0
- data/vendor/pygments-main/tests/test_perllexer.py +137 -0
- data/vendor/pygments-main/tests/test_regexlexer.py +47 -0
- data/vendor/pygments-main/tests/test_token.py +46 -0
- data/vendor/pygments-main/tests/test_using_api.py +40 -0
- data/vendor/pygments-main/tests/test_util.py +116 -0
- data/vendor/simplejson/.gitignore +10 -0
- data/vendor/simplejson/.travis.yml +5 -0
- data/vendor/simplejson/CHANGES.txt +291 -0
- data/vendor/simplejson/LICENSE.txt +19 -0
- data/vendor/simplejson/MANIFEST.in +5 -0
- data/vendor/simplejson/README.rst +19 -0
- data/vendor/simplejson/conf.py +179 -0
- data/vendor/simplejson/index.rst +628 -0
- data/vendor/simplejson/scripts/make_docs.py +18 -0
- data/vendor/simplejson/setup.py +104 -0
- data/vendor/simplejson/simplejson/__init__.py +510 -0
- data/vendor/simplejson/simplejson/_speedups.c +2745 -0
- data/vendor/simplejson/simplejson/decoder.py +425 -0
- data/vendor/simplejson/simplejson/encoder.py +567 -0
- data/vendor/simplejson/simplejson/ordered_dict.py +119 -0
- data/vendor/simplejson/simplejson/scanner.py +77 -0
- data/vendor/simplejson/simplejson/tests/__init__.py +67 -0
- data/vendor/simplejson/simplejson/tests/test_bigint_as_string.py +55 -0
- data/vendor/simplejson/simplejson/tests/test_check_circular.py +30 -0
- data/vendor/simplejson/simplejson/tests/test_decimal.py +66 -0
- data/vendor/simplejson/simplejson/tests/test_decode.py +83 -0
- data/vendor/simplejson/simplejson/tests/test_default.py +9 -0
- data/vendor/simplejson/simplejson/tests/test_dump.py +67 -0
- data/vendor/simplejson/simplejson/tests/test_encode_basestring_ascii.py +46 -0
- data/vendor/simplejson/simplejson/tests/test_encode_for_html.py +32 -0
- data/vendor/simplejson/simplejson/tests/test_errors.py +34 -0
- data/vendor/simplejson/simplejson/tests/test_fail.py +91 -0
- data/vendor/simplejson/simplejson/tests/test_float.py +19 -0
- data/vendor/simplejson/simplejson/tests/test_indent.py +86 -0
- data/vendor/simplejson/simplejson/tests/test_item_sort_key.py +20 -0
- data/vendor/simplejson/simplejson/tests/test_namedtuple.py +121 -0
- data/vendor/simplejson/simplejson/tests/test_pass1.py +76 -0
- data/vendor/simplejson/simplejson/tests/test_pass2.py +14 -0
- data/vendor/simplejson/simplejson/tests/test_pass3.py +20 -0
- data/vendor/simplejson/simplejson/tests/test_recursion.py +67 -0
- data/vendor/simplejson/simplejson/tests/test_scanstring.py +117 -0
- data/vendor/simplejson/simplejson/tests/test_separators.py +42 -0
- data/vendor/simplejson/simplejson/tests/test_speedups.py +20 -0
- data/vendor/simplejson/simplejson/tests/test_tuple.py +49 -0
- data/vendor/simplejson/simplejson/tests/test_unicode.py +109 -0
- data/vendor/simplejson/simplejson/tool.py +39 -0
- metadata +492 -0
|
@@ -0,0 +1,138 @@
|
|
|
1
|
+
(: made up functions, etc just to test xquery parsing (: even embedded comments
|
|
2
|
+
on multiple :)
|
|
3
|
+
lines
|
|
4
|
+
:)
|
|
5
|
+
xquery version "1.0";
|
|
6
|
+
|
|
7
|
+
module namespace xqueryexample "http://example.com/namespace";
|
|
8
|
+
import module namespace importedns = "http://example.com/ns/imported" at "no/such/file.xqy";
|
|
9
|
+
|
|
10
|
+
declare namespace sess = "com.example.session";
|
|
11
|
+
|
|
12
|
+
declare variable $amazing := "awesome";
|
|
13
|
+
declare variable $SESSIONS as element(sess:session)* := c:sessions();
|
|
14
|
+
|
|
15
|
+
declare option sess:clear "false";
|
|
16
|
+
|
|
17
|
+
define function whatsit($param as xs:string) as xs:string {
|
|
18
|
+
let $var1 := 1
|
|
19
|
+
let $var2 := 2
|
|
20
|
+
return (1 + 2 div ($var1 + $var2))
|
|
21
|
+
|
|
22
|
+
let $let := <x>"test"</x>
|
|
23
|
+
return (: some whitespace :) element element {
|
|
24
|
+
attribute attribute { 1 },
|
|
25
|
+
element test { 'a' },
|
|
26
|
+
attribute foo { "bar" },
|
|
27
|
+
fn:doc()[ foo/@bar eq $let ],
|
|
28
|
+
//x/with/another/*/*:version/xpath/@attr }
|
|
29
|
+
};
|
|
30
|
+
|
|
31
|
+
let $bride := "Bride"
|
|
32
|
+
let $test := validate lax { <some>html</some> }
|
|
33
|
+
let $test := validate strict { <some>html</some> }
|
|
34
|
+
let $test := validate { <some>html</some> }
|
|
35
|
+
let $test := $var1/*:Article (: comment here :) [fn:not()]
|
|
36
|
+
let $test := $var1/@*:name/fn:string()
|
|
37
|
+
|
|
38
|
+
let $noop := ordered { $test }
|
|
39
|
+
let $noop := unordered { $test }
|
|
40
|
+
|
|
41
|
+
let $noop :=
|
|
42
|
+
for $version at $i in $versions/version
|
|
43
|
+
let $row := if($i mod 2 eq 0) then "even" else "odd"
|
|
44
|
+
order by $version descending
|
|
45
|
+
return
|
|
46
|
+
|
|
47
|
+
return
|
|
48
|
+
<html xmlns="http://www.w3.org/1999/xhtml">
|
|
49
|
+
{
|
|
50
|
+
<outer>
|
|
51
|
+
<movie>
|
|
52
|
+
<title>The Princess { fn:capitalize($bride) }</title>
|
|
53
|
+
</movie>
|
|
54
|
+
<form action="" method="post" id="session-form" call="callsomething()">
|
|
55
|
+
<input type="hidden" name="{$d:DEBUG-FIELD}" value="{$d:DEBUG}"/>
|
|
56
|
+
{
|
|
57
|
+
(: placeholder for local sessions :)
|
|
58
|
+
element div {
|
|
59
|
+
attribute id { "sessions-local" },
|
|
60
|
+
attribute class { "hidden" },
|
|
61
|
+
element h1 { "Local Sessions" },
|
|
62
|
+
element p {
|
|
63
|
+
'These sessions use storage provided by your browser.',
|
|
64
|
+
'You can also ',
|
|
65
|
+
element a {
|
|
66
|
+
attribute href { 'session-import-local.xqy' },
|
|
67
|
+
'import' },
|
|
68
|
+
' sessions from local XML files.'
|
|
69
|
+
}
|
|
70
|
+
}
|
|
71
|
+
}
|
|
72
|
+
{
|
|
73
|
+
for $i in $sessions
|
|
74
|
+
let $id := c:session-id($i)
|
|
75
|
+
let $uri := c:session-uri($i)
|
|
76
|
+
(: we only care about the lock that expires last :)
|
|
77
|
+
let $conflicting := c:conflicting-locks($uri, 1)
|
|
78
|
+
let $name as xs:string := ($i/sess:name, "(unnamed)")[1]
|
|
79
|
+
return element tr {
|
|
80
|
+
element td { $name },
|
|
81
|
+
element td { string($i/sec:user) },
|
|
82
|
+
element td { data($i/sess:created) },
|
|
83
|
+
element td { data($i/sess:last-modified) },
|
|
84
|
+
element td {
|
|
85
|
+
if (empty($conflicting)) then () else
|
|
86
|
+
text {
|
|
87
|
+
"by", $conflicting/lock:owner,
|
|
88
|
+
"until", adjust-dateTime-to-timezone(
|
|
89
|
+
x:epoch-seconds-to-dateTime(
|
|
90
|
+
$conflicting/lock:timestamp + $conflicting/lock:timeout
|
|
91
|
+
)
|
|
92
|
+
)
|
|
93
|
+
},
|
|
94
|
+
(: only show resume button if there are no conflicting locks :)
|
|
95
|
+
element input {
|
|
96
|
+
attribute type { "button" },
|
|
97
|
+
attribute title {
|
|
98
|
+
data($i/sess:query-buffers/sess:query[1]) },
|
|
99
|
+
attribute onclick {
|
|
100
|
+
concat("list.resumeSession('", $id, "')") },
|
|
101
|
+
attribute value {
|
|
102
|
+
"Resume", (' ', $id)[ $d:DEBUG ] }
|
|
103
|
+
}[ not($conflicting) ],
|
|
104
|
+
$x:NBSP,
|
|
105
|
+
(: clone button :)
|
|
106
|
+
element input {
|
|
107
|
+
attribute type { "button" },
|
|
108
|
+
attribute title { "clone this session" },
|
|
109
|
+
attribute onclick {
|
|
110
|
+
concat("list.cloneSession('", $id, "', this)") },
|
|
111
|
+
attribute value { "Clone", (' ', $id)[ $d:DEBUG ] }
|
|
112
|
+
},
|
|
113
|
+
$x:NBSP,
|
|
114
|
+
(: export button :)
|
|
115
|
+
element input {
|
|
116
|
+
attribute type { "button" },
|
|
117
|
+
attribute title { "export this session" },
|
|
118
|
+
attribute onclick {
|
|
119
|
+
concat("list.exportServerSession('", $id, "', this)") },
|
|
120
|
+
attribute value { "Export", (' ', $id)[ $d:DEBUG ] }
|
|
121
|
+
},
|
|
122
|
+
$x:NBSP,
|
|
123
|
+
(: only show delete button if there are no conflicting locks :)
|
|
124
|
+
element input {
|
|
125
|
+
attribute type { "button" },
|
|
126
|
+
attribute title { "permanently delete this session" },
|
|
127
|
+
attribute onclick {
|
|
128
|
+
concat("list.deleteSession('", $id, "', this)") },
|
|
129
|
+
attribute value { "Delete", (' ', $id)[ $d:DEBUG ] }
|
|
130
|
+
}[ not($conflicting) ]
|
|
131
|
+
}
|
|
132
|
+
}
|
|
133
|
+
}
|
|
134
|
+
</form>
|
|
135
|
+
</outer>
|
|
136
|
+
}
|
|
137
|
+
<tr><td><!-- some commented things--> </td></tr>
|
|
138
|
+
</html>
|
|
@@ -0,0 +1,23 @@
|
|
|
1
|
+
<?xml version="1.0" encoding="utf-8"?>
|
|
2
|
+
<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
|
|
3
|
+
<xsl:output method="xml"/>
|
|
4
|
+
<xsl:template match="/">
|
|
5
|
+
<customers>
|
|
6
|
+
<xsl:apply-templates select="customers/customer[@Country='Germany']"/>
|
|
7
|
+
</customers>
|
|
8
|
+
</xsl:template>
|
|
9
|
+
<xsl:template match="customers">
|
|
10
|
+
<xsl:apply-templates/>
|
|
11
|
+
|
|
12
|
+
</xsl:template>
|
|
13
|
+
<xsl:template match="customer">
|
|
14
|
+
<customer>
|
|
15
|
+
<xsl:attribute name="CompanyName"><xsl:value-of select="@CompanyName"/></xsl:attribute>
|
|
16
|
+
<xsl:attribute name="CustomerID"><xsl:value-of select="@CustomerID"/></xsl:attribute>
|
|
17
|
+
<xsl:attribute name="Country"><xsl:value-of select="@Country"/></xsl:attribute>
|
|
18
|
+
</customer>
|
|
19
|
+
<xsl:apply-templates/>
|
|
20
|
+
</xsl:template>
|
|
21
|
+
|
|
22
|
+
</xsl:stylesheet>
|
|
23
|
+
|
|
@@ -0,0 +1,15 @@
|
|
|
1
|
+
File "/usr/lib/python2.3/site-packages/trac/web/main.py", line 314, in dispatch_request
|
|
2
|
+
dispatcher.dispatch(req)
|
|
3
|
+
File "/usr/lib/python2.3/site-packages/trac/web/main.py", line 186, in dispatch
|
|
4
|
+
req.session = Session(self.env, req)
|
|
5
|
+
File "/usr/lib/python2.3/site-packages/trac/web/session.py", line 52, in __init__
|
|
6
|
+
self.promote_session(sid)
|
|
7
|
+
File "/usr/lib/python2.3/site-packages/trac/web/session.py", line 125, in promote_session
|
|
8
|
+
"AND authenticated=0", (sid,))
|
|
9
|
+
File "/usr/lib/python2.3/site-packages/trac/db/util.py", line 47, in execute
|
|
10
|
+
return self.cursor.execute(sql_escape_percent(sql), args)
|
|
11
|
+
File "/usr/lib/python2.3/site-packages/trac/db/sqlite_backend.py", line 44, in execute
|
|
12
|
+
args or [])
|
|
13
|
+
File "/usr/lib/python2.3/site-packages/trac/db/sqlite_backend.py", line 36, in _rollback_on_error
|
|
14
|
+
return function(self, *args, **kwargs)
|
|
15
|
+
OperationalError: database is locked
|
|
@@ -0,0 +1,1202 @@
|
|
|
1
|
+
;;;; TYPEP und Verwandtes
|
|
2
|
+
;;;; Michael Stoll, 21. 10. 1988
|
|
3
|
+
;;;; Bruno Haible, 10.6.1989
|
|
4
|
+
;;;; Sam Steingold 2000-2005
|
|
5
|
+
|
|
6
|
+
;;; Datenstrukturen für TYPEP:
|
|
7
|
+
;;; - Ein Type-Specifier-Symbol hat auf seiner Propertyliste unter dem
|
|
8
|
+
;;; Indikator SYS::TYPE-SYMBOL eine Funktion von einem Argument, die
|
|
9
|
+
;;; testet, ob ein Objekt vom richtigen Typ ist.
|
|
10
|
+
;;; - Ein Symbol, das eine Type-Specifier-Liste beginnen kann, hat auf seiner
|
|
11
|
+
;;; Propertyliste unter dem Indikator SYS::TYPE-LIST eine Funktion von
|
|
12
|
+
;;; einem Argument für das zu testende Objekt und zusätzlichen Argumenten
|
|
13
|
+
;;; für die Listenelemente.
|
|
14
|
+
;;; - Ein Symbol, das als Typmacro definiert wurde, hat auf seiner Property-
|
|
15
|
+
;;; liste unter dem Indikator SYSTEM::DEFTYPE-EXPANDER den zugehörigen
|
|
16
|
+
;;; Expander: eine Funktion, die den zu expandierenden Type-Specifier (eine
|
|
17
|
+
;;; mindestens einelementige Liste) als Argument bekommt.
|
|
18
|
+
|
|
19
|
+
(in-package "EXT")
|
|
20
|
+
(export '(type-expand))
|
|
21
|
+
(in-package "SYSTEM")
|
|
22
|
+
|
|
23
|
+
; vorläufig, solange bis clos.lisp geladen wird:
|
|
24
|
+
(eval-when (eval)
|
|
25
|
+
(predefun clos::built-in-class-p (object) (declare (ignore object)) nil))
|
|
26
|
+
(unless (fboundp 'clos::class-name)
|
|
27
|
+
(defun clos::class-name (c) (declare (ignore c)) nil)
|
|
28
|
+
)
|
|
29
|
+
|
|
30
|
+
(defun typespec-error (fun type)
|
|
31
|
+
(error-of-type 'error
|
|
32
|
+
(TEXT "~S: invalid type specification ~S")
|
|
33
|
+
fun type
|
|
34
|
+
) )
|
|
35
|
+
|
|
36
|
+
;; ============================================================================
|
|
37
|
+
|
|
38
|
+
;; return the CLOS class named by TYPESPEC or NIL
|
|
39
|
+
(defun clos-class (typespec)
|
|
40
|
+
(let ((cc (get typespec 'CLOS::CLOSCLASS)))
|
|
41
|
+
(when (and cc (clos::defined-class-p cc) (eq (clos:class-name cc) typespec))
|
|
42
|
+
cc)))
|
|
43
|
+
|
|
44
|
+
;;; TYPEP, CLTL S. 72, S. 42-51
|
|
45
|
+
(defun typep (x y &optional env &aux f) ; x = Objekt, y = Typ
|
|
46
|
+
(declare (ignore env))
|
|
47
|
+
(setq y (expand-deftype y))
|
|
48
|
+
(cond
|
|
49
|
+
((symbolp y)
|
|
50
|
+
(cond ((setq f (get y 'TYPE-SYMBOL)) (funcall f x))
|
|
51
|
+
((setq f (get y 'TYPE-LIST)) (funcall f x))
|
|
52
|
+
((setq f (get y 'DEFSTRUCT-DESCRIPTION)) (ds-typep x y f))
|
|
53
|
+
((setq f (clos-class y))
|
|
54
|
+
; It's not worth handling structure classes specially here.
|
|
55
|
+
(clos::typep-class x f))
|
|
56
|
+
(t (typespec-error 'typep y))
|
|
57
|
+
) )
|
|
58
|
+
((and (consp y) (symbolp (first y)))
|
|
59
|
+
(cond
|
|
60
|
+
((and (eq (first y) 'SATISFIES) (eql (length y) 2))
|
|
61
|
+
(unless (symbolp (second y))
|
|
62
|
+
(error-of-type 'error
|
|
63
|
+
(TEXT "~S: argument to SATISFIES must be a symbol: ~S")
|
|
64
|
+
'typep (second y)
|
|
65
|
+
) )
|
|
66
|
+
(if (funcall (symbol-function (second y)) x) t nil)
|
|
67
|
+
)
|
|
68
|
+
((eq (first y) 'MEMBER)
|
|
69
|
+
(if (member x (rest y)) t nil)
|
|
70
|
+
)
|
|
71
|
+
((and (eq (first y) 'EQL) (eql (length y) 2))
|
|
72
|
+
(eql x (second y))
|
|
73
|
+
)
|
|
74
|
+
((and (eq (first y) 'NOT) (eql (length y) 2))
|
|
75
|
+
(not (typep x (second y)))
|
|
76
|
+
)
|
|
77
|
+
((eq (first y) 'AND)
|
|
78
|
+
(dolist (type (rest y) t)
|
|
79
|
+
(unless (typep x type) (return nil))
|
|
80
|
+
) )
|
|
81
|
+
((eq (first y) 'OR)
|
|
82
|
+
(dolist (type (rest y) nil)
|
|
83
|
+
(when (typep x type) (return t))
|
|
84
|
+
) )
|
|
85
|
+
((setq f (get (first y) 'TYPE-LIST)) (apply f x (rest y)))
|
|
86
|
+
(t (typespec-error 'typep y))
|
|
87
|
+
) )
|
|
88
|
+
((clos::defined-class-p y) (clos::typep-class x y))
|
|
89
|
+
((clos::eql-specializer-p y) (eql x (clos::eql-specializer-singleton y)))
|
|
90
|
+
((encodingp y) (charset-typep x y))
|
|
91
|
+
(t (typespec-error 'typep y))
|
|
92
|
+
) )
|
|
93
|
+
|
|
94
|
+
;; ----------------------------------------------------------------------------
|
|
95
|
+
|
|
96
|
+
;; UPGRADED-ARRAY-ELEMENT-TYPE is a lattice homomorphism, see
|
|
97
|
+
;; ANSI CL 15.1.2.1.
|
|
98
|
+
(defun upgraded-array-element-type (type &optional environment)
|
|
99
|
+
(declare (ignore environment))
|
|
100
|
+
;; see array.d
|
|
101
|
+
(case type
|
|
102
|
+
((BIT) 'BIT)
|
|
103
|
+
((CHARACTER) 'CHARACTER)
|
|
104
|
+
((T) 'T)
|
|
105
|
+
((NIL) 'NIL)
|
|
106
|
+
(t (if (subtypep type 'NIL)
|
|
107
|
+
'NIL
|
|
108
|
+
(multiple-value-bind (low high) (sys::subtype-integer type)
|
|
109
|
+
; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high)))
|
|
110
|
+
(if (and (integerp low) (not (minusp low)) (integerp high))
|
|
111
|
+
(let ((l (integer-length high)))
|
|
112
|
+
; Es gilt (subtypep type `(UNSIGNED-BYTE ,l))
|
|
113
|
+
(cond ((<= l 1) 'BIT)
|
|
114
|
+
((<= l 2) '(UNSIGNED-BYTE 2))
|
|
115
|
+
((<= l 4) '(UNSIGNED-BYTE 4))
|
|
116
|
+
((<= l 8) '(UNSIGNED-BYTE 8))
|
|
117
|
+
((<= l 16) '(UNSIGNED-BYTE 16))
|
|
118
|
+
((<= l 32) '(UNSIGNED-BYTE 32))
|
|
119
|
+
(t 'T)))
|
|
120
|
+
(if (subtypep type 'CHARACTER)
|
|
121
|
+
'CHARACTER
|
|
122
|
+
'T)))))))
|
|
123
|
+
|
|
124
|
+
;; ----------------------------------------------------------------------------
|
|
125
|
+
|
|
126
|
+
;; UPGRADED-COMPLEX-PART-TYPE is a lattice homomorphism, see
|
|
127
|
+
;; HyperSpec/Body/fun_complex.html and HyperSpec/Body/syscla_complex.html,
|
|
128
|
+
;; and an idempotent. Therefore
|
|
129
|
+
;; (subtypep (upgraded-complex-part-type T1) (upgraded-complex-part-type T2))
|
|
130
|
+
;; is equivalent to
|
|
131
|
+
;; (subtypep T1 (upgraded-complex-part-type T2))
|
|
132
|
+
;; (Proof: Let U T be an abbreviation for (upgraded-complex-part-type T).
|
|
133
|
+
;; If U T1 <= U T2, then T1 <= U T1 <= U T2.
|
|
134
|
+
;; If T1 <= U T2, then by homomorphism U T1 <= U U T2 = U T2.)
|
|
135
|
+
;;
|
|
136
|
+
;; For _any_ CL implementation, you could define
|
|
137
|
+
;; (defun upgraded-complex-part-type (type) 'REAL)
|
|
138
|
+
;; Likewise for _any_ CL implementation, you could define
|
|
139
|
+
;; (defun upgraded-complex-part-type (type) type)
|
|
140
|
+
;; or - again for _any_ CL implementation:
|
|
141
|
+
;; (defun upgraded-complex-part-type (type)
|
|
142
|
+
;; (cond ((subtypep type 'NIL) 'NIL)
|
|
143
|
+
;; ((subtypep type 'SHORT-FLOAT) 'SHORT-FLOAT)
|
|
144
|
+
;; ((subtypep type 'SINGLE-FLOAT) 'SINGLE-FLOAT)
|
|
145
|
+
;; ((subtypep type 'DOUBLE-FLOAT) 'DOUBLE-FLOAT)
|
|
146
|
+
;; ((subtypep type 'LONG-FLOAT) 'LONG-FLOAT)
|
|
147
|
+
;; ((subtypep type 'RATIONAL) 'RATIONAL)
|
|
148
|
+
;; ((subtypep type 'REAL) 'REAL)
|
|
149
|
+
;; (t (error ...))))
|
|
150
|
+
;; The reason is that a complex number is immutable: no setters for the
|
|
151
|
+
;; realpart and imagpart exist.
|
|
152
|
+
;;
|
|
153
|
+
;; We choose the second implementation because it allows the most precise
|
|
154
|
+
;; type inference.
|
|
155
|
+
(defun upgraded-complex-part-type (type &optional environment)
|
|
156
|
+
(declare (ignore environment))
|
|
157
|
+
(if (subtypep type 'REAL)
|
|
158
|
+
type
|
|
159
|
+
(error-of-type 'error
|
|
160
|
+
(TEXT "~S: type ~S is not a subtype of ~S")
|
|
161
|
+
'upgraded-complex-part-type type 'real)))
|
|
162
|
+
|
|
163
|
+
;; ----------------------------------------------------------------------------
|
|
164
|
+
|
|
165
|
+
;; Macros for defining the various built-in "atomic type specifier"s and
|
|
166
|
+
;; "compound type specifier"s. The following macros add information for both
|
|
167
|
+
;; the TYPEP function above and the c-TYPEP in the compiler.
|
|
168
|
+
|
|
169
|
+
; Alist symbol -> funname, used by the compiler.
|
|
170
|
+
(defparameter c-typep-alist1 '())
|
|
171
|
+
; Alist symbol -> lambdabody, used by the compiler.
|
|
172
|
+
(defparameter c-typep-alist2 '())
|
|
173
|
+
; Alist symbol -> expander function, used by the compiler.
|
|
174
|
+
(defparameter c-typep-alist3 '())
|
|
175
|
+
|
|
176
|
+
; (def-atomic-type symbol function-name)
|
|
177
|
+
; defines an atomic type. The function-name designates a function taking one
|
|
178
|
+
; argument and returning a generalized boolean value. It can be either a
|
|
179
|
+
; symbol or a lambda expression.
|
|
180
|
+
(defmacro def-atomic-type (symbol funname)
|
|
181
|
+
(let ((lambdap (and (consp funname) (eq (car funname) 'LAMBDA))))
|
|
182
|
+
`(PROGN
|
|
183
|
+
(SETF (GET ',symbol 'TYPE-SYMBOL)
|
|
184
|
+
,(if lambdap
|
|
185
|
+
`(FUNCTION ,(concat-pnames "TYPE-SYMBOL-" symbol) ,funname)
|
|
186
|
+
`(FUNCTION ,funname)
|
|
187
|
+
)
|
|
188
|
+
)
|
|
189
|
+
,(if lambdap
|
|
190
|
+
`(SETQ C-TYPEP-ALIST2
|
|
191
|
+
(NCONC C-TYPEP-ALIST2 (LIST (CONS ',symbol ',(cdr funname))))
|
|
192
|
+
)
|
|
193
|
+
`(SETQ C-TYPEP-ALIST1
|
|
194
|
+
(NCONC C-TYPEP-ALIST1 (LIST (CONS ',symbol ',funname)))
|
|
195
|
+
)
|
|
196
|
+
)
|
|
197
|
+
',symbol
|
|
198
|
+
)
|
|
199
|
+
) )
|
|
200
|
+
|
|
201
|
+
; (def-compound-type symbol lambda-list (x) check-form typep-form c-typep-form)
|
|
202
|
+
; defines a compound type. The lambda-list is of the form (&optional ...)
|
|
203
|
+
; where the arguments come from the CDR of the type specifier.
|
|
204
|
+
; For typep-form, x is an object.
|
|
205
|
+
; For c-typep-form, x is a multiply evaluatable form (actually a gensym).
|
|
206
|
+
; check-form is a form performing error checking, may call `error'.
|
|
207
|
+
; typep-form should return a generalized boolean value.
|
|
208
|
+
; c-typep-form should produce a form returning a generalized boolean value.
|
|
209
|
+
(defmacro def-compound-type (symbol lambdalist (var) check-form typep-form c-typep-form)
|
|
210
|
+
`(PROGN
|
|
211
|
+
(SETF (GET ',symbol 'TYPE-LIST)
|
|
212
|
+
(FUNCTION ,(concat-pnames "TYPE-LIST-" symbol)
|
|
213
|
+
(LAMBDA (,var ,@lambdalist)
|
|
214
|
+
,@(if check-form
|
|
215
|
+
`((MACROLET ((ERROR (&REST ERROR-ARGS)
|
|
216
|
+
(LIST* 'ERROR-OF-TYPE ''ERROR ERROR-ARGS)
|
|
217
|
+
))
|
|
218
|
+
,check-form
|
|
219
|
+
))
|
|
220
|
+
)
|
|
221
|
+
,typep-form
|
|
222
|
+
) ) )
|
|
223
|
+
(SETQ C-TYPEP-ALIST3
|
|
224
|
+
(NCONC C-TYPEP-ALIST3
|
|
225
|
+
(LIST (CONS ',symbol
|
|
226
|
+
#'(LAMBDA (,var ,@lambdalist &REST ILLEGAL-ARGS)
|
|
227
|
+
(DECLARE (IGNORE ILLEGAL-ARGS))
|
|
228
|
+
,@(if check-form
|
|
229
|
+
`((MACROLET ((ERROR (&REST ERROR-ARGS)
|
|
230
|
+
(LIST 'PROGN
|
|
231
|
+
(LIST* 'C-WARN ERROR-ARGS)
|
|
232
|
+
'(THROW 'C-TYPEP NIL)
|
|
233
|
+
)) )
|
|
234
|
+
,check-form
|
|
235
|
+
))
|
|
236
|
+
)
|
|
237
|
+
,c-typep-form
|
|
238
|
+
)
|
|
239
|
+
) ) ) )
|
|
240
|
+
',symbol
|
|
241
|
+
)
|
|
242
|
+
)
|
|
243
|
+
|
|
244
|
+
; CLtL1 p. 43
|
|
245
|
+
(def-atomic-type ARRAY arrayp)
|
|
246
|
+
(def-atomic-type ATOM atom)
|
|
247
|
+
(def-atomic-type BASE-CHAR
|
|
248
|
+
#+BASE-CHAR=CHARACTER
|
|
249
|
+
characterp
|
|
250
|
+
#-BASE-CHAR=CHARACTER
|
|
251
|
+
(lambda (x) (and (characterp x) (base-char-p x)))
|
|
252
|
+
)
|
|
253
|
+
(def-atomic-type BASE-STRING
|
|
254
|
+
(lambda (x)
|
|
255
|
+
(and (stringp x)
|
|
256
|
+
(eq (array-element-type x)
|
|
257
|
+
#+BASE-CHAR=CHARACTER 'CHARACTER #-BASE-CHAR=CHARACTER 'BASE-CHAR
|
|
258
|
+
) ) ) )
|
|
259
|
+
(def-atomic-type BIGNUM
|
|
260
|
+
(lambda (x) (and (integerp x) (not (fixnump x))))
|
|
261
|
+
)
|
|
262
|
+
(def-atomic-type BIT
|
|
263
|
+
(lambda (x) (or (eql x 0) (eql x 1)))
|
|
264
|
+
)
|
|
265
|
+
(def-atomic-type BIT-VECTOR bit-vector-p)
|
|
266
|
+
(def-atomic-type BOOLEAN
|
|
267
|
+
(lambda (x) (or (eq x 'nil) (eq x 't)))
|
|
268
|
+
)
|
|
269
|
+
(def-atomic-type CHARACTER characterp)
|
|
270
|
+
(def-atomic-type COMPILED-FUNCTION compiled-function-p)
|
|
271
|
+
(def-atomic-type COMPLEX complexp)
|
|
272
|
+
(def-atomic-type CONS consp)
|
|
273
|
+
(def-atomic-type DOUBLE-FLOAT double-float-p)
|
|
274
|
+
(def-atomic-type ENCODING encodingp)
|
|
275
|
+
(def-atomic-type EXTENDED-CHAR
|
|
276
|
+
#+BASE-CHAR=CHARACTER
|
|
277
|
+
(lambda (x) (declare (ignore x)) nil)
|
|
278
|
+
#-BASE-CHAR=CHARACTER
|
|
279
|
+
(lambda (x) (and (characterp x) (not (base-char-p x))))
|
|
280
|
+
)
|
|
281
|
+
(def-atomic-type FIXNUM fixnump)
|
|
282
|
+
(def-atomic-type FLOAT floatp)
|
|
283
|
+
(def-atomic-type FUNCTION functionp)
|
|
284
|
+
(def-atomic-type HASH-TABLE hash-table-p)
|
|
285
|
+
(def-atomic-type INTEGER integerp)
|
|
286
|
+
(def-atomic-type KEYWORD keywordp)
|
|
287
|
+
(def-atomic-type LIST listp)
|
|
288
|
+
#+LOGICAL-PATHNAMES
|
|
289
|
+
(def-atomic-type LOGICAL-PATHNAME logical-pathname-p)
|
|
290
|
+
(def-atomic-type LONG-FLOAT long-float-p)
|
|
291
|
+
(def-atomic-type NIL
|
|
292
|
+
(lambda (x) (declare (ignore x)) nil)
|
|
293
|
+
)
|
|
294
|
+
(def-atomic-type NULL null)
|
|
295
|
+
(def-atomic-type NUMBER numberp)
|
|
296
|
+
(def-atomic-type PACKAGE packagep)
|
|
297
|
+
(def-atomic-type PATHNAME pathnamep)
|
|
298
|
+
(def-atomic-type RANDOM-STATE random-state-p)
|
|
299
|
+
(def-atomic-type RATIO
|
|
300
|
+
(lambda (x) (and (rationalp x) (not (integerp x))))
|
|
301
|
+
)
|
|
302
|
+
(def-atomic-type RATIONAL rationalp)
|
|
303
|
+
(def-atomic-type READTABLE readtablep)
|
|
304
|
+
(def-atomic-type REAL realp)
|
|
305
|
+
(def-atomic-type SEQUENCE sequencep)
|
|
306
|
+
(def-atomic-type SHORT-FLOAT short-float-p)
|
|
307
|
+
(def-atomic-type SIMPLE-ARRAY simple-array-p)
|
|
308
|
+
(def-atomic-type SIMPLE-BASE-STRING
|
|
309
|
+
(lambda (x)
|
|
310
|
+
(and (simple-string-p x)
|
|
311
|
+
(eq (array-element-type x)
|
|
312
|
+
#+BASE-CHAR=CHARACTER 'CHARACTER #-BASE-CHAR=CHARACTER 'BASE-CHAR
|
|
313
|
+
) ) ) )
|
|
314
|
+
(def-atomic-type SIMPLE-BIT-VECTOR simple-bit-vector-p)
|
|
315
|
+
(def-atomic-type SIMPLE-STRING simple-string-p)
|
|
316
|
+
(def-atomic-type SIMPLE-VECTOR simple-vector-p)
|
|
317
|
+
(def-atomic-type SINGLE-FLOAT single-float-p)
|
|
318
|
+
(defun %standard-char-p (x) (and (characterp x) (standard-char-p x))) ; ABI
|
|
319
|
+
(def-atomic-type STANDARD-CHAR %standard-char-p)
|
|
320
|
+
(def-atomic-type CLOS:STANDARD-OBJECT clos::std-instance-p)
|
|
321
|
+
(def-atomic-type STREAM streamp)
|
|
322
|
+
(def-atomic-type FILE-STREAM file-stream-p)
|
|
323
|
+
(def-atomic-type SYNONYM-STREAM synonym-stream-p)
|
|
324
|
+
(def-atomic-type BROADCAST-STREAM broadcast-stream-p)
|
|
325
|
+
(def-atomic-type CONCATENATED-STREAM concatenated-stream-p)
|
|
326
|
+
(def-atomic-type TWO-WAY-STREAM two-way-stream-p)
|
|
327
|
+
(def-atomic-type ECHO-STREAM echo-stream-p)
|
|
328
|
+
(def-atomic-type STRING-STREAM string-stream-p)
|
|
329
|
+
(def-atomic-type STRING stringp)
|
|
330
|
+
(def-atomic-type STRING-CHAR characterp)
|
|
331
|
+
(def-atomic-type CLOS:STRUCTURE-OBJECT clos::structure-object-p)
|
|
332
|
+
(def-atomic-type SYMBOL symbolp)
|
|
333
|
+
(def-atomic-type T (lambda (x) (declare (ignore x)) t))
|
|
334
|
+
;; foreign1.lisp is loaded after this file,
|
|
335
|
+
;; so these symbols are not external yet
|
|
336
|
+
#+ffi
|
|
337
|
+
(def-atomic-type ffi::foreign-function
|
|
338
|
+
(lambda (x) (eq 'ffi::foreign-function (type-of x))))
|
|
339
|
+
#+ffi
|
|
340
|
+
(def-atomic-type ffi::foreign-variable
|
|
341
|
+
(lambda (x) (eq 'ffi::foreign-variable (type-of x))))
|
|
342
|
+
#+ffi
|
|
343
|
+
(def-atomic-type ffi::foreign-address
|
|
344
|
+
(lambda (x) (eq 'ffi::foreign-address (type-of x))))
|
|
345
|
+
;; see lispbibl.d (#define FOREIGN) and predtype.d (TYPE-OF):
|
|
346
|
+
#+(or unix ffi affi win32)
|
|
347
|
+
(def-atomic-type foreign-pointer
|
|
348
|
+
(lambda (x) (eq 'foreign-pointer (type-of x))))
|
|
349
|
+
(def-atomic-type VECTOR vectorp)
|
|
350
|
+
(def-atomic-type PLIST
|
|
351
|
+
(lambda (x) (multiple-value-bind (length tail) (list-length-dotted x)
|
|
352
|
+
(and (null tail) (evenp length)))))
|
|
353
|
+
|
|
354
|
+
(defmacro ensure-dim (type dim)
|
|
355
|
+
;; make sure DIM is a valid dimension
|
|
356
|
+
`(unless (or (eq ,dim '*) (typep ,dim `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))))
|
|
357
|
+
(error (TEXT "~S: dimension ~S is invalid") ',type ,dim)))
|
|
358
|
+
|
|
359
|
+
(defmacro ensure-rank (type rank)
|
|
360
|
+
;; make sure RANK is a valid rank
|
|
361
|
+
`(unless (typep ,rank `(INTEGER 0 (,ARRAY-RANK-LIMIT)))
|
|
362
|
+
(error (TEXT "~S: rank ~S is invalid") ',type ,rank)))
|
|
363
|
+
|
|
364
|
+
; CLtL1 p. 46-50
|
|
365
|
+
(defun c-typep-array (tester el-type dims x)
|
|
366
|
+
`(AND (,tester ,x)
|
|
367
|
+
,@(if (eq el-type '*)
|
|
368
|
+
'()
|
|
369
|
+
`((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
|
|
370
|
+
)
|
|
371
|
+
,@(if (eq dims '*)
|
|
372
|
+
'()
|
|
373
|
+
(if (numberp dims)
|
|
374
|
+
`((EQL ,dims (ARRAY-RANK ,x)))
|
|
375
|
+
`((EQL ,(length dims) (ARRAY-RANK ,x))
|
|
376
|
+
,@(let ((i 0))
|
|
377
|
+
(mapcap #'(lambda (dim)
|
|
378
|
+
(prog1
|
|
379
|
+
(if (eq dim '*)
|
|
380
|
+
'()
|
|
381
|
+
`((EQL ',dim (ARRAY-DIMENSION ,x ,i)))
|
|
382
|
+
)
|
|
383
|
+
(incf i)
|
|
384
|
+
) )
|
|
385
|
+
dims
|
|
386
|
+
) )
|
|
387
|
+
)
|
|
388
|
+
) )
|
|
389
|
+
)
|
|
390
|
+
)
|
|
391
|
+
(defun c-typep-vector (tester size x)
|
|
392
|
+
`(AND (,tester ,x)
|
|
393
|
+
,@(if (eq size '*)
|
|
394
|
+
'()
|
|
395
|
+
`((EQL ',size (ARRAY-DIMENSION ,x 0)))
|
|
396
|
+
)
|
|
397
|
+
)
|
|
398
|
+
)
|
|
399
|
+
(defun typep-number-test (x low high test type)
|
|
400
|
+
(and (funcall test x)
|
|
401
|
+
(cond ((eq low '*))
|
|
402
|
+
((funcall test low) (<= low x))
|
|
403
|
+
((and (consp low) (null (rest low)) (funcall test (first low)))
|
|
404
|
+
(< (first low) x)
|
|
405
|
+
)
|
|
406
|
+
(t (error-of-type 'error
|
|
407
|
+
#1=(TEXT "~S: argument to ~S must be *, ~S or a list of ~S: ~S")
|
|
408
|
+
'typep type type type low
|
|
409
|
+
) ) )
|
|
410
|
+
(cond ((eq high '*))
|
|
411
|
+
((funcall test high) (>= high x))
|
|
412
|
+
((and (consp high) (null (rest high)) (funcall test (first high)))
|
|
413
|
+
(> (first high) x)
|
|
414
|
+
)
|
|
415
|
+
(t (error-of-type 'error
|
|
416
|
+
#1# 'typep type type type high
|
|
417
|
+
) ) ) ) )
|
|
418
|
+
(defun c-typep-number (caller tester low high x)
|
|
419
|
+
`(AND (,tester ,x)
|
|
420
|
+
,@(cond ((eq low '*) '())
|
|
421
|
+
((funcall tester low) `((<= ,low ,x)))
|
|
422
|
+
((and (consp low) (null (rest low)) (funcall tester (first low)))
|
|
423
|
+
`((< ,(first low) ,x))
|
|
424
|
+
)
|
|
425
|
+
(t (c-warn #1=(TEXT "~S: argument to ~S must be *, ~S or a list of ~S: ~S")
|
|
426
|
+
'typep caller caller caller low
|
|
427
|
+
)
|
|
428
|
+
(throw 'c-TYPEP nil)
|
|
429
|
+
) )
|
|
430
|
+
,@(cond ((eq high '*) '())
|
|
431
|
+
((funcall tester high) `((>= ,high ,x)))
|
|
432
|
+
((and (consp high) (null (rest high)) (funcall tester (first high)))
|
|
433
|
+
`((> ,(first high) ,x))
|
|
434
|
+
)
|
|
435
|
+
(t (c-warn #1# 'typep caller caller caller high)
|
|
436
|
+
(throw 'c-TYPEP nil)
|
|
437
|
+
) )
|
|
438
|
+
)
|
|
439
|
+
)
|
|
440
|
+
(def-compound-type ARRAY (&optional (el-type '*) (dims '*)) (x)
|
|
441
|
+
(unless (eq dims '*)
|
|
442
|
+
(if (numberp dims)
|
|
443
|
+
(ensure-rank ARRAY dims)
|
|
444
|
+
(dolist (dim dims) (ensure-dim ARRAY dim))))
|
|
445
|
+
(and (arrayp x)
|
|
446
|
+
(or (eq el-type '*)
|
|
447
|
+
(equal (array-element-type x) (upgraded-array-element-type el-type))
|
|
448
|
+
)
|
|
449
|
+
(or (eq dims '*)
|
|
450
|
+
(if (numberp dims)
|
|
451
|
+
(eql dims (array-rank x))
|
|
452
|
+
(and (eql (length dims) (array-rank x))
|
|
453
|
+
(every #'(lambda (a b) (or (eq a '*) (eql a b)))
|
|
454
|
+
dims (array-dimensions x)
|
|
455
|
+
) ) ) ) )
|
|
456
|
+
(c-typep-array 'ARRAYP el-type dims x)
|
|
457
|
+
)
|
|
458
|
+
(def-compound-type SIMPLE-ARRAY (&optional (el-type '*) (dims '*)) (x)
|
|
459
|
+
(unless (eq dims '*)
|
|
460
|
+
(if (numberp dims)
|
|
461
|
+
(ensure-rank SIMPLE-ARRAY dims)
|
|
462
|
+
(dolist (dim dims) (ensure-dim SIMPLE-ARRAY dim))))
|
|
463
|
+
(and (simple-array-p x)
|
|
464
|
+
(or (eq el-type '*)
|
|
465
|
+
(equal (array-element-type x) (upgraded-array-element-type el-type))
|
|
466
|
+
)
|
|
467
|
+
(or (eq dims '*)
|
|
468
|
+
(if (numberp dims)
|
|
469
|
+
(eql dims (array-rank x))
|
|
470
|
+
(and (eql (length dims) (array-rank x))
|
|
471
|
+
(every #'(lambda (a b) (or (eq a '*) (eql a b)))
|
|
472
|
+
dims (array-dimensions x)
|
|
473
|
+
) ) ) ) )
|
|
474
|
+
(c-typep-array 'SIMPLE-ARRAY-P el-type dims x)
|
|
475
|
+
)
|
|
476
|
+
(def-compound-type VECTOR (&optional (el-type '*) (size '*)) (x)
|
|
477
|
+
(ensure-dim VECTOR size)
|
|
478
|
+
(and (vectorp x)
|
|
479
|
+
(or (eq el-type '*)
|
|
480
|
+
(equal (array-element-type x) (upgraded-array-element-type el-type))
|
|
481
|
+
)
|
|
482
|
+
(or (eq size '*) (eql (array-dimension x 0) size))
|
|
483
|
+
)
|
|
484
|
+
`(AND (VECTORP ,x)
|
|
485
|
+
,@(if (eq el-type '*)
|
|
486
|
+
'()
|
|
487
|
+
`((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
|
|
488
|
+
)
|
|
489
|
+
,@(if (eq size '*)
|
|
490
|
+
'()
|
|
491
|
+
`((EQL (ARRAY-DIMENSION ,x 0) ',size))
|
|
492
|
+
)
|
|
493
|
+
)
|
|
494
|
+
)
|
|
495
|
+
(def-compound-type SIMPLE-VECTOR (&optional (size '*)) (x)
|
|
496
|
+
(ensure-dim SIMLPE-VECTOR size)
|
|
497
|
+
(and (simple-vector-p x)
|
|
498
|
+
(or (eq size '*) (eql size (array-dimension x 0)))
|
|
499
|
+
)
|
|
500
|
+
(c-typep-vector 'SIMPLE-VECTOR-P size x)
|
|
501
|
+
)
|
|
502
|
+
(def-compound-type COMPLEX (&optional (rtype '*) (itype rtype)) (x)
|
|
503
|
+
nil
|
|
504
|
+
(and (complexp x)
|
|
505
|
+
(or (eq rtype '*)
|
|
506
|
+
(typep (realpart x) (upgraded-complex-part-type rtype)))
|
|
507
|
+
(or (eq itype '*)
|
|
508
|
+
(typep (imagpart x) (upgraded-complex-part-type itype))))
|
|
509
|
+
`(AND (COMPLEXP ,x)
|
|
510
|
+
,@(if (eq rtype '*)
|
|
511
|
+
'()
|
|
512
|
+
`((TYPEP (REALPART ,x) ',(upgraded-complex-part-type rtype))))
|
|
513
|
+
,@(if (eq itype '*)
|
|
514
|
+
'()
|
|
515
|
+
`((TYPEP (IMAGPART ,x) ',(upgraded-complex-part-type itype))))))
|
|
516
|
+
(def-compound-type INTEGER (&optional (low '*) (high '*)) (x)
|
|
517
|
+
nil
|
|
518
|
+
(typep-number-test x low high #'integerp 'INTEGER)
|
|
519
|
+
(c-typep-number 'INTEGER 'INTEGERP low high x)
|
|
520
|
+
)
|
|
521
|
+
(def-compound-type MOD (n) (x)
|
|
522
|
+
(unless (integerp n)
|
|
523
|
+
(error (TEXT "~S: argument to MOD must be an integer: ~S")
|
|
524
|
+
'typep n
|
|
525
|
+
) )
|
|
526
|
+
(and (integerp x) (<= 0 x) (< x n))
|
|
527
|
+
`(AND (INTEGERP ,x) (NOT (MINUSP ,x)) (< ,x ,n))
|
|
528
|
+
)
|
|
529
|
+
(def-compound-type SIGNED-BYTE (&optional (n '*)) (x)
|
|
530
|
+
(unless (or (eq n '*) (integerp n))
|
|
531
|
+
(error (TEXT "~S: argument to SIGNED-BYTE must be an integer or * : ~S")
|
|
532
|
+
'typep n
|
|
533
|
+
) )
|
|
534
|
+
(and (integerp x) (or (eq n '*) (< (integer-length x) n)))
|
|
535
|
+
`(AND (INTEGERP ,x)
|
|
536
|
+
,@(if (eq n '*) '() `((< (INTEGER-LENGTH ,x) ,n)))
|
|
537
|
+
)
|
|
538
|
+
)
|
|
539
|
+
(def-compound-type UNSIGNED-BYTE (&optional (n '*)) (x)
|
|
540
|
+
(unless (or (eq n '*) (integerp n))
|
|
541
|
+
(error (TEXT "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S")
|
|
542
|
+
'typep n
|
|
543
|
+
) )
|
|
544
|
+
(and (integerp x)
|
|
545
|
+
(not (minusp x))
|
|
546
|
+
(or (eq n '*) (<= (integer-length x) n))
|
|
547
|
+
)
|
|
548
|
+
`(AND (INTEGERP ,x) (NOT (MINUSP ,x))
|
|
549
|
+
,@(if (eq n '*) '() `((<= (INTEGER-LENGTH ,x) ,n)))
|
|
550
|
+
)
|
|
551
|
+
)
|
|
552
|
+
(def-compound-type REAL (&optional (low '*) (high '*)) (x)
|
|
553
|
+
nil
|
|
554
|
+
(typep-number-test x low high #'realp 'REAL)
|
|
555
|
+
(c-typep-number 'REAL 'REALP low high x)
|
|
556
|
+
)
|
|
557
|
+
(def-compound-type RATIONAL (&optional (low '*) (high '*)) (x)
|
|
558
|
+
nil
|
|
559
|
+
(typep-number-test x low high #'rationalp 'RATIONAL)
|
|
560
|
+
(c-typep-number 'RATIONAL 'RATIONALP low high x)
|
|
561
|
+
)
|
|
562
|
+
(def-compound-type FLOAT (&optional (low '*) (high '*)) (x)
|
|
563
|
+
nil
|
|
564
|
+
(typep-number-test x low high #'floatp 'FLOAT)
|
|
565
|
+
(c-typep-number 'FLOAT 'FLOATP low high x)
|
|
566
|
+
)
|
|
567
|
+
(def-compound-type SHORT-FLOAT (&optional (low '*) (high '*)) (x)
|
|
568
|
+
nil
|
|
569
|
+
(typep-number-test x low high #'short-float-p 'SHORT-FLOAT)
|
|
570
|
+
(c-typep-number 'SHORT-FLOAT 'SHORT-FLOAT-P low high x)
|
|
571
|
+
)
|
|
572
|
+
(def-compound-type SINGLE-FLOAT (&optional (low '*) (high '*)) (x)
|
|
573
|
+
nil
|
|
574
|
+
(typep-number-test x low high #'single-float-p 'SINGLE-FLOAT)
|
|
575
|
+
(c-typep-number 'SINGLE-FLOAT 'SINGLE-FLOAT-P low high x)
|
|
576
|
+
)
|
|
577
|
+
(def-compound-type DOUBLE-FLOAT (&optional (low '*) (high '*)) (x)
|
|
578
|
+
nil
|
|
579
|
+
(typep-number-test x low high #'double-float-p 'DOUBLE-FLOAT)
|
|
580
|
+
(c-typep-number 'DOUBLE-FLOAT 'DOUBLE-FLOAT-P low high x)
|
|
581
|
+
)
|
|
582
|
+
(def-compound-type LONG-FLOAT (&optional (low '*) (high '*)) (x)
|
|
583
|
+
nil
|
|
584
|
+
(typep-number-test x low high #'long-float-p 'LONG-FLOAT)
|
|
585
|
+
(c-typep-number 'LONG-FLOAT 'LONG-FLOAT-P low high x)
|
|
586
|
+
)
|
|
587
|
+
(def-compound-type STRING (&optional (size '*)) (x)
|
|
588
|
+
(ensure-dim STRING size)
|
|
589
|
+
(and (stringp x)
|
|
590
|
+
(or (eq size '*) (eql size (array-dimension x 0)))
|
|
591
|
+
)
|
|
592
|
+
(c-typep-vector 'STRINGP size x)
|
|
593
|
+
)
|
|
594
|
+
(def-compound-type SIMPLE-STRING (&optional (size '*)) (x)
|
|
595
|
+
(ensure-dim SIMPLE-STRING size)
|
|
596
|
+
(and (simple-string-p x)
|
|
597
|
+
(or (eq size '*) (eql size (array-dimension x 0)))
|
|
598
|
+
)
|
|
599
|
+
(c-typep-vector 'SIMPLE-STRING-P size x)
|
|
600
|
+
)
|
|
601
|
+
(def-compound-type BASE-STRING (&optional (size '*)) (x)
|
|
602
|
+
(ensure-dim BASE-STRING size)
|
|
603
|
+
(and (stringp x)
|
|
604
|
+
(or (eq size '*) (eql size (array-dimension x 0)))
|
|
605
|
+
)
|
|
606
|
+
(c-typep-vector 'STRINGP size x)
|
|
607
|
+
)
|
|
608
|
+
(def-compound-type SIMPLE-BASE-STRING (&optional (size '*)) (x)
|
|
609
|
+
(ensure-dim SIMPLE-BASE-STRING size)
|
|
610
|
+
(and (simple-string-p x)
|
|
611
|
+
(or (eq size '*) (eql size (array-dimension x 0)))
|
|
612
|
+
)
|
|
613
|
+
(c-typep-vector 'SIMPLE-STRING-P size x)
|
|
614
|
+
)
|
|
615
|
+
(def-compound-type BIT-VECTOR (&optional (size '*)) (x)
|
|
616
|
+
(ensure-dim BIT-VECTOR size)
|
|
617
|
+
(and (bit-vector-p x)
|
|
618
|
+
(or (eq size '*) (eql size (array-dimension x 0)))
|
|
619
|
+
)
|
|
620
|
+
(c-typep-vector 'BIT-VECTOR-P size x)
|
|
621
|
+
)
|
|
622
|
+
(def-compound-type SIMPLE-BIT-VECTOR (&optional (size '*)) (x)
|
|
623
|
+
(ensure-dim SIMPLE-BIT-VECTOR size)
|
|
624
|
+
(and (simple-bit-vector-p x)
|
|
625
|
+
(or (eq size '*) (eql size (array-dimension x 0)))
|
|
626
|
+
)
|
|
627
|
+
(c-typep-vector 'SIMPLE-BIT-VECTOR-P size x)
|
|
628
|
+
)
|
|
629
|
+
(def-compound-type CONS (&optional (car-type '*) (cdr-type '*)) (x)
|
|
630
|
+
nil
|
|
631
|
+
(and (consp x)
|
|
632
|
+
(or (eq car-type '*) (typep (car x) car-type))
|
|
633
|
+
(or (eq cdr-type '*) (typep (cdr x) cdr-type))
|
|
634
|
+
)
|
|
635
|
+
`(AND (CONSP ,x)
|
|
636
|
+
,@(if (eq car-type '*) '() `((TYPEP (CAR ,x) ',car-type)))
|
|
637
|
+
,@(if (eq cdr-type '*) '() `((TYPEP (CDR ,x) ',cdr-type)))
|
|
638
|
+
)
|
|
639
|
+
)
|
|
640
|
+
|
|
641
|
+
(fmakunbound 'def-compound-type)
|
|
642
|
+
|
|
643
|
+
;; ----------------------------------------------------------------------------
|
|
644
|
+
|
|
645
|
+
; Typtest ohne Gefahr einer Fehlermeldung. Für SIGNAL und HANDLER-BIND.
|
|
646
|
+
(defun safe-typep (x y &optional env)
|
|
647
|
+
(let ((*error-handler*
|
|
648
|
+
#'(lambda (&rest error-args)
|
|
649
|
+
(declare (ignore error-args))
|
|
650
|
+
(return-from safe-typep (values nil nil))
|
|
651
|
+
)) )
|
|
652
|
+
(values (typep x y env) t)
|
|
653
|
+
) )
|
|
654
|
+
|
|
655
|
+
; Umwandlung eines "type for declaration" in einen "type for discrimination".
|
|
656
|
+
(defun type-for-discrimination (y &optional (notp nil) &aux f)
|
|
657
|
+
(cond ((symbolp y)
|
|
658
|
+
(cond ((get y 'TYPE-SYMBOL) y)
|
|
659
|
+
((get y 'TYPE-LIST) y)
|
|
660
|
+
((setq f (get y 'DEFTYPE-EXPANDER))
|
|
661
|
+
(let* ((z (funcall f (list y)))
|
|
662
|
+
(zx (type-for-discrimination z notp)))
|
|
663
|
+
(if (eql zx z) y zx)
|
|
664
|
+
))
|
|
665
|
+
(t y)
|
|
666
|
+
) )
|
|
667
|
+
((and (consp y) (symbolp (first y)))
|
|
668
|
+
(case (first y)
|
|
669
|
+
((SATISFIES MEMBER EQL) y)
|
|
670
|
+
(NOT
|
|
671
|
+
(let* ((z (second y))
|
|
672
|
+
(zx (type-for-discrimination z (not notp))))
|
|
673
|
+
(if (eql zx z) y `(NOT ,zx))
|
|
674
|
+
))
|
|
675
|
+
((AND OR COMPLEX VALUES)
|
|
676
|
+
(let* ((z (rest y))
|
|
677
|
+
(zx (mapcar #'(lambda (x) (type-for-discrimination x notp)) z)))
|
|
678
|
+
(if (every #'eql z zx) y (cons (first y) zx))
|
|
679
|
+
))
|
|
680
|
+
(FUNCTION
|
|
681
|
+
;; (FUNCTION arg-types res-type) is somewhere between
|
|
682
|
+
;; NIL and FUNCTION, but undecidable.
|
|
683
|
+
(if notp 'NIL 'FUNCTION)
|
|
684
|
+
)
|
|
685
|
+
(t (cond ((get (first y) 'TYPE-LIST) y)
|
|
686
|
+
((setq f (get (first y) 'DEFTYPE-EXPANDER))
|
|
687
|
+
(let* ((z (funcall f y))
|
|
688
|
+
(zx (type-for-discrimination z notp)))
|
|
689
|
+
(if (eql zx z) y zx)
|
|
690
|
+
))
|
|
691
|
+
(t y)
|
|
692
|
+
) ) ) )
|
|
693
|
+
(t y)
|
|
694
|
+
) )
|
|
695
|
+
|
|
696
|
+
; Testet eine Liste von Werten auf Erfüllen eines Type-Specifiers. Für THE.
|
|
697
|
+
(defun %the (values type) ; ABI
|
|
698
|
+
(macrolet ((near-typep (objform typform)
|
|
699
|
+
;; near-typep ist wie typep, nur dass das Objekt auch ein
|
|
700
|
+
;; Read-Label sein darf. Das tritt z.B. auf bei
|
|
701
|
+
;; (read-from-string "#1=#S(FOO :X #1#)")
|
|
702
|
+
;; im Konstruktor MAKE-FOO. Die Implementation ist aber
|
|
703
|
+
;; nicht gezwungen, bei fehlerhaftem THE zwingend einen
|
|
704
|
+
;; Fehler zu melden, darum ist ein lascherer Typcheck hier
|
|
705
|
+
;; erlaubt.
|
|
706
|
+
(let ((g (gensym)))
|
|
707
|
+
`(let ((,g ,objform))
|
|
708
|
+
(or (typep ,g ,typform) (eq (type-of ,g) 'READ-LABEL))))))
|
|
709
|
+
(if (and (consp type) (eq (car type) 'VALUES))
|
|
710
|
+
;; The VALUES type specifier is ill-defined in ANSI CL.
|
|
711
|
+
;;
|
|
712
|
+
;; There are two possibilities to define a VALUES type specifier in a
|
|
713
|
+
;; sane way:
|
|
714
|
+
;; - (EXACT-VALUES type1 ... [&optional ...]) describes the exact shape
|
|
715
|
+
;; of the values list, as received by MULTIPLE-VALUE-LIST.
|
|
716
|
+
;; For example, (EXACT-VALUES SYMBOL) is matched by (values 'a) but not
|
|
717
|
+
;; by (values 'a 'b) or (values).
|
|
718
|
+
;; - (ASSIGNABLE-VALUES type1 ... [&optional ...]) describes the values
|
|
719
|
+
;; as received by a set of variables through MULTIPLE-VALUE-BIND or
|
|
720
|
+
;; MULTIPLE-VALUE-SETQ. For example, (ASSIGNABLE-VALUES SYMBOL) is
|
|
721
|
+
;; defined by whether
|
|
722
|
+
;; (MULTIPLE-VALUE-BIND (var1) values (DECLARE (TYPE SYMBOL var1)) ...)
|
|
723
|
+
;; is valid or not; therefore (ASSIGNABLE-VALUES SYMBOL) is matched by
|
|
724
|
+
;; (values 'a) and (values 'a 'b) and (values).
|
|
725
|
+
;; Note that &OPTIONAL is actually redundant here:
|
|
726
|
+
;; (ASSIGNABLE-VALUES type1 ... &optional otype1 ...)
|
|
727
|
+
;; is equivalent to
|
|
728
|
+
;; (ASSIGNABLE-VALUES type1 ... (OR NULL otype1) ...)
|
|
729
|
+
;; HyperSpec/Body/typspe_values.html indicates that VALUES means
|
|
730
|
+
;; EXACT-VALUES; however, HyperSpec/Body/speope_the.html indicates that
|
|
731
|
+
;; VALUES means ASSIGNABLE-VALUES.
|
|
732
|
+
;;
|
|
733
|
+
;; SBCL interprets the VALUES type specifier to mean EXACT-VALUES when
|
|
734
|
+
;; it contains &OPTIONAL or &REST, but ASSIGNABLE-VALUES when it has
|
|
735
|
+
;; only a tuple of type specifiers. This is utter nonsense, in particular
|
|
736
|
+
;; because it makes (VALUES type1 ... typek &OPTIONAL)
|
|
737
|
+
;; different from (VALUES type1 ... typek).
|
|
738
|
+
;;
|
|
739
|
+
;; Here we use the ASSIGNABLE-VALUES interpretation.
|
|
740
|
+
;; In SUBTYPEP we just punt and don't assume any interpretation.
|
|
741
|
+
(let ((vals values) (types (cdr type)))
|
|
742
|
+
;; required:
|
|
743
|
+
(loop
|
|
744
|
+
(when (or (atom types) (atom vals)) (return-from %the t))
|
|
745
|
+
(when (memq (car types) lambda-list-keywords) (return))
|
|
746
|
+
(unless (near-typep (pop vals) (pop types))
|
|
747
|
+
(return-from %the nil)))
|
|
748
|
+
;; &optional:
|
|
749
|
+
(when (and (consp types) (eq (car types) '&optional))
|
|
750
|
+
(setq types (cdr types))
|
|
751
|
+
(loop
|
|
752
|
+
(when (or (atom types) (atom vals)) (return-from %the t))
|
|
753
|
+
(when (memq (car types) lambda-list-keywords) (return))
|
|
754
|
+
(unless (near-typep (pop vals) (pop types))
|
|
755
|
+
(return-from %the nil))))
|
|
756
|
+
;; &rest &key:
|
|
757
|
+
(case (car types)
|
|
758
|
+
(&rest
|
|
759
|
+
(setq types (cdr types))
|
|
760
|
+
(when (atom types) (typespec-error 'the type))
|
|
761
|
+
(unless (near-typep (pop vals) (pop types))
|
|
762
|
+
(return-from %the nil)))
|
|
763
|
+
(&key)
|
|
764
|
+
(t (typespec-error 'the type)))
|
|
765
|
+
(if (eq (car types) '&key)
|
|
766
|
+
(progn
|
|
767
|
+
(setq types (cdr types))
|
|
768
|
+
(when (oddp (length vals)) (return-from %the nil))
|
|
769
|
+
(let ((keywords nil))
|
|
770
|
+
(loop
|
|
771
|
+
(when (or (atom types) (atom vals)) (return-from %the t))
|
|
772
|
+
(when (memq (car types) lambda-list-keywords) (return))
|
|
773
|
+
(let ((item (pop types)))
|
|
774
|
+
(unless (and (listp item) (eql (length item) 2)
|
|
775
|
+
(symbolp (first item)))
|
|
776
|
+
(typespec-error 'the type))
|
|
777
|
+
(let ((kw (symbol-to-keyword (first item))))
|
|
778
|
+
(unless (near-typep (getf vals kw) (second item))
|
|
779
|
+
(return-from %the nil))
|
|
780
|
+
(push kw keywords))))
|
|
781
|
+
(if (and (consp types) (eq (car types) '&allow-other-keys))
|
|
782
|
+
(setq types (cdr types))
|
|
783
|
+
(unless (getf vals ':allow-other-keys)
|
|
784
|
+
(do ((L vals (cddr L)))
|
|
785
|
+
((atom L))
|
|
786
|
+
(unless (memq (car L) keywords)
|
|
787
|
+
(return-from %the nil)))))))
|
|
788
|
+
(when (consp types) (typespec-error 'the type)))
|
|
789
|
+
t)
|
|
790
|
+
(near-typep (if (consp values) (car values) nil) type))))
|
|
791
|
+
|
|
792
|
+
;;; ===========================================================================
|
|
793
|
+
|
|
794
|
+
;; SUBTYPEP
|
|
795
|
+
(load "subtypep")
|
|
796
|
+
|
|
797
|
+
|
|
798
|
+
;; Returns the number of bytes that are needed to represent #\Null in a
|
|
799
|
+
;; given encoding.
|
|
800
|
+
(defun encoding-zeroes (encoding)
|
|
801
|
+
#+UNICODE
|
|
802
|
+
;; this should use min_bytes_per_char for cache, not the hash table
|
|
803
|
+
(let ((name (ext:encoding-charset encoding))
|
|
804
|
+
(table #.(make-hash-table :key-type '(or string symbol) :value-type 'fixnum
|
|
805
|
+
:test 'stablehash-equal :warn-if-needs-rehash-after-gc t
|
|
806
|
+
:initial-contents '(("UTF-7" . 1))))
|
|
807
|
+
(tester #.(make-string 2 :initial-element (code-char 0))))
|
|
808
|
+
(or (gethash name table)
|
|
809
|
+
(setf (gethash name table)
|
|
810
|
+
(- (length (ext:convert-string-to-bytes tester encoding))
|
|
811
|
+
(length (ext:convert-string-to-bytes tester encoding
|
|
812
|
+
:end 1))))))
|
|
813
|
+
#-UNICODE 1)
|
|
814
|
+
|
|
815
|
+
;; Determines two values low,high such that
|
|
816
|
+
;; (subtypep type `(INTEGER ,low ,high))
|
|
817
|
+
;; holds and low is as large as possible and high is as small as possible.
|
|
818
|
+
;; low = * means -infinity, high = * means infinity.
|
|
819
|
+
;; When (subtypep type 'INTEGER) is false, the values NIL,NIL are returned.
|
|
820
|
+
;; We need this function only for MAKE-ARRAY, UPGRADED-ARRAY-ELEMENT-TYPE and
|
|
821
|
+
;; OPEN and can therefore w.l.o.g. replace
|
|
822
|
+
;; type with `(OR ,type (MEMBER 0))
|
|
823
|
+
#| ;; The original implementation calls canonicalize-type and then applies
|
|
824
|
+
;; a particular SUBTYPE variant:
|
|
825
|
+
(defun subtype-integer (type)
|
|
826
|
+
(macrolet ((yes () '(return-from subtype-integer (values low high)))
|
|
827
|
+
(no () '(return-from subtype-integer nil))
|
|
828
|
+
(unknown () '(return-from subtype-integer nil)))
|
|
829
|
+
(setq type (canonicalize-type type))
|
|
830
|
+
(if (consp type)
|
|
831
|
+
(case (first type)
|
|
832
|
+
(MEMBER ; (MEMBER &rest objects)
|
|
833
|
+
;; All elements must be of type INTEGER.
|
|
834
|
+
(let ((low 0) (high 0)) ; wlog!
|
|
835
|
+
(dolist (x (rest type) (yes))
|
|
836
|
+
(unless (typep x 'INTEGER) (return (no)))
|
|
837
|
+
(setq low (min low x) high (max high x)))))
|
|
838
|
+
(OR ; (OR type*)
|
|
839
|
+
;; Every type must be subtype of INTEGER.
|
|
840
|
+
(let ((low 0) (high 0)) ; wlog!
|
|
841
|
+
(dolist (type1 (rest type) (yes))
|
|
842
|
+
(multiple-value-bind (low1 high1) (subtype-integer type1)
|
|
843
|
+
(unless low1 (return (no)))
|
|
844
|
+
(setq low (if (or (eq low '*) (eq low1 '*)) '* (min low low1))
|
|
845
|
+
high (if (or (eq high '*) (eq high1 '*))
|
|
846
|
+
'* (max high high1)))))))
|
|
847
|
+
(AND ; (AND type*)
|
|
848
|
+
;; If one of the types is subtype of INTEGER, then yes,
|
|
849
|
+
;; otherwise unknown.
|
|
850
|
+
(let ((low nil) (high nil))
|
|
851
|
+
(dolist (type1 (rest type))
|
|
852
|
+
(multiple-value-bind (low1 high1) (subtype-integer type1)
|
|
853
|
+
(when low1
|
|
854
|
+
(if low
|
|
855
|
+
(setq low (if (eq low '*) low1 (if (eq low1 '*) low (max low low1)))
|
|
856
|
+
high (if (eq high '*) high1 (if (eq high1 '*) high (min high high1))))
|
|
857
|
+
(setq low low1 high high1)))))
|
|
858
|
+
(if low
|
|
859
|
+
(progn
|
|
860
|
+
(when (and (numberp low) (numberp high) (not (<= low high)))
|
|
861
|
+
(setq low 0 high 0) ; type equivalent to NIL)
|
|
862
|
+
(yes))
|
|
863
|
+
(unknown)))))
|
|
864
|
+
(setq type (list type)))
|
|
865
|
+
(if (eq (first type) 'INTEGER)
|
|
866
|
+
(let ((low (if (rest type) (second type) '*))
|
|
867
|
+
(high (if (cddr type) (third type) '*)))
|
|
868
|
+
(when (consp low)
|
|
869
|
+
(setq low (first low))
|
|
870
|
+
(when (numberp low) (incf low)))
|
|
871
|
+
(when (consp high)
|
|
872
|
+
(setq high (first high))
|
|
873
|
+
(when (numberp high) (decf high)))
|
|
874
|
+
(when (and (numberp low) (numberp high) (not (<= low high))) ; type leer?
|
|
875
|
+
(setq low 0 high 0))
|
|
876
|
+
(yes))
|
|
877
|
+
(if (and (eq (first type) 'INTERVALS) (eq (second type) 'INTEGER))
|
|
878
|
+
(let ((low (third type))
|
|
879
|
+
(high (car (last type))))
|
|
880
|
+
(when (consp low)
|
|
881
|
+
(setq low (first low))
|
|
882
|
+
(when (numberp low) (incf low)))
|
|
883
|
+
(when (consp high)
|
|
884
|
+
(setq high (first high))
|
|
885
|
+
(when (numberp high) (decf high)))
|
|
886
|
+
(yes))
|
|
887
|
+
(unknown)))))
|
|
888
|
+
|# ;; This implementation inlines the (tail-recursive) canonicalize-type
|
|
889
|
+
;; function. Its advantage is that it doesn't cons as much.
|
|
890
|
+
;; (For example, (subtype-integer '(UNSIGNED-BYTE 8)) doesn't cons.)
|
|
891
|
+
(defun subtype-integer (type)
|
|
892
|
+
(macrolet ((yes () '(return-from subtype-integer (values low high)))
|
|
893
|
+
(no () '(return-from subtype-integer nil))
|
|
894
|
+
(unknown () '(return-from subtype-integer nil)))
|
|
895
|
+
(setq type (expand-deftype type))
|
|
896
|
+
(cond ((symbolp type)
|
|
897
|
+
(case type
|
|
898
|
+
(BIT (let ((low 0) (high 1)) (yes)))
|
|
899
|
+
(FIXNUM
|
|
900
|
+
(let ((low '#,most-negative-fixnum)
|
|
901
|
+
(high '#,most-positive-fixnum))
|
|
902
|
+
(yes)))
|
|
903
|
+
((INTEGER BIGNUM SIGNED-BYTE)
|
|
904
|
+
(let ((low '*) (high '*)) (yes)))
|
|
905
|
+
(UNSIGNED-BYTE
|
|
906
|
+
(let ((low 0) (high '*)) (yes)))
|
|
907
|
+
((NIL)
|
|
908
|
+
(let ((low 0) (high 0)) (yes))) ; wlog!
|
|
909
|
+
(t (no))))
|
|
910
|
+
((and (consp type) (symbolp (first type)))
|
|
911
|
+
(unless (and (list-length type) (null (cdr (last type))))
|
|
912
|
+
(typespec-error 'subtypep type))
|
|
913
|
+
(case (first type)
|
|
914
|
+
(MEMBER ; (MEMBER &rest objects)
|
|
915
|
+
;; All elements must be of type INTEGER.
|
|
916
|
+
(let ((low 0) (high 0)) ; wlog!
|
|
917
|
+
(dolist (x (rest type) (yes))
|
|
918
|
+
(unless (typep x 'INTEGER) (return (no)))
|
|
919
|
+
(setq low (min low x) high (max high x)))))
|
|
920
|
+
(EQL ; (EQL object)
|
|
921
|
+
(let ((x (second type)))
|
|
922
|
+
(if (typep x 'INTEGER)
|
|
923
|
+
(let ((low (min 0 x)) (high (max 0 x))) (yes))
|
|
924
|
+
(no))))
|
|
925
|
+
(OR ; (OR type*)
|
|
926
|
+
;; Every type must be subtype of INTEGER.
|
|
927
|
+
(let ((low 0) (high 0)) ; wlog!
|
|
928
|
+
(dolist (type1 (rest type) (yes))
|
|
929
|
+
(multiple-value-bind (low1 high1) (subtype-integer type1)
|
|
930
|
+
(unless low1 (return (no)))
|
|
931
|
+
(setq low (if (or (eq low '*) (eq low1 '*))
|
|
932
|
+
'* (min low low1))
|
|
933
|
+
high (if (or (eq high '*) (eq high1 '*))
|
|
934
|
+
'* (max high high1)))))))
|
|
935
|
+
(AND ; (AND type*)
|
|
936
|
+
;; If one of the types is subtype of INTEGER, then yes,
|
|
937
|
+
;; otherwise unknown.
|
|
938
|
+
(let ((low nil) (high nil))
|
|
939
|
+
(dolist (type1 (rest type))
|
|
940
|
+
(multiple-value-bind (low1 high1) (subtype-integer type1)
|
|
941
|
+
(when low1
|
|
942
|
+
(if low
|
|
943
|
+
(setq low (if (eq low '*) low1
|
|
944
|
+
(if (eq low1 '*) low
|
|
945
|
+
(max low low1)))
|
|
946
|
+
high (if (eq high '*) high1
|
|
947
|
+
(if (eq high1 '*) high
|
|
948
|
+
(min high high1))))
|
|
949
|
+
(setq low low1
|
|
950
|
+
high high1)))))
|
|
951
|
+
(if low
|
|
952
|
+
(progn
|
|
953
|
+
(when (and (numberp low) (numberp high)
|
|
954
|
+
(not (<= low high)))
|
|
955
|
+
(setq low 0 high 0)) ; type equivalent to NIL
|
|
956
|
+
(yes))
|
|
957
|
+
(unknown))))
|
|
958
|
+
(INTEGER
|
|
959
|
+
(let ((low (if (rest type) (second type) '*))
|
|
960
|
+
(high (if (cddr type) (third type) '*)))
|
|
961
|
+
(when (consp low)
|
|
962
|
+
(setq low (first low))
|
|
963
|
+
(when (numberp low) (incf low)))
|
|
964
|
+
(when (consp high)
|
|
965
|
+
(setq high (first high))
|
|
966
|
+
(when (numberp high) (decf high)))
|
|
967
|
+
(when (and (numberp low) (numberp high) (not (<= low high)))
|
|
968
|
+
(setq low 0 high 0)) ; type equivalent to NIL
|
|
969
|
+
(yes)))
|
|
970
|
+
(INTERVALS
|
|
971
|
+
(if (eq (second type) 'INTEGER)
|
|
972
|
+
(let ((low (third type))
|
|
973
|
+
(high (car (last type))))
|
|
974
|
+
(when (consp low)
|
|
975
|
+
(setq low (first low))
|
|
976
|
+
(when (numberp low) (incf low)))
|
|
977
|
+
(when (consp high)
|
|
978
|
+
(setq high (first high))
|
|
979
|
+
(when (numberp high) (decf high)))
|
|
980
|
+
(yes))
|
|
981
|
+
(unknown)))
|
|
982
|
+
(MOD ; (MOD n)
|
|
983
|
+
(let ((n (second type)))
|
|
984
|
+
(unless (and (integerp n) (>= n 0))
|
|
985
|
+
(typespec-error 'subtypep type))
|
|
986
|
+
(if (eql n 0)
|
|
987
|
+
(no)
|
|
988
|
+
(let ((low 0) (high (1- n)))
|
|
989
|
+
(yes)))))
|
|
990
|
+
(SIGNED-BYTE ; (SIGNED-BYTE &optional s)
|
|
991
|
+
(let ((s (if (cdr type) (second type) '*)))
|
|
992
|
+
(if (eq s '*)
|
|
993
|
+
(let ((low '*) (high '*)) (yes))
|
|
994
|
+
(progn
|
|
995
|
+
(unless (and (integerp s) (plusp s))
|
|
996
|
+
(typespec-error 'subtypep type))
|
|
997
|
+
(let ((n (ash 1 (1- s)))) ; (ash 1 *) == (expt 2 *)
|
|
998
|
+
(let ((low (- n)) (high (1- n)))
|
|
999
|
+
(yes)))))))
|
|
1000
|
+
(UNSIGNED-BYTE ; (UNSIGNED-BYTE &optional s)
|
|
1001
|
+
(let ((s (if (cdr type) (second type) '*)))
|
|
1002
|
+
(if (eq s '*)
|
|
1003
|
+
(let ((low 0) (high '*)) (yes))
|
|
1004
|
+
(progn
|
|
1005
|
+
(unless (and (integerp s) (>= s 0))
|
|
1006
|
+
(typespec-error 'subtypep type))
|
|
1007
|
+
(let ((n (ash 1 s))) ; (ash 1 *) == (expt 2 *)
|
|
1008
|
+
(let ((low 0) (high (1- n)))
|
|
1009
|
+
(yes)))))))
|
|
1010
|
+
(t (no))))
|
|
1011
|
+
((clos::defined-class-p type)
|
|
1012
|
+
(if (and (clos::built-in-class-p type)
|
|
1013
|
+
(eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type))
|
|
1014
|
+
(return-from subtype-integer
|
|
1015
|
+
(subtype-integer (clos:class-name type)))
|
|
1016
|
+
(no)))
|
|
1017
|
+
((clos::eql-specializer-p type)
|
|
1018
|
+
(let ((x (clos::eql-specializer-singleton type)))
|
|
1019
|
+
(if (typep x 'INTEGER)
|
|
1020
|
+
(let ((low (min 0 x)) (high (max 0 x))) (yes))
|
|
1021
|
+
(no))))
|
|
1022
|
+
((encodingp type) (no))
|
|
1023
|
+
(t (typespec-error 'subtypep type)))))
|
|
1024
|
+
|
|
1025
|
+
#| TODO: Fix subtype-integer such that this works.
|
|
1026
|
+
Henry Baker:
|
|
1027
|
+
(defun type-null (x)
|
|
1028
|
+
(values (and (eq 'bit (upgraded-array-element-type `(or bit ,x)))
|
|
1029
|
+
(not (typep 0 x))
|
|
1030
|
+
(not (typep 1 x)))
|
|
1031
|
+
t))
|
|
1032
|
+
(type-null '(and symbol number))
|
|
1033
|
+
(type-null '(and integer symbol))
|
|
1034
|
+
(type-null '(and integer character))
|
|
1035
|
+
|#
|
|
1036
|
+
|
|
1037
|
+
;; Determines a sequence kind (an atom, as defined in defseq.lisp: one of
|
|
1038
|
+
;; LIST - stands for LIST
|
|
1039
|
+
;; VECTOR - stands for (VECTOR T)
|
|
1040
|
+
;; STRING - stands for (VECTOR CHARACTER)
|
|
1041
|
+
;; 1, 2, 4, 8, 16, 32 - stands for (VECTOR (UNSIGNED-BYTE n))
|
|
1042
|
+
;; 0 - stands for (VECTOR NIL))
|
|
1043
|
+
;; that indicates the sequence type meant by the given type. Other possible
|
|
1044
|
+
;; return values are
|
|
1045
|
+
;; SEQUENCE - denoting a type whose intersection with (OR LIST VECTOR) is not
|
|
1046
|
+
;; subtype of LIST or VECTOR, or
|
|
1047
|
+
;; NIL - indicating a type whose intersection with (OR LIST VECTOR) is empty.
|
|
1048
|
+
;; When the type is (OR (VECTOR eltype1) ... (VECTOR eltypeN)), the chosen
|
|
1049
|
+
;; element type is the smallest element type that contains all of eltype1 ...
|
|
1050
|
+
;; eltypeN.
|
|
1051
|
+
;;
|
|
1052
|
+
;; User-defined sequence types are not supported here.
|
|
1053
|
+
;;
|
|
1054
|
+
;; This implementation inlines the (tail-recursive) canonicalize-type
|
|
1055
|
+
;; function. Its advantage is that it doesn't cons as much. Also it employs
|
|
1056
|
+
;; some heuristics and does not have the full power of SUBTYPEP.
|
|
1057
|
+
(defun subtype-sequence (type)
|
|
1058
|
+
(setq type (expand-deftype type))
|
|
1059
|
+
(cond ((symbolp type)
|
|
1060
|
+
(case type
|
|
1061
|
+
((LIST CONS NULL) 'LIST)
|
|
1062
|
+
((NIL) 'NIL)
|
|
1063
|
+
((BIT-VECTOR SIMPLE-BIT-VECTOR) '1)
|
|
1064
|
+
((STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING) 'STRING)
|
|
1065
|
+
((VECTOR SIMPLE-VECTOR ARRAY SIMPLE-ARRAY) 'VECTOR)
|
|
1066
|
+
((SEQUENCE) 'SEQUENCE)
|
|
1067
|
+
(t 'NIL)))
|
|
1068
|
+
((and (consp type) (symbolp (first type)))
|
|
1069
|
+
(unless (and (list-length type) (null (cdr (last type))))
|
|
1070
|
+
(typespec-error 'subtypep type))
|
|
1071
|
+
(case (first type)
|
|
1072
|
+
(MEMBER ; (MEMBER &rest objects)
|
|
1073
|
+
(let ((kind 'NIL))
|
|
1074
|
+
(dolist (x (rest type))
|
|
1075
|
+
(setq kind (sequence-type-union kind (type-of-sequence x))))
|
|
1076
|
+
kind))
|
|
1077
|
+
(EQL ; (EQL object)
|
|
1078
|
+
(unless (eql (length type) 2)
|
|
1079
|
+
(typespec-error 'subtypep type))
|
|
1080
|
+
(type-of-sequence (second type)))
|
|
1081
|
+
(OR ; (OR type*)
|
|
1082
|
+
(let ((kind 'NIL))
|
|
1083
|
+
(dolist (x (rest type))
|
|
1084
|
+
(setq kind (sequence-type-union kind (subtype-sequence x))))
|
|
1085
|
+
kind))
|
|
1086
|
+
(AND ; (AND type*)
|
|
1087
|
+
(let ((kind 'SEQUENCE))
|
|
1088
|
+
(dolist (x (rest type))
|
|
1089
|
+
(setq kind (sequence-type-intersection kind (subtype-sequence x))))
|
|
1090
|
+
kind))
|
|
1091
|
+
((SIMPLE-BIT-VECTOR BIT-VECTOR) ; (SIMPLE-BIT-VECTOR &optional size)
|
|
1092
|
+
(when (cddr type)
|
|
1093
|
+
(typespec-error 'subtypep type))
|
|
1094
|
+
'1)
|
|
1095
|
+
((SIMPLE-STRING STRING SIMPLE-BASE-STRING BASE-STRING) ; (SIMPLE-STRING &optional size)
|
|
1096
|
+
(when (cddr type)
|
|
1097
|
+
(typespec-error 'subtypep type))
|
|
1098
|
+
'STRING)
|
|
1099
|
+
(SIMPLE-VECTOR ; (SIMPLE-VECTOR &optional size)
|
|
1100
|
+
(when (cddr type)
|
|
1101
|
+
(typespec-error 'subtypep type))
|
|
1102
|
+
'VECTOR)
|
|
1103
|
+
((VECTOR ARRAY SIMPLE-ARRAY) ; (VECTOR &optional el-type size), (ARRAY &optional el-type dimensions)
|
|
1104
|
+
(when (cdddr type)
|
|
1105
|
+
(typespec-error 'subtypep type))
|
|
1106
|
+
(let ((el-type (if (cdr type) (second type) '*)))
|
|
1107
|
+
(if (eq el-type '*)
|
|
1108
|
+
'VECTOR
|
|
1109
|
+
(let ((eltype (upgraded-array-element-type el-type)))
|
|
1110
|
+
(cond ((eq eltype 'T) 'VECTOR)
|
|
1111
|
+
((eq eltype 'CHARACTER) 'STRING)
|
|
1112
|
+
((eq eltype 'BIT) '1)
|
|
1113
|
+
((and (consp eltype) (eq (first eltype) 'UNSIGNED-BYTE)) (second eltype))
|
|
1114
|
+
((eq eltype 'NIL) '0)
|
|
1115
|
+
(t (error (TEXT "~S is not up-to-date with ~S for element type ~S")
|
|
1116
|
+
'subtypep-sequence 'upgraded-array-element-type eltype)))))))
|
|
1117
|
+
((CONS) ; (CONS &optional cartype cdrtype)
|
|
1118
|
+
(when (cdddr type)
|
|
1119
|
+
(typespec-error 'subtypep type))
|
|
1120
|
+
'LIST)
|
|
1121
|
+
(t 'NIL)))
|
|
1122
|
+
((clos::defined-class-p type)
|
|
1123
|
+
(if (and (clos::built-in-class-p type)
|
|
1124
|
+
(eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type))
|
|
1125
|
+
(subtype-sequence (clos:class-name type))
|
|
1126
|
+
'NIL))
|
|
1127
|
+
((clos::eql-specializer-p type)
|
|
1128
|
+
(type-of-sequence (clos::eql-specializer-singleton type)))
|
|
1129
|
+
(t 'NIL)))
|
|
1130
|
+
(defun type-of-sequence (x)
|
|
1131
|
+
(cond ((listp x) 'LIST)
|
|
1132
|
+
((vectorp x)
|
|
1133
|
+
(let ((eltype (array-element-type x)))
|
|
1134
|
+
(cond ((eq eltype 'T) 'VECTOR)
|
|
1135
|
+
((eq eltype 'CHARACTER) 'STRING)
|
|
1136
|
+
((eq eltype 'BIT) '1)
|
|
1137
|
+
((and (consp eltype) (eq (first eltype) 'UNSIGNED-BYTE)) (second eltype))
|
|
1138
|
+
((eq eltype 'NIL) '0)
|
|
1139
|
+
(t (error (TEXT "~S is not up-to-date with ~S for element type ~S")
|
|
1140
|
+
'type-of-sequence 'array-element-type eltype)))))
|
|
1141
|
+
(t 'NIL)))
|
|
1142
|
+
(defun sequence-type-union (t1 t2)
|
|
1143
|
+
(cond ; Simple general rules.
|
|
1144
|
+
((eql t1 t2) t1)
|
|
1145
|
+
((eq t1 'NIL) t2)
|
|
1146
|
+
((eq t2 'NIL) t1)
|
|
1147
|
+
; Now the union of two different types.
|
|
1148
|
+
((or (eq t1 'SEQUENCE) (eq t2 'SEQUENCE)) 'SEQUENCE)
|
|
1149
|
+
((or (eq t1 'LIST) (eq t2 'LIST))
|
|
1150
|
+
; union of LIST and a vector type
|
|
1151
|
+
'SEQUENCE)
|
|
1152
|
+
((or (eq t1 'VECTOR) (eq t2 'VECTOR)) 'VECTOR)
|
|
1153
|
+
((eql t1 0) t2)
|
|
1154
|
+
((eql t2 0) t1)
|
|
1155
|
+
((or (eq t1 'STRING) (eq t2 'STRING))
|
|
1156
|
+
; union of STRING and an integer-vector type
|
|
1157
|
+
'VECTOR)
|
|
1158
|
+
(t (max t1 t2))))
|
|
1159
|
+
(defun sequence-type-intersection (t1 t2)
|
|
1160
|
+
(cond ; Simple general rules.
|
|
1161
|
+
((eql t1 t2) t1)
|
|
1162
|
+
((or (eq t1 'NIL) (eq t2 'NIL)) 'NIL)
|
|
1163
|
+
; Now the intersection of two different types.
|
|
1164
|
+
((eq t1 'SEQUENCE) t2)
|
|
1165
|
+
((eq t2 'SEQUENCE) t1)
|
|
1166
|
+
((or (eq t1 'LIST) (eq t2 'LIST))
|
|
1167
|
+
; intersection of LIST and a vector type
|
|
1168
|
+
'NIL)
|
|
1169
|
+
((eq t1 'VECTOR) t2)
|
|
1170
|
+
((eq t2 'VECTOR) t1)
|
|
1171
|
+
((or (eql t1 0) (eql t2 0)) '0)
|
|
1172
|
+
((or (eq t1 'STRING) (eq t2 'STRING))
|
|
1173
|
+
; intersection of STRING and an integer-vector type
|
|
1174
|
+
'0)
|
|
1175
|
+
(t (min t1 t2))))
|
|
1176
|
+
|
|
1177
|
+
;; ============================================================================
|
|
1178
|
+
|
|
1179
|
+
(defun type-expand (typespec &optional once-p)
|
|
1180
|
+
(multiple-value-bind (expanded user-defined-p)
|
|
1181
|
+
(expand-deftype typespec once-p)
|
|
1182
|
+
(if user-defined-p (values expanded user-defined-p)
|
|
1183
|
+
(cond ((symbolp typespec)
|
|
1184
|
+
(cond ((or (get typespec 'TYPE-SYMBOL) (get typespec 'TYPE-LIST))
|
|
1185
|
+
(values typespec nil))
|
|
1186
|
+
((or (get typespec 'DEFSTRUCT-DESCRIPTION)
|
|
1187
|
+
(clos-class typespec))
|
|
1188
|
+
(values typespec nil))
|
|
1189
|
+
(t (typespec-error 'type-expand typespec))))
|
|
1190
|
+
((and (consp typespec) (symbolp (first typespec)))
|
|
1191
|
+
(case (first typespec)
|
|
1192
|
+
((SATISFIES MEMBER EQL NOT AND OR) (values typespec nil))
|
|
1193
|
+
(t (cond ((get (first typespec) 'TYPE-LIST)
|
|
1194
|
+
(values typespec nil))
|
|
1195
|
+
(t (typespec-error 'type-expand typespec))))))
|
|
1196
|
+
((clos::defined-class-p typespec) (values typespec nil))
|
|
1197
|
+
(t (typespec-error 'type-expand typespec))))))
|
|
1198
|
+
|
|
1199
|
+
;; ============================================================================
|
|
1200
|
+
|
|
1201
|
+
(unless (clos::funcallable-instance-p #'clos::class-name)
|
|
1202
|
+
(fmakunbound 'clos::class-name))
|