Software Público Brasileiro

###############################################################################
# Name: lisp.py                                                               #
# Purpose: Define Lisp syntax for highlighting and other features             #
# Author: Cody Precord <cprecord@editra.org>                                  #
# Author: Jeff                                                                #
# Copyright: (c) 2007 Cody Precord <staff@editra.org>                         #
# License: wxWindows License                                                  #
###############################################################################

"""
FILE: lisp.py
AUTHOR: Cody Precord
@summary: Lexer configuration module for Lisp Files.
@todo: Add Standard Variables

"""

__author__ = "Cody Precord <cprecord@editra.org>"
__svnid__ = "$Id: _lisp.py 68798 2011-08-20 17:17:05Z CJP $"
__revision__ = "$Revision: 68798 $"

#-----------------------------------------------------------------------------#
# Imports
import wx.stc as stc

# Local Imports
import synglob
import syndata

#-----------------------------------------------------------------------------#

#---- Keyword Definitions ----#

# Lisp Functions/Operators
LISP_FUNC = (0, "abort abs access acons acos acosh add-method adjoin "
                "adjust-array adjustable-array-p alist allocate-instance "
                "alpha-char-p alphanumericp and append apply applyhook apropos "
                "apropos-list aref arithmetic-error arithmetic-error-operands "
                "arithmetic-error-operation array array-dimension "
                "array-dimension-limit array-dimensions array-displacement "
                "array-element-type array-has-fill-pointer-p "
                "array-in-bounds-p array-rank array-rank-limit "
                "array-row-major-index array-total-size "
                "array-total-size-limit arrayp ash asin asinh assert assoc "
                "assoc-if assoc-if-not atan atanh atom backquote baktrace "
                "base-char base-string bignum bignums bit bit-and bit-andc1 "
                "bit-andc2 bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 "
                "bit-orc2 bit-vector bit-vector-p bit-xor block boole boole-1 "
                "boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 "
                "boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 "
                "boole-orc2 boole-set boole-xor boolean both-case-p boundp "
                "break broadcast-stream broadcast-stream-streams "
                "built-in-class butlast byte byte-position byte-size caaaar "
                "caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar "
                "caddar cadddr caddr cadr call-arguments-limit call-method "
                "call-next-method capitalize car case catch ccase cdaaar "
                "cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar "
                "cdddar cddddr cdddr cddr cdr ceil-error ceil-error-name "
                "ceiling cerror change-class char char-bit char-bits "
                "char-bits-limit char-code char-code-limit char-control-bit "
                "char-downcase char-equal char-font char-font-limit "
                "char-greaterp char-hyper-bit char-int char-lessp "
                "char-meta-bit char-name char-not-equal char-not-greaterp "
                "char-not-lessp char-super-bit char-upcase char/= char<= char= "
                "char>= character characterp check-type cirhash cis class "
                "class-name class-of clear-input clear-output close code-char "
                "coerce commonp compilation-speed compile compile-file "
                "compile-file-pathname compiled-function compiled-function-p "
                "compiler-let compiler-macro compiler-macro-function "
                "complement complex complexp compute-applicable-methods "
                "compute-restarts concatenate concatenated-stream "
                "concatenated-stream-streams cond condition conjugate cons "
                "consp constantly constantp continue control-error copy "
                "copy-list copy-pprint-dispatch copy-readtable copy-seq "
                "copy-structure copy-symbol copy-tree cos cosh count count-if "
                "count-if-not ctypecase debug decf declaim declaration declare "
                "decode-float decode-universal-time defclass defconstant "
                "defgeneric define-compiler-macro define-condition "
                "define-method-combination define-modify-macro "
                "define-setf-expander define-setf-method define-symbol-macro "
                "defmacro defmethod defpackage defparameter defsetf defstruct "
                "deftype defun defvar delete delete-duplicates delete-file "
                "delete-if delete-if-not delete-package denominator "
                "deposite-field describe describe-object destructuring-bind "
                "digit-char digit-char-p directory directory-namestring "
                "disassemble division-by-zero do do* do-all-symbols "
                "do-external-symbols do-symbols dolist dotimes double-float "
                "double-float-epsilon double-float-negative-epsilion dpb "
                "dribble dynamic-extent ecase echo-stream "
                "echo-stream-input-stream echo-stream-output-stream ed eigth "
                "elt encode-universal-time end-of-file endp enough-namestring "
                "ensure-directories-exist ensure-generic-function eq eql equal "
                "equalp error errset etypecase eval eval-when evalhook evenp "
                "every exp export expt extend-char fboundp fceiling "
                "fdefinition fflor fifth file-author file-error "
                "file-error-pathname file-length file-namestring file-position "
                "file-stream 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 fixnum flet float float-digits "
                "float-precision float-radix float-sign floating-point-inexact "
                "floating-point-invalid-operation floating-point-underflow "
                "floatp floor fmakunbound force-output format formatter fourth "
                "fresh-line fround ftruncate ftype funcall function "
                "function-keywords function-lambda-expression functionp gbitp "
                "gcd generic-function gensym gentemp get get-decoded-time "
                "get-dispatched-macro-character get-internal-real-time "
                "get-internal-run-time get-macro-character "
                "get-output-stream-string get-properties get-setf-expansion "
                "get-setf-method get-universial-time getf gethash go "
                "graphic-char-p handler-bind handler-case hash hash-table "
                "hash-table-count hash-table-p hash-table-rehash-size "
                "hash-table-rehash-threshold hash-table-size hash-table-test "
                "host-namestring identity if if-exists ignorable ignore "
                "ignore-errors imagpart import in-package incf "
                "initialize-instance inline input-stream-p inspect int-char "
                "integer integer-decode-float integer-length integerp "
                "interactive-stream-p intern internal-time-units-per-second "
                "intersection invalid-method-error invoke-debugger "
                "invoke-restart invoke-restart-interactively isqrt keyword "
                "keywordp l labels lambda lambda-list-keywords "
                "lambda-parameters-limit last lcm ldb ldb-test ldiff "
                "least-negative-double-float least-negative-long-float "
                "least-negative-normalized-double-float "
                "least-negative-normalized-long-float "
                "least-negative-normalized-short-font "
                "least-negative-normalized-single-font "
                "least-negative-short-font least-negative-single-font "
                "least-positive-double-float least-positive-long-float "
                "least-positive-normalized-double-float "
                "least-positive-normalized-long-float "
                "least-positive-normalized-short-float "
                "least-positive-normalized-single-float "
                "least-positive-short-float least-positive-single-float length "
                "let let* lisp lisp-implementation-type "
                "lisp-implementation-version list list* "
                "list-all-packages list-lenght listen listp load "
                "load-logical-pathname-translation load-time-value locally "
                "log logand logandc1 logandc2 logbitp logcount logeqv "
                "logical-pathname logical-pathname-translations logior lognand "
                "lognor lognot logorc1 logorc2 logtest logxor long-float "
                "long-float-epsilon long-float-negative-epsilon long-site-name "
                "loop loop-finish lower-case-p machine-instance machine-type "
                "machine-version macro-function macroexpand macroexpand-1 "
                "macroexpand-l macrolet make make-array make-broadcast-stream "
                "make-char 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-method 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 map-into mapc mapcan "
                "mapcar mapcon maphash mapl maplist mask-field max member "
                "member-if member-if-not merge merge-pathname merge-pathnames "
                "method method-combination method-combination-error "
                "method-qualifiers min minusp mismatch mod "
                "most-negative-double-float most-negative-fixnum "
                "most-negative-long-float most-negative-short-float "
                "most-negative-single-float most-positive-fixnum "
                "most-positive-long-float most-positive-short-float "
                "most-positive-single-float muffle-warning "
                "multiple-value-bind multiple-value-call multiple-value-limit "
                "multiple-value-list multiple-value-prog1 multiple-value-seteq "
                "multiple-value-setq name name-char namestring nbutlast nconc "
                "next-method-p nil nintersection ninth no-applicable-method "
                "no-next-method not notany notevery notinline nreconc nreverse "
                "nset-difference nset-exclusive-or nstring nstring-capitalize "
                "nstring-downcase nstring-upcase nstubst-if-not nsublis nsubst "
                "nsubst-if nth nth-value nthcdr null number numberp numerator "
                "nunion oddp open open-stream-p optimize or otherwise "
                "output-stream-p package package-error package-error-package "
                "package-name package-nicknames package-shadowing-symbols "
                "package-use-list package-used-by-list packagep pairlis "
                "parse-error parse-integer parse-namestring pathname "
                "pathname-device pathname-directory pathname-host "
                "pathname-match-p pathname-name pathname-type "
                "pathname-version pathnamep peek-char phase pi plist plusp pop "
                "position position-if position-if-not pprint pprint-dispatch "
                "pprint-exit-if-list-exhausted pprint-fill pprint-indent "
                "pprint-linear pprint-logical-block pprint-newline pprint-pop "
                "pprint-tab pprint-tabular prin1 prin1-to-string princ "
                "princ-to-string print print-not-readable "
                "print-not-readable-object print-object probe-file proclaim "
                "prog prog* prog1 prog2 progn program-error progv provide "
                "psetf psetq push pushnew putprop quote random random-state "
                "random-state-p rassoc rassoc-if rassoc-if-not ration rational "
                "rationalize rationalp read read-byte read-car-no-hang "
                "read-char read-delimited-list read-eval-print "
                "read-from-string read-line read-preserving-whitespace "
                "read-squence reader-error readtable readtable-case readtablep "
                "real realp realpart reduce reinitialize-instance rem remf "
                "remhash remove remove-duplicates remove-if "
                "remove-if-not remove-method remprop rename-file "
                "rename-package replace require rest restart restart-bind "
                "restart-case restart-name return return-from revappend "
                "reverse room rotatef round row-major-aref rplaca rplacd "
                "safety satisfies sbit scale-float schar search second "
                "sequence serious-condition set set-char-bit set-difference "
                "set-dispatched-macro-character set-exclusive-or "
                "set-macro-character set-pprint-dispatch "
                "set-syntax-from-char setf setq seventh shadow "
                "shadowing-import shared-initialize shiftf short-float "
                "short-float-epsilon short-float-negative-epsilon "
                "short-site-name signal signed-byte signum simple-array "
                "simple-base-string simple-bit-vector- simple-bit-vector-p "
                "simple-condition simple-condition-format-arguments "
                "simple-condition-format-control simple-error simple-string "
                "simple-string-p simple-type-error simple-vector "
                "simple-vector-p simple-warning sin single-float "
                "single-float-epsilon single-float-negative-epsilon sinh "
                "sixth sleep slot-boundp slot-exists-p slot-makunbound "
                "slot-missing slot-unbound slot-value software-type "
                "software-version some sort space special special-form-p "
                "special-operator-p speed sqrt stable-sort standard "
                "standard-char standard-char-p standard-class "
                "standard-generic-function standard-method standard-object "
                "step storage-condition store-value stream stream-element-type "
                "stream-error stream-error-stream stream-external-format "
                "streamp streamup string string-capitalize string-char "
                "string-char-p string-downcase string-equal string-greaterp "
                "string-left-trim string-lessp string-not-equal "
                "string-not-greaterp string-not-lessp string-right-strim "
                "string-right-trim string-stream string-trim string-upcase "
                "string/= string< string<= string= string> string>= stringp "
                "structure structure-class structure-object style-warning "
                "sublim sublis subseq subsetp subst subst-if subst-if-not "
                "substitute substitute-if substitute-if-not subtypep svref "
                "sxhash symbol symbol-function symbol-macrolet symbol-name "
                "symbol-package symbol-plist symbol-value symbolp "
                "synonym-stream synonym-stream-symbol sys system t tagbody "
                "tailp tan tanh tenth terpri the third throw time trace "
                "translate-logical-pathname translate-pathname tree-equal "
                "truename truncase truncate two-way-stream "
                "two-way-stream-input-stream two-way-stream-output-stream "
                "type type-error type-error-datnum type-error-expected-type "
                "type-of typecase typep unbound-slot unbound-slot-instance "
                "unbound-variable undefined-function unexport unintern union "
                "unless unread unread-char unsigned-byte untrace unuse-package "
                "unwind-protect update-instance-for-different-class "
                "update-instance-for-redefined-class "
                "upgraded-array-element-type upgraded-complex-part-type "
                "upper-case-p use-package use-value user user-homedir-pathname "
                "value value-list values vector vector-pop vector-push "
                "vector-push-extend vectorp warn warning when "
                "wild-pathname-p 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 write "
                "write-byte write-char write-line write-sequence" )

SCHEME_KW = (0, "* + - / < <= = => > >= abs acos and angle append apply asin "
                "assoc assq assv atan begin boolean? caaaar caaadr caaar "
                "caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr "
                "caddr cadr call-with-current-continuation "
                "call-with-input-file call-with-output-file call-with-values "
                "call/cc car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar "
                "cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling "
                "char->integer char-alphabetic? char-ci<=? char-ci<? char-ci=? "
                "char-ci>=? char-ci>? char-downcase char-lower-case? "
                "char-numeric? char-ready? char-upcase char-upper-case? "
                "char-whitespace? char<=? char<? char=? char>=? char>? char? "
                "close-input-port close-output-port complex? cond cons cos "
                "current-input-port current-output-port define define-syntax "
                "delay denominator display do dynamic-wind else eof-object? "
                "eq? equal? eqv? eval even? exact->inexact exact? exp expt "
                "floor for-each force gcd if imag-part inexact->exact inexact? "
                "input-port? integer->char integer? interaction-environment "
                "lambda lcm length let let* let-syntax letrec letrec-syntax "
                "list list->string list->vector list-ref list-tail list? load "
                "log magnitude make-polar make-rectangular make-string "
                "make-vector map max member memq memv min modulo negative? "
                "newline not null-environment null? number->string number? "
                "numerator odd? open-input-file open-output-file or "
                "output-port? pair? peek-char positive? procedure? quasiquote "
                "quote quotient rational? rationalize read read-char "
                "real-part real? remainder reverse round "
                "scheme-report-environment set! set-car! set-cdr! sin sqrt "
                "string string->list string->number string->symbol "
                "string-append string-ci<=? string-ci<? string-ci=? "
                "string-ci>=? string-ci>? string-copy string-fill! "
                "string-length string-ref string-set! string<=? string<? "
                "string=? string>=? string>? string? substring symbol->string "
                "symbol? syntax-rules transcript-off transcript-on truncate "
                "unquote unquote-splicing values vector vector->list "
                "vector-fill! vector-length vector-ref vector-set! vector? "
                "with-input-from-file with-output-to-file write write-char "
                "zero?" )

# Lisp Keywords
LISP_KEYWORDS = (1, ":abort :adjustable :append :array :base :case :circle "
                    ":conc-name :constructor :copier :count :create :default "
                    ":device :directory :displaced-index-offset :displaced-to "
                    ":element-type :end :end1 :end2 :error :escape :external "
                    ":from-end :gensym :host :include :if-does-not-exist "
                    ":if-exists :index :inherited :internal :initial-contents "
                    ":initial-element :initial-offset :initial-value :input "
                    ":io :junk-allowed :key :length :level :name :named "
                    ":new-version :nicknames :output :ouput=file :overwrite "
                    ":predicate :preserve-whitespace :pretty :print "
                    ":print-function :probe :radix :read-only :rehash-size "
                    ":rehash-threshold :rename :size :rename-and-delete :start "
                    ":start1 :start2 :stream :supersede :test :test-not :use "
                    ":verbose :version")

NEWLISP_FUNC = (0, "! != % & * + - / : < << <= = > >= >> ? @ NaN? abort abs "
                   "acos acosh add address " "amb and append append-file apply "
                   "args array array-list array? asin asinh assoc assoc-set "
                   "atan atan2 atanh atom? base64-dec base64-enc bayes-query "
                   "bayes-train begin beta betai bind binomial callback case "
                   "catch ceil change-dir char chop clean close command-event "
                   "cond cons constant context context? copy-file cos cosh "
                   "count cpymem crc32 crit-chi2 crit-z current-line curry "
                   "date date-value debug dec def-new default define "
                   "define-macro delete delete-file delete-url destroy det "
                   "device difference directory directory? div do-until "
                   "do-while doargs dolist dostring dotimes dotree dump dup "
                   "empty? encrypt ends-with env erf error-event error-number "
                   "error-text eval eval-string exec exists exit exp expand "
                   "explode factor fft file-info file? filter find find-all "
                   "first flat " "float float? floor flt for for-all fork "
                   "format fv gammai gammaln gcd get-char get-float get-int "
                   "get-long get-string get-url global global? if if-not ifft "
                   "import inc index int integer integer? intersect invert irr "
                   "join lambda? last legal? length let letex letn list list? "
                   "load local log lookup lower-case macro? main-args make-dir "
                   "map mat match max member min mod mul multiply name "
                   "net-accept net-close net-connect net-error net-eval "
                   "net-listen net-local net-lookup net-peek net-peer net-ping"
                   "-receive " "net-receive-from net-receive-udp net-select "
                   "net-send net-send-to net-send-udp net-service net-sessions "
                   "new nil nil? normal not now nper npv nth nth-set null? "
                   "number? open or ostype pack parse parse-date peek pipe pmt "
                   "pop pop-assoc post-url pow pretty-print primitive? print "
                   "println prob-chi2 prob-z process prompt-event protected? "
                   "push put-url pv quote quote? rand random randomize "
                   "read-buffer read-char read-expr read-file read-key "
                   "read-line real-path ref ref-all ref-set regex regex-comp "
                   "remove-dir rename-file replace reset rest reverse rotate "
                   "round save search seed seek select semaphore sequence "
                   "series set set-assoc set-locale set-nth set-ref "
                   "set-ref-all setq sgn share signal silent sin sinh sleep "
                   "slice sort source spawn sqrt starts-with string string? "
                   "sub swap sym symbol? symbols sync sys-error sys-info tan "
                   "tanh throw throw-error time time-of-day timer title-case "
                   "trace trace-highlight transpose trim true true? unicode "
                   "unify unique unless unpack until upper-case utf8 utf8len "
                   "uuid wait-pid when while write-buffer write-char "
                   "write-file write-line xml-error xml-parse xml-type-tags "
                   "zero? | ~ lambda")
 
# Lisp Keywords
NEWLISP_KEYWORDS = (1, "$ $0 $1 $10 $11 $12 $13 $14 $15 $2 $3 $4 $5 $6 $7 $8 "
                       "$9 $args $idx $main-args MAIN :")

#---- Syntax Style Specs ----#
SYNTAX_ITEMS = [ (stc.STC_LISP_DEFAULT, 'default_style'),
                 (stc.STC_LISP_COMMENT, 'comment_style'),
                 (stc.STC_LISP_MULTI_COMMENT, 'comment_style'),
                 (stc.STC_LISP_IDENTIFIER, 'default_style'),
                 (stc.STC_LISP_KEYWORD, 'keyword_style'),
                 (stc.STC_LISP_KEYWORD_KW, 'keyword2_style'),
                 (stc.STC_LISP_NUMBER, 'number_style'),
                 (stc.STC_LISP_OPERATOR, 'operator_style'),
                 (stc.STC_LISP_SPECIAL, 'operator_style'),
                 (stc.STC_LISP_STRING, 'string_style'),
                 (stc.STC_LISP_STRINGEOL, 'stringeol_style'),
                 (stc.STC_LISP_SYMBOL, 'scalar_style') ]

#---- Extra Properties ----#
FOLD = ('fold', '1')

#-----------------------------------------------------------------------------#

class SyntaxData(syndata.SyntaxDataBase):
    """SyntaxData object for List/newLisp/Scheme""" 
    def __init__(self, langid):
        super(SyntaxData, self).__init__(langid)

        # Setup
        self.SetLexer(stc.STC_LEX_LISP)

    def GetKeywords(self):
        """Returns Specified Keywords List """
        if self.LangId == synglob.ID_LANG_LISP:
            return [LISP_FUNC, LISP_KEYWORDS]
        elif self.LangId == synglob.ID_LANG_SCHEME:
            return [SCHEME_KW]
        elif self.LangId == synglob.ID_LANG_NEWLISP:
            return [NEWLISP_FUNC, NEWLISP_KEYWORDS]
        else:
            return list()

    def GetSyntaxSpec(self):
        """Syntax Specifications """
        return SYNTAX_ITEMS

    def GetProperties(self):
        """Returns a list of Extra Properties to set """
        return [FOLD]

    def GetCommentPattern(self):
        """Returns a list of characters used to comment a block of code """
        return [u';']