*.fasl
*.fas
*.lib
+\#*
jscl.js
tests.js
--- /dev/null
+#+SEQ_TODO: TODO DOING | DONE
+
+Current JSCL implementation status, taking Common Lisp Hyper Spec Dictionaries
+as a base. DONE status will be achieved whenever a feature is fully
+implemented and tested.
+
+* Implementation status [4/678][0%]
+ :PROPERTIES:
+ :COOKIE_DATA: todo recursive
+ :END:
+** [0/21][0%] Evaluation and Compilation
+*** TODO Function COMPILE
+*** TODO Special Operator EVAL-WHEN
+*** TODO Special Operator LOAD-TIME-VALUE
+*** TODO Accessor COMPILER-MACRO-FUNCTION
+*** TODO Macro DEFINE-COMPILER-MACRO
+*** TODO Accessor MACRO-FUNCTION
+*** TODO Function MACROEXPAND, MACROEXPAND-1
+*** TODO Special Operator SYMBOL-MACROLET
+*** TODO Variable *MACROEXPAND-HOOK*
+*** TODO Declaration IGNORE, IGNORABLE
+*** TODO Declaration DYNAMIC-EXTENT
+*** TODO Declaration TYPE
+*** TODO Declaration INLINE, NOTINLINE
+*** TODO Declaration FTYPE
+*** TODO Declaration DECLARATION
+*** TODO Declaration OPTIMIZE
+*** TODO Declaration SPECIAL
+*** TODO Special Operator LOCALLY
+*** TODO Special Operator THE
+*** TODO Function SPECIAL-OPERATOR-P
+*** TODO Function CONSTANTP
+** [0/31][0%] Types and Classes
+*** TODO Type NIL
+*** TODO Type BOOLEAN
+*** TODO System Class FUNCTION
+*** TODO Type COMPILED-FUNCTION
+*** TODO System Class GENERIC-FUNCTION
+*** TODO System Class STANDARD-GENERIC-FUNCTION
+*** TODO System Class CLASS
+*** TODO System Class BUILT-IN-CLASS
+*** TODO System Class STRUCTURE-CLASS
+*** TODO System Class STANDARD-CLASS
+*** TODO System Class METHOD
+*** TODO System Class STANDARD-METHOD
+*** TODO Class STRUCTURE-OBJECT
+*** TODO Class STANDARD-OBJECT
+*** TODO System Class METHOD-COMBINATION
+*** TODO System Class T
+*** TODO Type Specifier SATISFIES
+*** TODO Type Specifier MEMBER
+*** TODO Type Specifier NOT
+*** TODO Type Specifier AND
+*** TODO Type Specifier OR
+*** TODO Type Specifier VALUES
+*** TODO Type Specifier EQL
+*** TODO Function COERCE
+*** TODO Macro DEFTYPE
+*** TODO Function SUBTYPEP
+*** TODO Function TYPE-OF
+*** TODO Function TYPEP
+*** TODO Condition Type TYPE-ERROR
+*** TODO Function TYPE-ERROR-DATUM, TYPE-ERROR-EXPECTED-TYPE
+*** TODO Condition Type SIMPLE-TYPE-ERROR
+** [0/69][0%] Data and Control Flow
+*** TODO Function APPLY
+*** TODO Macro DEFUN
+*** TODO Accessor FDEFINITION
+*** TODO Function FBOUNDP
+*** TODO Function FMAKUNBOUND
+*** TODO Special Operator FLET, LABELS, MACROLET
+*** TODO Function FUNCALL
+*** TODO Special Operator FUNCTION
+*** TODO Function FUNCTION-LAMBDA-EXPRESSION
+*** TODO Function FUNCTIONP
+*** TODO Function COMPILED-FUNCTION-P
+*** TODO Constant Variable CALL-ARGUMENTS-LIMIT
+*** TODO Constant Variable LAMBDA-LIST-KEYWORDS
+*** TODO Constant Variable LAMBDA-PARAMETERS-LIMIT
+*** TODO Macro DEFCONSTANT
+*** TODO Macro DEFPARAMETER, DEFVAR
+*** TODO Macro DESTRUCTURING-BIND
+*** TODO Special Operator LET, LET*
+*** TODO Special Operator PROGV
+*** TODO Special Form SETQ
+*** TODO Macro PSETQ
+*** TODO Special Operator BLOCK
+*** TODO Special Operator CATCH
+*** TODO Special Operator GO
+*** TODO Special Operator RETURN-FROM
+*** TODO Macro RETURN
+*** TODO Special Operator TAGBODY
+*** TODO Special Operator THROW
+*** TODO Special Operator UNWIND-PROTECT
+*** TODO Constant Variable NIL
+*** TODO Function NOT
+*** TODO Constant Variable T
+*** TODO Function EQ
+*** TODO Function EQL
+*** TODO Function EQUAL
+*** TODO Function EQUALP
+*** TODO Function IDENTITY
+*** TODO Function COMPLEMENT
+*** TODO Function CONSTANTLY
+*** TODO Function EVERY, SOME, NOTEVERY, NOTANY
+*** TODO Macro AND
+*** TODO Macro COND
+*** TODO Special Operator IF
+*** TODO Macro OR
+*** TODO Macro WHEN, UNLESS
+*** TODO Macro CASE, CCASE, ECASE
+*** TODO Macro TYPECASE, CTYPECASE, ETYPECASE
+*** TODO Macro MULTIPLE-VALUE-BIND
+*** TODO Special Operator MULTIPLE-VALUE-CALL
+*** TODO Macro MULTIPLE-VALUE-LIST
+*** TODO Special Operator MULTIPLE-VALUE-PROG1
+*** TODO Macro MULTIPLE-VALUE-SETQ
+*** TODO Accessor VALUES
+*** TODO Function VALUES-LIST
+*** TODO Constant Variable MULTIPLE-VALUES-LIMIT
+*** TODO Macro NTH-VALUE
+*** TODO Macro PROG, PROG*
+*** TODO Macro PROG1, PROG2
+*** TODO Special Operator PROGN
+*** TODO Macro DEFINE-MODIFY-MACRO
+*** TODO Macro DEFSETF
+*** TODO Macro DEFINE-SETF-EXPANDER
+*** TODO Function GET-SETF-EXPANSION
+*** TODO Macro SETF, PSETF
+*** TODO Macro SHIFTF
+*** TODO Macro ROTATEF
+*** TODO Condition Type CONTROL-ERROR
+*** TODO Condition Type PROGRAM-ERROR
+*** TODO Condition Type UNDEFINED-FUNCTION
+** [0/5][0%] Iteration
+*** TODO Macro DO, DO*
+*** TODO Macro DOTIMES
+*** TODO Macro DOLIST
+*** TODO Macro LOOP
+*** TODO Local Macro LOOP-FINISH
+** [0/41][0%] Objects
+*** TODO Standard Generic Function FUNCTION-KEYWORDS
+*** TODO Function ENSURE-GENERIC-FUNCTION
+*** TODO Standard Generic Function ALLOCATE-INSTANCE
+*** TODO Standard Generic Function REINITIALIZE-INSTANCE
+*** TODO Standard Generic Function SHARED-INITIALIZE
+*** TODO Standard Generic Function UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
+*** TODO Standard Generic Function UPDATE-INSTANCE-FOR-REDEFINED-CLASS
+*** TODO Standard Generic Function CHANGE-CLASS
+*** TODO Function SLOT-BOUNDP
+*** TODO Function SLOT-EXISTS-P
+*** TODO Function SLOT-MAKUNBOUND
+*** TODO Standard Generic Function SLOT-MISSING
+*** TODO Standard Generic Function SLOT-UNBOUND
+*** TODO Function SLOT-VALUE
+*** TODO Standard Generic Function METHOD-QUALIFIERS
+*** TODO Standard Generic Function NO-APPLICABLE-METHOD
+*** TODO Standard Generic Function NO-NEXT-METHOD
+*** TODO Standard Generic Function REMOVE-METHOD
+*** TODO Standard Generic Function MAKE-INSTANCE
+*** TODO Standard Generic Function MAKE-INSTANCES-OBSOLETE
+*** TODO Standard Generic Function MAKE-LOAD-FORM
+*** TODO Function MAKE-LOAD-FORM-SAVING-SLOTS
+*** TODO Macro WITH-ACCESSORS
+*** TODO Macro WITH-SLOTS
+*** TODO Macro DEFCLASS
+*** TODO Macro DEFGENERIC
+*** TODO Macro DEFMETHOD
+*** TODO Accessor FIND-CLASS
+*** TODO Local Function NEXT-METHOD-P
+*** TODO Local Macro CALL-METHOD, MAKE-METHOD
+*** TODO Local Function CALL-NEXT-METHOD
+*** TODO Standard Generic Function COMPUTE-APPLICABLE-METHODS
+*** TODO Macro DEFINE-METHOD-COMBINATION
+*** TODO Standard Generic Function FIND-METHOD
+*** TODO Standard Generic Function ADD-METHOD
+*** TODO Standard Generic Function INITIALIZE-INSTANCE
+*** TODO Standard Generic Function CLASS-NAME
+*** TODO Standard Generic Function (SETF CLASS-NAME)
+*** TODO Function CLASS-OF
+*** TODO Condition Type UNBOUND-SLOT
+*** TODO Function UNBOUND-SLOT-INSTANCE
+** [0/2][0%] Structures
+*** TODO Macro DEFSTRUCT
+*** TODO Function COPY-STRUCTURE
+** [0/46][0%] Conditions
+*** TODO Condition Type CONDITION
+*** TODO Condition Type WARNING
+*** TODO Condition Type STYLE-WARNING
+*** TODO Condition Type SERIOUS-CONDITION
+*** TODO Condition Type ERROR
+*** TODO Condition Type CELL-ERROR
+*** TODO Function CELL-ERROR-NAME
+*** TODO Condition Type PARSE-ERROR
+*** TODO Condition Type STORAGE-CONDITION
+*** TODO Macro ASSERT
+*** TODO Function ERROR
+*** TODO Function CERROR
+*** TODO Macro CHECK-TYPE
+*** TODO Condition Type SIMPLE-ERROR
+*** TODO Function INVALID-METHOD-ERROR
+*** TODO Function METHOD-COMBINATION-ERROR
+*** TODO Function SIGNAL
+*** TODO Condition Type SIMPLE-CONDITION
+*** TODO Function SIMPLE-CONDITION-FORMAT-CONTROL, SIMPLE-CONDITION-FORMAT-ARGUMENTS
+*** TODO Function WARN
+*** TODO Condition Type SIMPLE-WARNING
+*** TODO Function INVOKE-DEBUGGER
+*** TODO Function BREAK
+*** TODO Variable *DEBUGGER-HOOK*
+*** TODO Variable *BREAK-ON-SIGNALS*
+*** TODO Macro HANDLER-BIND
+*** TODO Macro HANDLER-CASE
+*** TODO Macro IGNORE-ERRORS
+*** TODO Macro DEFINE-CONDITION
+*** TODO Function MAKE-CONDITION
+*** TODO System Class RESTART
+*** TODO Function COMPUTE-RESTARTS
+*** TODO Function FIND-RESTART
+*** TODO Function INVOKE-RESTART
+*** TODO Function INVOKE-RESTART-INTERACTIVELY
+*** TODO Macro RESTART-BIND
+*** TODO Macro RESTART-CASE
+*** TODO Function RESTART-NAME
+*** TODO Macro WITH-CONDITION-RESTARTS
+*** TODO Macro WITH-SIMPLE-RESTART
+*** TODO Restart ABORT
+*** TODO Restart CONTINUE
+*** TODO Restart MUFFLE-WARNING
+*** TODO Restart STORE-VALUE
+*** TODO Restart USE-VALUE
+*** TODO Function ABORT, CONTINUE, MUFFLE-WARNING, STORE-VALUE, USE-VALUE
+** [0/20][0%] Symbols
+*** TODO System Class SYMBOL
+*** TODO Type KEYWORD
+*** TODO Function SYMBOLP
+*** TODO Function KEYWORDP
+*** TODO Function MAKE-SYMBOL
+*** TODO Function COPY-SYMBOL
+*** TODO Function GENSYM
+*** TODO Variable *GENSYM-COUNTER*
+*** TODO Function GENTEMP
+*** TODO Accessor SYMBOL-FUNCTION
+*** TODO Function SYMBOL-NAME
+*** TODO Function SYMBOL-PACKAGE
+*** TODO Accessor SYMBOL-PLIST
+*** TODO Accessor SYMBOL-VALUE
+*** TODO Accessor GET
+*** TODO Function REMPROP
+*** TODO Function BOUNDP
+*** TODO Function MAKUNBOUND
+*** TODO Function SET
+*** TODO Condition Type UNBOUND-VARIABLE
+** [0/30][0%] Packages
+*** TODO System Class PACKAGE
+*** TODO Function EXPORT
+*** TODO Function FIND-SYMBOL
+*** TODO Function FIND-PACKAGE
+*** TODO Function FIND-ALL-SYMBOLS
+*** TODO Function IMPORT
+*** TODO Function LIST-ALL-PACKAGES
+*** TODO Function RENAME-PACKAGE
+*** TODO Function SHADOW
+*** TODO Function SHADOWING-IMPORT
+*** TODO Function DELETE-PACKAGE
+*** TODO Function MAKE-PACKAGE
+*** TODO Macro WITH-PACKAGE-ITERATOR
+*** TODO Function UNEXPORT
+*** TODO Function UNINTERN
+*** TODO Macro IN-PACKAGE
+*** TODO Function UNUSE-PACKAGE
+*** TODO Function USE-PACKAGE
+*** TODO Macro DEFPACKAGE
+*** TODO Macro DO-SYMBOLS, DO-EXTERNAL-SYMBOLS, DO-ALL-SYMBOLS
+*** TODO Function INTERN
+*** TODO Function PACKAGE-NAME
+*** TODO Function PACKAGE-NICKNAMES
+*** TODO Function PACKAGE-SHADOWING-SYMBOLS
+*** TODO Function PACKAGE-USE-LIST
+*** TODO Function PACKAGE-USED-BY-LIST
+*** TODO Function PACKAGEP
+*** TODO Variable *PACKAGE*
+*** TODO Condition Type PACKAGE-ERROR
+*** TODO Function PACKAGE-ERROR-PACKAGE
+** [0/84][0%] Numbers
+*** TODO System Class NUMBER
+*** TODO System Class COMPLEX
+*** TODO System Class REAL
+*** TODO System Class FLOAT
+*** TODO Type SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, LONG-FLOAT
+*** TODO System Class RATIONAL
+*** TODO System Class RATIO
+*** TODO System Class INTEGER
+*** TODO Type SIGNED-BYTE
+*** TODO Type UNSIGNED-BYTE
+*** TODO Type Specifier MOD
+*** TODO Type BIT
+*** TODO Type FIXNUM
+*** TODO Type BIGNUM
+*** TODO Function =, /=, <, >, <=, >=
+*** TODO Function MAX, MIN
+*** TODO Function MINUSP, PLUSP
+*** TODO Function ZEROP
+*** TODO Function FLOOR, FFLOOR, CEILING, FCEILING, TRUNCATE, FTRUNCATE, ROUND, FROUND
+*** TODO Function SIN, COS, TAN
+*** TODO Function ASIN, ACOS, ATAN
+*** TODO Constant Variable PI
+*** TODO Function SINH, COSH, TANH, ASINH, ACOSH, ATANH
+*** TODO Function *
+*** TODO Function +
+*** TODO Function -
+*** TODO Function /
+*** TODO Function 1+, 1-
+*** TODO Function ABS
+*** TODO Function EVENP, ODDP
+*** TODO Function EXP, EXPT
+*** TODO Function GCD
+*** TODO Macro INCF, DECF
+*** TODO Function LCM
+*** TODO Function LOG
+*** TODO Function MOD, REM
+*** TODO Function SIGNUM
+*** TODO Function SQRT, ISQRT
+*** TODO System Class RANDOM-STATE
+*** TODO Function MAKE-RANDOM-STATE
+*** TODO Function RANDOM
+*** TODO Function RANDOM-STATE-P
+*** TODO Variable *RANDOM-STATE*
+*** TODO Function NUMBERP
+*** TODO Function CIS
+*** TODO Function COMPLEX
+*** TODO Function COMPLEXP
+*** TODO Function CONJUGATE
+*** TODO Function PHASE
+*** TODO Function REALPART, IMAGPART
+*** TODO Function UPGRADED-COMPLEX-PART-TYPE
+*** TODO Function REALP
+*** TODO Function NUMERATOR, DENOMINATOR
+*** TODO Function RATIONAL, RATIONALIZE
+*** TODO Function RATIONALP
+*** TODO Function ASH
+*** TODO Function INTEGER-LENGTH
+*** TODO Function INTEGERP
+*** TODO Function PARSE-INTEGER
+*** TODO Function BOOLE
+*** TODO Constant Variable 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
+*** TODO Function LOGAND, LOGANDC1, LOGANDC2, LOGEQV, LOGIOR, LOGNAND, LOGNOR, LOGNOT, LOGORC1, LOGORC2, LOGXOR
+*** TODO Function LOGBITP
+*** TODO Function LOGCOUNT
+*** TODO Function LOGTEST
+*** TODO Function BYTE, BYTE-SIZE, BYTE-POSITION
+*** TODO Function DEPOSIT-FIELD
+*** TODO Function DPB
+*** TODO Accessor LDB
+*** TODO Function LDB-TEST
+*** TODO Accessor MASK-FIELD
+*** TODO Constant Variable MOST-POSITIVE-FIXNUM, MOST-NEGATIVE-FIXNUM
+*** TODO Function DECODE-FLOAT, SCALE-FLOAT, FLOAT-RADIX, FLOAT-SIGN, FLOAT-DIGITS, FLOAT-PRECISION, INTEGER-DECODE-FLOAT
+*** TODO Function FLOAT
+*** TODO Function FLOATP
+*** TODO Constant Variable MOST-POSITIVE-SHORT-FLOAT, LEAST-POSITIVE-SHORT-FLOAT, LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT, MOST-POSITIVE-DOUBLE-FLOAT, LEAST-POSITIVE-DOUBLE-FLOAT, LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT, MOST-POSITIVE-LONG-FLOAT, LEAST-POSITIVE-LONG-FLOAT, LEAST-POSITIVE-NORMALIZED-LONG-FLOAT, MOST-POSITIVE-SINGLE-FLOAT, LEAST-POSITIVE-SINGLE-FLOAT, LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT, MOST-NEGATIVE-SHORT-FLOAT, LEAST-NEGATIVE-SHORT-FLOAT, LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT, MOST-NEGATIVE-SINGLE-FLOAT, LEAST-NEGATIVE-SINGLE-FLOAT, LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT, MOST-NEGATIVE-DOUBLE-FLOAT, LEAST-NEGATIVE-DOUBLE-FLOAT, LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT, MOST-NEGATIVE-LONG-FLOAT, LEAST-NEGATIVE-LONG-FLOAT, LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT
+*** TODO Constant Variable SHORT-FLOAT-EPSILON, SHORT-FLOAT-NEGATIVE-EPSILON, SINGLE-FLOAT-EPSILON, SINGLE-FLOAT-NEGATIVE-EPSILON, DOUBLE-FLOAT-EPSILON, DOUBLE-FLOAT-NEGATIVE-EPSILON, LONG-FLOAT-EPSILON, LONG-FLOAT-NEGATIVE-EPSILON
+*** TODO Condition Type ARITHMETIC-ERROR
+*** TODO Function ARITHMETIC-ERROR-OPERANDS, ARITHMETIC-ERROR-OPERATION
+*** TODO Condition Type DIVISION-BY-ZERO
+*** TODO Condition Type FLOATING-POINT-INVALID-OPERATION
+*** TODO Condition Type FLOATING-POINT-INEXACT
+*** TODO Condition Type FLOATING-POINT-OVERFLOW
+*** TODO Condition Type FLOATING-POINT-UNDERFLOW
+** [0/21][0%] Characters
+*** TODO System Class CHARACTER
+*** TODO Type BASE-CHAR
+*** TODO Type STANDARD-CHAR
+*** TODO Type EXTENDED-CHAR
+*** TODO Function CHAR=, CHAR/=, CHAR<, CHAR>, CHAR<=, CHAR>=, CHAR-EQUAL, CHAR-NOT-EQUAL, CHAR-LESSP, CHAR-GREATERP, CHAR-NOT-GREATERP, CHAR-NOT-LESSP
+*** TODO Function CHARACTER
+*** TODO Function CHARACTERP
+*** TODO Function ALPHA-CHAR-P
+*** TODO Function ALPHANUMERICP
+*** TODO Function DIGIT-CHAR
+*** TODO Function DIGIT-CHAR-P
+*** TODO Function GRAPHIC-CHAR-P
+*** TODO Function STANDARD-CHAR-P
+*** TODO Function CHAR-UPCASE, CHAR-DOWNCASE
+*** TODO Function UPPER-CASE-P, LOWER-CASE-P, BOTH-CASE-P
+*** TODO Function CHAR-CODE
+*** TODO Function CHAR-INT
+*** TODO Function CODE-CHAR
+*** TODO Constant Variable CHAR-CODE-LIMIT
+*** TODO Function CHAR-NAME
+*** TODO Function NAME-CHAR
+** [4/49][8%] Conses
+*** TODO System Class LIST
+*** TODO System Class NULL
+*** TODO System Class CONS
+*** TODO Type ATOM
+*** DONE Function CONS
+*** DONE Function CONSP
+*** DONE Function ATOM
+*** DONE Function RPLACA, RPLACD
+*** DOING Accessor CAR, CDR, CAAR, CADR, CDAR, CDDR, CAAAR, CAADR, CADAR, CADDR, CDAAR, CDADR, CDDAR, CDDDR, CAAAAR, CAAADR, CAADAR, CAADDR, CADAAR, CADADR, CADDAR, CADDDR, CDAAAR, CDAADR, CDADAR, CDADDR, CDDAAR, CDDADR, CDDDAR, CDDDDR
+*** TODO Function COPY-TREE
+*** DOING Function SUBLIS, NSUBLIS
+*** DOING Function SUBST, SUBST-IF, SUBST-IF-NOT, NSUBST, NSUBST-IF, NSUBST-IF-NOT
+*** TODO Function TREE-EQUAL
+*** TODO Function COPY-LIST
+*** TODO Function LIST, LIST*
+*** TODO Function LIST-LENGTH
+*** TODO Function LISTP
+*** TODO Function MAKE-LIST
+*** TODO Macro PUSH
+*** TODO Macro POP
+*** DOING Accessor FIRST, SECOND, THIRD, FOURTH, FIFTH, SIXTH, SEVENTH, EIGHTH, NINTH, TENTH
+*** TODO Accessor NTH
+*** TODO Function ENDP
+*** TODO Function NULL
+*** TODO Function NCONC
+*** TODO Function APPEND
+*** TODO Function REVAPPEND, NRECONC
+*** TODO Function BUTLAST, NBUTLAST
+*** TODO Function LAST
+*** TODO Function LDIFF, TAILP
+*** TODO Function NTHCDR
+*** TODO Accessor REST
+*** TODO Function MEMBER, MEMBER-IF, MEMBER-IF-NOT
+*** TODO Function MAPC, MAPCAR, MAPCAN, MAPL, MAPLIST, MAPCON
+*** TODO Function ACONS
+*** TODO Function ASSOC, ASSOC-IF, ASSOC-IF-NOT
+*** TODO Function COPY-ALIST
+*** TODO Function PAIRLIS
+*** TODO Function RASSOC, RASSOC-IF, RASSOC-IF-NOT
+*** TODO Function GET-PROPERTIES
+*** TODO Accessor GETF
+*** TODO Macro REMF
+*** TODO Function INTERSECTION, NINTERSECTION
+*** TODO Function ADJOIN
+*** TODO Macro PUSHNEW
+*** TODO Function SET-DIFFERENCE, NSET-DIFFERENCE
+*** TODO Function SET-EXCLUSIVE-OR, NSET-EXCLUSIVE-OR
+*** TODO Function SUBSETP
+*** TODO Function UNION, NUNION
+** [0/36][0%] Arrays
+*** TODO System Class ARRAY
+*** TODO Type SIMPLE-ARRAY
+*** TODO System Class VECTOR
+*** TODO Type SIMPLE-VECTOR
+*** TODO System Class BIT-VECTOR
+*** TODO Type SIMPLE-BIT-VECTOR
+*** TODO Function MAKE-ARRAY
+*** TODO Function ADJUST-ARRAY
+*** TODO Function ADJUSTABLE-ARRAY-P
+*** TODO Accessor AREF
+*** TODO Function ARRAY-DIMENSION
+*** TODO Function ARRAY-DIMENSIONS
+*** TODO Function ARRAY-ELEMENT-TYPE
+*** TODO Function ARRAY-HAS-FILL-POINTER-P
+*** TODO Function ARRAY-DISPLACEMENT
+*** TODO Function ARRAY-IN-BOUNDS-P
+*** TODO Function ARRAY-RANK
+*** TODO Function ARRAY-ROW-MAJOR-INDEX
+*** TODO Function ARRAY-TOTAL-SIZE
+*** TODO Function ARRAYP
+*** TODO Accessor FILL-POINTER
+*** TODO Accessor ROW-MAJOR-AREF
+*** TODO Function UPGRADED-ARRAY-ELEMENT-TYPE
+*** TODO Constant Variable ARRAY-DIMENSION-LIMIT
+*** TODO Constant Variable ARRAY-RANK-LIMIT
+*** TODO Constant Variable ARRAY-TOTAL-SIZE-LIMIT
+*** TODO Function SIMPLE-VECTOR-P
+*** TODO Accessor SVREF
+*** TODO Function VECTOR
+*** TODO Function VECTOR-POP
+*** TODO Function VECTOR-PUSH, VECTOR-PUSH-EXTEND
+*** TODO Function VECTORP
+*** TODO Accessor BIT, SBIT
+*** TODO Function BIT-AND, BIT-ANDC1, BIT-ANDC2, BIT-EQV, BIT-IOR, BIT-NAND, BIT-NOR, BIT-NOT, BIT-ORC1, BIT-ORC2, BIT-XOR
+*** TODO Function BIT-VECTOR-P
+*** TODO FunctionSIMPLE-BIT-VECTOR-P
+** [0/12][0%] Strings
+*** TODO System Class STRING
+*** TODO Type BASE-STRING
+*** TODO Type SIMPLE-STRING
+*** TODO Type SIMPLE-BASE-STRING
+*** TODO Function SIMPLE-STRING-P
+*** TODO Accessor CHAR, SCHAR
+*** TODO Function STRING
+*** TODO Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE
+*** TODO Function STRING-TRIM, STRING-LEFT-TRIM, STRING-RIGHT-TRIM
+*** TODO Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP
+*** TODO Function STRINGP
+*** TODO Function MAKE-STRING
+** [0/23][0%] Sequences
+*** TODO System Class SEQUENCE
+*** TODO Function COPY-SEQ
+*** TODO Accessor ELT
+*** TODO Function FILL
+*** TODO Function MAKE-SEQUENCE
+*** TODO Accessor SUBSEQ
+*** TODO Function MAP
+*** TODO Function MAP-INTO
+*** TODO Function REDUCE
+*** TODO Function COUNT, COUNT-IF, COUNT-IF-NOT
+*** TODO Function LENGTH
+*** TODO Function REVERSE, NREVERSE
+*** TODO Function SORT, STABLE-SORT
+*** TODO Function FIND, FIND-IF, FIND-IF-NOT
+*** TODO Function POSITION, POSITION-IF, POSITION-IF-NOT
+*** TODO Function SEARCH
+*** TODO Function MISMATCH
+*** TODO Function REPLACE
+*** TODO Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
+*** TODO Function CONCATENATE
+*** TODO Function MERGE
+*** TODO Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF, DELETE-IF-NOT
+*** TODO Function REMOVE-DUPLICATES, DELETE-DUPLICATES
+** [0/14][0%] Hash Tables
+*** TODO System Class HASH-TABLE
+*** TODO Function MAKE-HASH-TABLE
+*** TODO Function HASH-TABLE-P
+*** TODO Function HASH-TABLE-COUNT
+*** TODO Function HASH-TABLE-REHASH-SIZE
+*** TODO Function HASH-TABLE-REHASH-THRESHOLD
+*** TODO Function HASH-TABLE-SIZE
+*** TODO Function HASH-TABLE-TEST
+*** TODO Accessor GETHASH
+*** TODO Function REMHASH
+*** TODO Function MAPHASH
+*** TODO Macro WITH-HASH-TABLE-ITERATOR
+*** TODO Function CLRHASH
+*** TODO Function SXHASH
+** [0/17][0%] Filenames
+*** TODO System Class PATHNAME
+*** TODO System Class LOGICAL-PATHNAME
+*** TODO Function PATHNAME
+*** TODO Function MAKE-PATHNAME
+*** TODO Function PATHNAMEP
+*** TODO Function PATHNAME-HOST, PATHNAME-DEVICE, PATHNAME-DIRECTORY, PATHNAME-NAME, PATHNAME-TYPE, PATHNAME-VERSION
+*** TODO Function LOAD-LOGICAL-PATHNAME-TRANSLATIONS
+*** TODO Accessor LOGICAL-PATHNAME-TRANSLATIONS
+*** TODO Function LOGICAL-PATHNAME
+*** TODO Variable *DEFAULT-PATHNAME-DEFAULTS*
+*** TODO Function NAMESTRING, FILE-NAMESTRING, DIRECTORY-NAMESTRING, HOST-NAMESTRING, ENOUGH-NAMESTRING
+*** TODO Function PARSE-NAMESTRING
+*** TODO Function WILD-PATHNAME-P
+*** TODO Function PATHNAME-MATCH-P
+*** TODO Function TRANSLATE-LOGICAL-PATHNAME
+*** TODO Function TRANSLATE-PATHNAME
+*** TODO Function MERGE-PATHNAMES
+** [0/10][0%] Files
+*** TODO Function DIRECTORY
+*** TODO Function PROBE-FILE
+*** TODO Function ENSURE-DIRECTORIES-EXIST
+*** TODO Function TRUENAME
+*** TODO Function FILE-AUTHOR
+*** TODO Function FILE-WRITE-DATE
+*** TODO Function RENAME-FILE
+*** TODO Function DELETE-FILE
+*** TODO Condition Type FILE-ERROR
+*** TODO Function FILE-ERROR-PATHNAME
+** [0/57][0%] Streams
+*** TODO System Class STREAM
+*** TODO System Class BROADCAST-STREAM
+*** TODO System Class CONCATENATED-STREAM
+*** TODO System Class ECHO-STREAM
+*** TODO System Class FILE-STREAM
+*** TODO System Class STRING-STREAM
+*** TODO System Class SYNONYM-STREAM
+*** TODO System Class TWO-WAY-STREAM
+*** TODO Function INPUT-STREAM-P, OUTPUT-STREAM-P
+*** TODO Function INTERACTIVE-STREAM-P
+*** TODO Function OPEN-STREAM-P
+*** TODO Function STREAM-ELEMENT-TYPE
+*** TODO Function STREAMP
+*** TODO Function READ-BYTE
+*** TODO Function WRITE-BYTE
+*** TODO Function PEEK-CHAR
+*** TODO Function READ-CHAR
+*** TODO Function READ-CHAR-NO-HANG
+*** TODO Function TERPRI, FRESH-LINE
+*** TODO Function UNREAD-CHAR
+*** TODO Function WRITE-CHAR
+*** TODO Function READ-LINE
+*** TODO Function WRITE-STRING, WRITE-LINE
+*** TODO Function READ-SEQUENCE
+*** TODO Function WRITE-SEQUENCE
+*** TODO Function FILE-LENGTH
+*** TODO Function FILE-POSITION
+*** TODO Function FILE-STRING-LENGTH
+*** TODO Function OPEN
+*** TODO Function STREAM-EXTERNAL-FORMAT
+*** TODO macro WITH-OPEN-FILE
+*** TODO Function CLOSE
+*** TODO Macro WITH-OPEN-STREAM
+*** TODO Function LISTEN
+*** TODO Function CLEAR-INPUT
+*** TODO Function FINISH-OUTPUT, FORCE-OUTPUT, CLEAR-OUTPUT
+*** TODO Function Y-OR-N-P, YES-OR-NO-P
+*** TODO Function MAKE-SYNONYM-STREAM
+*** TODO Function SYNONYM-STREAM-SYMBOL
+*** TODO Function BROADCAST-STREAM-STREAMS
+*** TODO Function MAKE-BROADCAST-STREAM
+*** TODO Function MAKE-TWO-WAY-STREAM
+*** TODO Function TWO-WAY-STREAM-INPUT-STREAM, TWO-WAY-STREAM-OUTPUT-STREAM
+*** TODO Function ECHO-STREAM-INPUT-STREAM, ECHO-STREAM-OUTPUT-STREAM
+*** TODO Function MAKE-ECHO-STREAM
+*** TODO Function CONCATENATED-STREAM-STREAMS
+*** TODO Function MAKE-CONCATENATED-STREAM
+*** TODO Function GET-OUTPUT-STREAM-STRING
+*** TODO Function MAKE-STRING-INPUT-STREAM
+*** TODO Function MAKE-STRING-OUTPUT-STREAM
+*** TODO Macro WITH-INPUT-FROM-STRING
+*** TODO Macro WITH-OUTPUT-TO-STRING
+*** TODO Variable *DEBUG-IO*, *ERROR-OUTPUT*, *QUERY-IO*, *STANDARD-INPUT*, *STANDARD-OUTPUT*, *TRACE-OUTPUT*
+*** TODO Variable *TERMINAL-IO*
+*** TODO Condition Type STREAM-ERROR
+*** TODO Function STREAM-ERROR-STREAM
+*** TODO Condition Type END-OF-FILE
+** [0/31][0%] Printer
+*** TODO Function COPY-PPRINT-DISPATCH
+*** TODO Macro FORMATTER
+*** TODO Function PPRINT-DISPATCH
+*** TODO Local Macro PPRINT-EXIT-IF-LIST-EXHAUSTED
+*** TODO Function PPRINT-FILL, PPRINT-LINEAR, PPRINT-TABULAR
+*** TODO Function PPRINT-INDENT
+*** TODO Macro PPRINT-LOGICAL-BLOCK
+*** TODO Function PPRINT-NEWLINE
+*** TODO Local Macro PPRINT-POP
+*** TODO Function PPRINT-TAB
+*** TODO Standard Generic Function PRINT-OBJECT
+*** TODO Macro PRINT-UNREADABLE-OBJECT
+*** TODO Function SET-PPRINT-DISPATCH
+*** TODO Function WRITE, PRIN1, PRINT, PPRINT, PRINC
+*** TODO Function WRITE-TO-STRING, PRIN1-TO-STRING, PRINC-TO-STRING
+*** TODO Variable *PRINT-ARRAY*
+*** TODO Variable *PRINT-BASE*, *PRINT-RADIX*
+*** TODO Variable *PRINT-CASE*
+*** TODO Variable *PRINT-CIRCLE*
+*** TODO Variable *PRINT-ESCAPE*
+*** TODO Variable *PRINT-GENSYM*
+*** TODO Variable *PRINT-LEVEL*, *PRINT-LENGTH*
+*** TODO Variable *PRINT-LINES*
+*** TODO Variable *PRINT-MISER-WIDTH*
+*** TODO Variable *PRINT-PPRINT-DISPATCH*
+*** TODO Variable *PRINT-PRETTY*
+*** TODO Variable *PRINT-READABLY*
+*** TODO Variable *PRINT-RIGHT-MARGIN*
+*** TODO Condition Type PRINT-NOT-READABLE
+*** TODO Function PRINT-NOT-READABLE-OBJECT
+*** TODO Function FORMAT
+** [0/18][0%] Reader
+*** TODO System Class READTABLE
+*** TODO Function COPY-READTABLE
+*** TODO Function MAKE-DISPATCH-MACRO-CHARACTER
+*** TODO Function READ, READ-PRESERVING-WHITESPACE
+*** TODO Function READ-DELIMITED-LIST
+*** TODO Function READ-FROM-STRING
+*** TODO Accessor READTABLE-CASE
+*** TODO Function READTABLEP
+*** TODO Function SET-DISPATCH-MACRO-CHARACTER, GET-DISPATCH-MACRO-CHARACTER
+*** TODO Function SET-MACRO-CHARACTER, GET-MACRO-CHARACTER
+*** TODO Function SET-SYNTAX-FROM-CHAR
+*** TODO Macro WITH-STANDARD-IO-SYNTAX
+*** TODO Variable *READ-BASE*
+*** TODO Variable *READ-DEFAULT-FLOAT-FORMAT*
+*** TODO Variable *READ-EVAL*
+*** TODO Variable *READ-SUPPRESS*
+*** TODO Variable *READTABLE*
+*** TODO Condition Type READER-ERROR
+** [0/11][0%] System Construction
+*** TODO Function COMPILE-FILE
+*** TODO Function COMPILE-FILE-PATHNAME
+*** TODO Function LOAD
+*** TODO Macro WITH-COMPILATION-UNIT
+*** TODO Variable *FEATURES*
+*** TODO Variable *COMPILE-FILE-PATHNAME*, *COMPILE-FILE-TRUENAME*
+*** TODO Variable *LOAD-PATHNAME*, *LOAD-TRUENAME*
+*** TODO Variable *COMPILE-PRINT*, *COMPILE-VERBOSE*
+*** TODO Variable *LOAD-PRINT*, *LOAD-VERBOSE*
+*** TODO Variable *MODULES*
+*** TODO Function PROVIDE, REQUIRE
+** [0/30][0%] Environment
+*** TODO Function DECODE-UNIVERSAL-TIME
+*** TODO function ENCODE-UNIVERSAL-TIME
+*** TODO Function GET-UNIVERSAL-TIME, GET-DECODED-TIME
+*** TODO Function SLEEP
+*** TODO Function APROPOS, APROPOS-LIST
+*** TODO Function DESCRIBE
+*** TODO Standard Generic Function DESCRIBE-OBJECT
+*** TODO Macro TRACE, UNTRACE
+*** TODO Macro STEP
+*** TODO Macro TIME
+*** TODO Constant Variable INTERNAL-TIME-UNITS-PER-SECOND
+*** TODO Function GET-INTERNAL-REAL-TIME
+*** TODO Function GET-INTERNAL-RUN-TIME
+*** TODO Function DISASSEMBLE
+*** TODO Standard Generic Function DOCUMENTATION, (SETF DOCUMENTATION)
+*** TODO Function ROOM
+*** TODO Function ED
+*** TODO Function INSPECT
+*** TODO Function DRIBBLE
+*** TODO Variable -
+*** TODO Variable +, ++, +++
+*** TODO Variable *, **, ***
+*** TODO Variable /, //, ///
+*** TODO Function LISP-IMPLEMENTATION-TYPE, LISP-IMPLEMENTATION-VERSION
+*** TODO Function SHORT-SITE-NAME, LONG-SITE-NAME
+*** TODO Function MACHINE-INSTANCE
+*** TODO Function MACHINE-TYPE
+*** TODO Function MACHINE-VERSION
+*** TODO Function SOFTWARE-TYPE, SOFTWARE-VERSION
+*** TODO Function USER-HOMEDIR-PATHNAME
-David Vazquez <davazp@gmail.com>
+David Vázquez <davazp@gmail.com>
Raimon Grau <rgrau@gmail.com>
Alfredo Beaumont <alfredo.beaumont@gmail.com>
Owen Rodley <Strigoides@gmail.com>
Mihai Bazon <mihai@bazon.net>
Robert Smith <quad@symbo1ics.com>
Slava Barinov <rayslava@gmail.com>
-maxwellhansen <maxwellhansen@hotmail.com>
+Maxwell Hansen <maxwellhansen@hotmail.com>
+Henry Irvine <henryirvine@mac.com>
+Paul Nathan <pnathan@vandals.uidaho.edu>
+Brit Butler <redline6561@gmail.com>
+Samuel Chase <samebchase@gmail.com>
+Olof-Joachim Frahm <olof@macrolet.net>
$(function () {
var jqconsole = $('#console').jqconsole('Welcome to JSCL!\n\n', '');
jqconsole.RegisterMatching('(', ')', 'parents');
-
+ if (localStorage.getItem("jqhist"))
+ jqconsole.SetHistory(JSON.parse(localStorage.getItem("jqhist")));
+
lisp.write = function(str){
jqconsole.Write(xstring(str), 'jqconsole-output', false);
return str;
var vs = lisp.evalInput(input);
// for (var i=0; i<vs.length; i++){
jqconsole.Write(lisp.print(vs) + '\n', 'jqconsole-return');
+ localStorage.setItem("jqhist", JSON.stringify(jqconsole.GetHistory()));
// }
} catch(error) {
var msg = error.message || error || 'Unknown error';
(in-package :jscl)
(defvar *source*
- '(("boot" :target)
- ("compat" :host)
- ("utils" :both)
- ("list" :target)
- ("string" :target)
- ("print" :target)
- ("package" :target)
- ("ffi" :target)
- ("char" :target)
- ("read" :both)
- ("compiler" :both)
- ("toplevel" :target)))
+ '(("boot" :target)
+ ("compat" :host)
+ ("utils" :both)
+ ("list" :target)
+ ("string" :target)
+ ("sequence" :target)
+ ("print" :target)
+ ("package" :target)
+ ("ffi" :target)
+ ("misc" :target)
+ ("numbers" :target)
+ ("char" :target)
+ ("read" :both)
+ ("defstruct" :both)
+ ("lambda-list" :both)
+ ("backquote" :both)
+ ("compiler" :both)
+ ("toplevel" :target)))
(defun source-pathname
(filename &key (directory '(:relative "src")) (type nil) (defaults filename))
(when (plusp (length compilation))
(write-string compilation out)))))))
-
(defun dump-global-environment (stream)
(flet ((late-compile (form)
(write-string (ls-compile-toplevel form) stream)))
;; for the compiler and it can be dumped.
(dolist (b (lexenv-function *environment*))
(when (eq (binding-type b) 'macro)
- (push *magic-unquote-marker* (binding-value b))))
+ (setf (binding-value b) `(,*magic-unquote-marker* ,(binding-value b)))))
(late-compile `(setq *environment* ',*environment*))
;; Set some counter variable properly, so user compiled code will
;; not collide with the compiler itself.
(defun bootstrap ()
- (let ((*package* (find-package "JSCL")))
+ (let ((*features* (cons :jscl *features*))
+ (*package* (find-package "JSCL")))
(setq *environment* (make-lexenv))
(setq *literal-table* nil)
(setq *variable-counter* 0
--- /dev/null
+;;; backquote.lisp ---
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Backquote implementation.
+;;;
+;;; Author: Guy L. Steele Jr. Date: 27 December 1985
+;;; Tested under Symbolics Common Lisp and Lucid Common Lisp.
+;;; This software is in the public domain.
+
+;;; The following are unique tokens used during processing.
+;;; They need not be symbols; they need not even be atoms.
+(defvar *comma* 'unquote)
+(defvar *comma-atsign* 'unquote-splicing)
+
+(defvar *bq-list* (make-symbol "BQ-LIST"))
+(defvar *bq-append* (make-symbol "BQ-APPEND"))
+(defvar *bq-list** (make-symbol "BQ-LIST*"))
+(defvar *bq-nconc* (make-symbol "BQ-NCONC"))
+(defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
+(defvar *bq-quote* (make-symbol "BQ-QUOTE"))
+(defvar *bq-quote-nil* (list *bq-quote* nil))
+
+;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
+;;; the expression foo, looking for occurrences of #:COMMA,
+;;; #:COMMA-ATSIGN, and #:COMMA-DOT. It constructs code in strict
+;;; accordance with the rules on pages 349-350 of the first edition
+;;; (pages 528-529 of this second edition). It then optionally
+;;; applies a code simplifier.
+
+;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
+;;; processing applies the code simplifier. If the value is NIL,
+;;; then the code resulting from BACKQUOTE is exactly that
+;;; specified by the official rules.
+(defparameter *bq-simplify* t)
+
+(defmacro backquote (x)
+ (bq-completely-process x))
+
+;;; Backquote processing proceeds in three stages:
+;;;
+;;; (1) BQ-PROCESS applies the rules to remove occurrences of
+;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
+;;; this level of BACKQUOTE. (It also causes embedded calls to
+;;; BACKQUOTE to be expanded so that nesting is properly handled.)
+;;; Code is produced that is expressed in terms of functions
+;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE. This is done
+;;; so that the simplifier will simplify only list construction
+;;; functions actually generated by BACKQUOTE and will not involve
+;;; any user code in the simplification. #:BQ-LIST means LIST,
+;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
+;;; but indicates places where "%." was used and where NCONC may
+;;; therefore be introduced by the simplifier for efficiency.
+;;;
+;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
+;;; BQ-PROCESS to produce equivalent but faster code. The
+;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
+;;; introduced into the code.
+;;;
+;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
+;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
+;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
+;;; replaced by its argument). #:BQ-LIST* is replaced by either
+;;; LIST* or CONS (the latter is used in the two-argument case,
+;;; purely to make the resulting code a tad more readable).
+
+(defun bq-completely-process (x)
+ (let ((raw-result (bq-process x)))
+ (bq-remove-tokens (if *bq-simplify*
+ (bq-simplify raw-result)
+ raw-result))))
+
+(defun bq-process (x)
+ (cond ((atom x)
+ (list *bq-quote* x))
+ ((eq (car x) 'backquote)
+ (bq-process (bq-completely-process (cadr x))))
+ ((eq (car x) *comma*) (cadr x))
+ ((eq (car x) *comma-atsign*)
+ (error ",@~S after `" (cadr x)))
+ ;; ((eq (car x) *comma-dot*)
+ ;; ;; (error ",.~S after `" (cadr x))
+ ;; (error "ill-formed"))
+ (t (do ((p x (cdr p))
+ (q '() (cons (bracket (car p)) q)))
+ ((atom p)
+ (cons *bq-append*
+ (nreconc q (list (list *bq-quote* p)))))
+ (when (eq (car p) *comma*)
+ (unless (null (cddr p))
+ (error "Malformed ,~S" p))
+ (return (cons *bq-append*
+ (nreconc q (list (cadr p))))))
+ (when (eq (car p) *comma-atsign*)
+ (error "Dotted ,@~S" p))
+ ;; (when (eq (car p) *comma-dot*)
+ ;; ;; (error "Dotted ,.~S" p)
+ ;; (error "Dotted"))
+ ))))
+
+;;; This implements the bracket operator of the formal rules.
+(defun bracket (x)
+ (cond ((atom x)
+ (list *bq-list* (bq-process x)))
+ ((eq (car x) *comma*)
+ (list *bq-list* (cadr x)))
+ ((eq (car x) *comma-atsign*)
+ (cadr x))
+ ;; ((eq (car x) *comma-dot*)
+ ;; (list *bq-clobberable* (cadr x)))
+ (t (list *bq-list* (bq-process x)))))
+
+;;; This auxiliary function is like MAPCAR but has two extra
+;;; purposes: (1) it handles dotted lists; (2) it tries to make
+;;; the result share with the argument x as much as possible.
+(defun maptree (fn x)
+ (if (atom x)
+ (funcall fn x)
+ (let ((a (funcall fn (car x)))
+ (d (maptree fn (cdr x))))
+ (if (and (eql a (car x)) (eql d (cdr x)))
+ x
+ (cons a d)))))
+
+;;; This predicate is true of a form that when read looked
+;;; like %@foo or %.foo.
+(defun bq-splicing-frob (x)
+ (and (consp x)
+ (or (eq (car x) *comma-atsign*)
+ ;; (eq (car x) *comma-dot*)
+ )))
+
+;;; This predicate is true of a form that when read
+;;; looked like %@foo or %.foo or just plain %foo.
+(defun bq-frob (x)
+ (and (consp x)
+ (or (eq (car x) *comma*)
+ (eq (car x) *comma-atsign*)
+ ;; (eq (car x) *comma-dot*)
+ )))
+
+;;; The simplifier essentially looks for calls to #:BQ-APPEND and
+;;; tries to simplify them. The arguments to #:BQ-APPEND are
+;;; processed from right to left, building up a replacement form.
+;;; At each step a number of special cases are handled that,
+;;; loosely speaking, look like this:
+;;;
+;;; (APPEND (LIST a b c) foo) => (LIST* a b c foo)
+;;; provided a, b, c are not splicing frobs
+;;; (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
+;;; provided a, b, c are not splicing frobs
+;;; (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
+;;; (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
+(defun bq-simplify (x)
+ (if (atom x)
+ x
+ (let ((x (if (eq (car x) *bq-quote*)
+ x
+ (maptree #'bq-simplify x))))
+ (if (not (eq (car x) *bq-append*))
+ x
+ (bq-simplify-args x)))))
+
+(defun bq-simplify-args (x)
+ (do ((args (reverse (cdr x)) (cdr args))
+ (result
+ nil
+ (cond ((atom (car args))
+ (bq-attach-append *bq-append* (car args) result))
+ ((and (eq (caar args) *bq-list*)
+ (notany #'bq-splicing-frob (cdar args)))
+ (bq-attach-conses (cdar args) result))
+ ((and (eq (caar args) *bq-list**)
+ (notany #'bq-splicing-frob (cdar args)))
+ (bq-attach-conses
+ (reverse (cdr (reverse (cdar args))))
+ (bq-attach-append *bq-append*
+ (car (last (car args)))
+ result)))
+ ((and (eq (caar args) *bq-quote*)
+ (consp (cadar args))
+ (not (bq-frob (cadar args)))
+ (null (cddar args)))
+ (bq-attach-conses (list (list *bq-quote*
+ (caadar args)))
+ result))
+ ((eq (caar args) *bq-clobberable*)
+ (bq-attach-append *bq-nconc* (cadar args) result))
+ (t (bq-attach-append *bq-append*
+ (car args)
+ result)))))
+ ((null args) result)))
+
+(defun null-or-quoted (x)
+ (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
+
+;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
+;;; or #:BQ-NCONC. This produces a form (op item result) but
+;;; some simplifications are done on the fly:
+;;;
+;;; (op '(a b c) '(d e f g)) => '(a b c d e f g)
+;;; (op item 'nil) => item, provided item is not a splicable frob
+;;; (op item 'nil) => (op item), if item is a splicable frob
+;;; (op item (op a b c)) => (op item a b c)
+(defun bq-attach-append (op item result)
+ (cond ((and (null-or-quoted item) (null-or-quoted result))
+ (list *bq-quote* (append (cadr item) (cadr result))))
+ ((or (null result) (equal result *bq-quote-nil*))
+ (if (bq-splicing-frob item) (list op item) item))
+ ((and (consp result) (eq (car result) op))
+ (list* (car result) item (cdr result)))
+ (t (list op item result))))
+
+;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
+;;; `(LIST* ,@items ,result) but some simplifications are done
+;;; on the fly.
+;;;
+;;; (LIST* 'a 'b 'c 'd) => '(a b c . d)
+;;; (LIST* a b c 'nil) => (LIST a b c)
+;;; (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
+;;; (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
+(defun bq-attach-conses (items result)
+ (cond ((and (every #'null-or-quoted items)
+ (null-or-quoted result))
+ (list *bq-quote*
+ (append (mapcar #'cadr items) (cadr result))))
+ ((or (null result) (equal result *bq-quote-nil*))
+ (cons *bq-list* items))
+ ((and (consp result)
+ (or (eq (car result) *bq-list*)
+ (eq (car result) *bq-list**)))
+ (cons (car result) (append items (cdr result))))
+ (t (cons *bq-list** (append items (list result))))))
+
+;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
+;;; (CONS a b) instead of (LIST* a b), purely for readability.
+(defun bq-remove-tokens (x)
+ (cond ((eq x *bq-list*) 'list)
+ ((eq x *bq-append*) 'append)
+ ((eq x *bq-nconc*) 'nconc)
+ ((eq x *bq-list**) 'list*)
+ ((eq x *bq-quote*) 'quote)
+ ((atom x) x)
+ ((eq (car x) *bq-clobberable*)
+ (bq-remove-tokens (cadr x)))
+ ((and (eq (car x) *bq-list**)
+ (consp (cddr x))
+ (null (cdddr x)))
+ (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
+ (t (maptree #'bq-remove-tokens x))))
;;; to the compiler to be able to run.
(eval-when-compile
- (%compile-defmacro 'defmacro
- '(function
- (lambda (name args &rest body)
- `(eval-when-compile
- (%compile-defmacro ',name
- '(function
- (lambda ,(mapcar #'(lambda (x)
- (if (eq x '&body)
- '&rest
- x))
- args)
- ,@body))))))))
+ (let ((defmacro-macroexpander
+ '#'(lambda (form)
+ (destructuring-bind (name args &body body)
+ form
+ (let ((whole (gensym)))
+ `(eval-when-compile
+ (%compile-defmacro ',name
+ '#'(lambda (,whole)
+ (destructuring-bind ,args ,whole
+ ,@body)))))))))
+ (%compile-defmacro 'defmacro defmacro-macroexpander)))
(defmacro declaim (&rest decls)
`(eval-when-compile
(defmacro unless (condition &body body)
`(if ,condition nil (progn ,@body)))
-(defmacro defvar (name value &optional docstring)
+(defmacro defvar (name &optional (value nil value-p) docstring)
`(progn
(declaim (special ,name))
- (unless (boundp ',name) (setq ,name ,value))
+ ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
',name))
(defun boundp (x)
(boundp x))
-;; Basic functions
-(defun = (x y) (= x y))
-(defun * (x y) (* x y))
-(defun / (x y) (/ x y))
-(defun 1+ (x) (+ x 1))
-(defun 1- (x) (- x 1))
-(defun zerop (x) (= x 0))
-
-(defun truncate (x &optional (y 1))
- (floor (/ x y)))
+(defun fboundp (x)
+ (fboundp x))
+(defun eq (x y) (eq x y))
(defun eql (x y) (eq x y))
(defun not (x) (if x nil t))
;; Basic macros
-
(defmacro incf (place &optional (delta 1))
(multiple-value-bind (dummies vals newval setter getter)
(get-setf-expansion place)
,@(cdr newval))
,setter))))
-(defmacro dolist (iter &body body)
- (let ((var (first iter))
- (g!list (gensym)))
+(defmacro pushnew (x place &rest keys &key key test test-not)
+ (declare (ignore key test test-not))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion place)
+ (let ((g (gensym))
+ (v (gensym)))
+ `(let* ((,g ,x)
+ ,@(mapcar #'list dummies vals)
+ ,@(cdr newval)
+ (,v ,getter))
+ (if (member ,g ,v ,@keys)
+ ,v
+ (let ((,(car newval) (cons ,g ,getter)))
+ ,setter))))))
+
+(defmacro dolist ((var list &optional result) &body body)
+ (let ((g!list (gensym)))
+ (unless (symbolp var) (error "`~S' is not a symbol." var))
`(block nil
- (let ((,g!list ,(second iter))
+ (let ((,g!list ,list)
(,var nil))
(%while ,g!list
(setq ,var (car ,g!list))
(tagbody ,@body)
(setq ,g!list (cdr ,g!list)))
- ,(third iter)))))
+ ,result))))
-(defmacro dotimes (iter &body body)
- (let ((g!to (gensym))
- (var (first iter))
- (to (second iter))
- (result (third iter)))
+(defmacro dotimes ((var count &optional result) &body body)
+ (let ((g!count (gensym)))
+ (unless (symbolp var) (error "`~S' is not a symbol." var))
`(block nil
(let ((,var 0)
- (,g!to ,to))
- (%while (< ,var ,g!to)
+ (,g!count ,count))
+ (%while (< ,var ,g!count)
(tagbody ,@body)
(incf ,var))
,result))))
(defmacro cond (&rest clausules)
- (if (null clausules)
- nil
- (if (eq (caar clausules) t)
- `(progn ,@(cdar clausules))
- (let ((test-symbol (gensym)))
- `(let ((,test-symbol ,(caar clausules)))
- (if ,test-symbol
- ,(if (null (cdar clausules))
- test-symbol
- `(progn ,@(cdar clausules)))
- (cond ,@(cdr clausules))))))))
+ (unless (null clausules)
+ (destructuring-bind (condition &body body)
+ (first clausules)
+ (cond
+ ((eq condition t)
+ `(progn ,@body))
+ ((null body)
+ (let ((test-symbol (gensym)))
+ `(let ((,test-symbol ,condition))
+ (if ,test-symbol
+ ,test-symbol
+ (cond ,@(rest clausules))))))
+ (t
+ `(if ,condition
+ (progn ,@body)
+ (cond ,@(rest clausules))))))))
(defmacro case (form &rest clausules)
(let ((!form (gensym)))
`(let ((,!form ,form))
(cond
,@(mapcar (lambda (clausule)
- (if (or (eq (car clausule) t)
- (eq (car clausule) 'otherwise))
- `(t ,@(cdr clausule))
- `((eql ,!form ',(car clausule))
- ,@(cdr clausule))))
+ (destructuring-bind (keys &body body)
+ clausule
+ (if (or (eq keys 't) (eq keys 'otherwise))
+ `(t nil ,@body)
+ (let ((keys (if (listp keys) keys (list keys))))
+ `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
+ nil ,@body)))))
clausules)))))
(defmacro ecase (form &rest clausules)
(defmacro prog2 (form1 result &body body)
`(prog1 (progn ,form1 ,result) ,@body))
+(defmacro prog (inits &rest body )
+ (multiple-value-bind (forms decls docstring) (parse-body body)
+ `(block nil
+ (let ,inits
+ ,@decls
+ (tagbody ,@forms)))))
;;; Go on growing the Lisp language in Ecmalisp, with more high level
;;; utilities as well as correct versions of other constructions.
-(defun + (&rest args)
- (let ((r 0))
- (dolist (x args r)
- (incf r x))))
-
-(defun - (x &rest others)
- (if (null others)
- (- x)
- (let ((r x))
- (dolist (y others r)
- (decf r y)))))
-
(defun append-two (list1 list2)
(if (null list1)
list2
(defun identity (x) x)
+(defun complement (x)
+ (lambda (&rest args)
+ (not (apply x args))))
+
(defun constantly (x)
(lambda (&rest args)
x))
(defun char= (x y)
(eql x y))
-(defun integerp (x)
- (and (numberp x) (= (floor x) x)))
-
-(defun floatp (x)
- (and (numberp x) (not (integerp x))))
-
-(defun plusp (x) (< 0 x))
-(defun minusp (x) (< x 0))
+(defun char< (x y)
+ (< (char-code x) (char-code y)))
(defun atom (x)
(not (consp x)))
-(defun remove (x list)
- (cond
- ((null list)
- nil)
- ((eql x (car list))
- (remove x (cdr list)))
- (t
- (cons (car list) (remove x (cdr list))))))
-
-(defun remove-if (func list)
- (cond
- ((null list)
- nil)
- ((funcall func (car list))
- (remove-if func (cdr list)))
- (t
- ;;
- (cons (car list) (remove-if func (cdr list))))))
-
-(defun remove-if-not (func list)
- (cond
- ((null list)
- nil)
- ((funcall func (car list))
- (cons (car list) (remove-if-not func (cdr list))))
- (t
- (remove-if-not func (cdr list)))))
-
(defun alpha-char-p (x)
(or (<= (char-code #\a) (char-code x) (char-code #\z))
- (<= (char-code #\Z) (char-code x) (char-code #\Z))))
+ (<= (char-code #\A) (char-code x) (char-code #\Z))))
(defun digit-char-p (x)
(if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
(and (<= 0 weight 9)
(char "0123456789" weight)))
-(defun subseq (seq a &optional b)
- (if b
- (slice seq a b)
- (slice seq a)))
-
-(defmacro do-sequence (iteration &body body)
- (let ((seq (gensym))
- (index (gensym)))
- `(let ((,seq ,(second iteration)))
- (cond
- ;; Strings
- ((stringp ,seq)
- (let ((,index 0))
- (dotimes (,index (length ,seq))
- (let ((,(first iteration)
- (char ,seq ,index)))
- ,@body))))
- ;; Lists
- ((listp ,seq)
- (dolist (,(first iteration) ,seq)
- ,@body))
- (t
- (error "type-error!"))))))
-
-(defun find (item sequence &key (key #'identity) (test #'eql))
- (do-sequence (x sequence)
- (when (funcall test (funcall key x) item)
- (return x))))
-
-(defun find-if (predicate sequence &key (key #'identity))
- (do-sequence (x sequence)
- (when (funcall predicate (funcall key x))
- (return x))))
-
-(defun some (function seq)
- (do-sequence (elt seq)
- (when (funcall function elt)
- (return-from some t))))
-
-(defun every (function seq)
- (do-sequence (elt seq)
- (unless (funcall function elt)
- (return-from every nil)))
- t)
-
-(defun position (elt sequence)
- (let ((pos 0))
- (do-sequence (x seq)
- (when (eq elt x)
- (return))
- (incf pos))
- pos))
-
(defun equal (x y)
(cond
((eql x y) t)
(list nil)))))
clausules)))))
+(defmacro etypecase (x &rest clausules)
+ (let ((g!x (gensym)))
+ `(let ((,g!x ,x))
+ (typecase ,g!x
+ ,@clausules
+ (t (error "~X fell through etypeacase expression." ,g!x))))))
+
(defun notany (fn seq)
(not (some fn seq)))
-
(defconstant internal-time-units-per-second 1000)
(defun get-internal-real-time ()
(defun error (fmt &rest args)
(%throw (apply #'format nil fmt args)))
-
-;;; compiler.lisp ---
+;;; compiler.lisp ---
;; copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
(incf index))
output)))
-#+common-lisp
+#-jscl
(defun indent (&rest string)
(with-output-to-string (*standard-output*)
(with-input-from-string (input (apply #'code string))
;;; function call.
(defvar *multiple-value-p* nil)
-;; A very simple defstruct built on lists. It supports just slot with
-;; an optional default initform, and it will create a constructor,
-;; predicate and accessors for you.
-(defmacro def!struct (name &rest slots)
- (unless (symbolp name)
- (error "It is not a full defstruct implementation."))
- (let* ((name-string (symbol-name name))
- (slot-descriptions
- (mapcar (lambda (sd)
- (cond
- ((symbolp sd)
- (list sd))
- ((and (listp sd) (car sd) (cddr sd))
- sd)
- (t
- (error "Bad slot description `~S'." sd))))
- slots))
- (predicate (intern (concat name-string "-P"))))
- `(progn
- ;; Constructor
- (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
- (list ',name ,@(mapcar #'car slot-descriptions)))
- ;; Predicate
- (defun ,predicate (x)
- (and (consp x) (eq (car x) ',name)))
- ;; Copier
- (defun ,(intern (concat "COPY-" name-string)) (x)
- (copy-list x))
- ;; Slot accessors
- ,@(with-collect
- (let ((index 1))
- (dolist (slot slot-descriptions)
- (let* ((name (car slot))
- (accessor-name (intern (concat name-string "-" (string name)))))
- (collect
- `(defun ,accessor-name (x)
- (unless (,predicate x)
- (error "The object `~S' is not of type `~S'" x ,name-string))
- (nth ,index x)))
- ;; TODO: Implement this with a higher level
- ;; abstraction like defsetf or (defun (setf ..))
- (collect
- `(define-setf-expander ,accessor-name (x)
- (let ((object (gensym))
- (new-value (gensym)))
- (values (list object)
- (list x)
- (list new-value)
- `(progn
- (rplaca (nthcdr ,',index ,object) ,new-value)
- ,new-value)
- `(,',accessor-name ,object)))))
- (incf index)))))
- ',name)))
-
-
;;; Environment
(def!struct binding
(incf index))
output))
-(defvar *literal-table* nil)
-(defvar *literal-counter* 0)
-
-;;; BOOTSTRAP MAGIC: During bootstrap, we record the macro definitions
-;;; as lists. Once everything is compiled, we want to dump the whole
-;;; global environment to the output file to reproduce it in the
+;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
+;;; the bootstrap. Once everything is compiled, we want to dump the
+;;; whole global environment to the output file to reproduce it in the
;;; run-time. However, the environment must contain expander functions
;;; rather than lists. We do not know how to dump function objects
-;;; itself, so we mark the definitions with this object and the
+;;; itself, so we mark the list definitions with this object and the
;;; compiler will be called when this object has to be dumped.
;;; Backquote/unquote does a similar magic, but this use is exclusive.
+;;;
+;;; Indeed, perhaps to compile the object other macros need to be
+;;; evaluated. For this reason we define a valid macro-function for
+;;; this symbol.
(defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
+#-jscl
+(setf (macro-function *magic-unquote-marker*)
+ (lambda (form &optional environment)
+ (declare (ignore environment))
+ (second form)))
+
+(defvar *literal-table* nil)
+(defvar *literal-counter* 0)
(defun genlit ()
(code "l" (incf *literal-counter*)))
(defun dump-symbol (symbol)
- #+common-lisp
+ #-jscl
(let ((package (symbol-package symbol)))
(if (eq package (find-package "KEYWORD"))
- (code "(new Symbol(" (dump-string (symbol-name symbol)) ", "
- (dump-string (package-name package)) "))")
+ (code "(new Symbol(" (dump-string (symbol-name symbol)) ", " (dump-string (package-name package)) "))")
(code "(new Symbol(" (dump-string (symbol-name symbol)) "))")))
#+jscl
(let ((package (symbol-package symbol)))
((floatp sexp) (float-to-string sexp))
((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))
(t
- (or (cdr (assoc sexp *literal-table* :test #'equal))
+ (or (cdr (assoc sexp *literal-table* :test #'eql))
(let ((dumped (typecase sexp
(symbol (dump-symbol sexp))
(string (dump-string sexp))
(cons
+ ;; BOOTSTRAP MAGIC: See the root file
+ ;; jscl.lisp and the function
+ ;; `dump-global-environment' for futher
+ ;; information.
(if (eq (car sexp) *magic-unquote-marker*)
- (ls-compile (cdr sexp))
+ (ls-compile (second sexp))
(dump-cons sexp)))
(array (dump-array sexp)))))
(if (and recursive (not (symbolp sexp)))
(let ((jsvar (genlit)))
(push (cons sexp jsvar) *literal-table*)
(toplevel-compilation (code "var " jsvar " = " dumped))
+ (when (keywordp sexp)
+ (toplevel-compilation (code jsvar ".value = " jsvar)))
jsvar)))))))
(define-compilation progn (&rest body)
(if (null (cdr body))
(ls-compile (car body) *multiple-value-p*)
- (js!selfcall (ls-compile-block body t))))
+ (code "("
+ (join
+ (remove-if #'null-or-empty-p
+ (append
+ (mapcar #'ls-compile (butlast body))
+ (list (ls-compile (car (last body)) t))))
+ ",")
+ ")")))
(defun special-variable-p (x)
(and (claimp x 'variable 'special) t))
variables)
",")
"){" *newline*
- (let ((body (ls-compile-block body t)))
+ (let ((body (ls-compile-block body t t)))
(indent (let-binding-wrapper dynamic-bindings body)))
"})(" (join cvalues ",") ")")))
(js!selfcall
(let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
(body (concat (mapconcat #'let*-initialize-value bindings)
- (ls-compile-block body t))))
+ (ls-compile-block body t t))))
(let*-binding-wrapper specials body)))))
(ls-compile-block forms)
"return args;" *newline*))
-
-;;; Backquote implementation.
-;;;
-;;; Author: Guy L. Steele Jr. Date: 27 December 1985
-;;; Tested under Symbolics Common Lisp and Lucid Common Lisp.
-;;; This software is in the public domain.
-
-;;; The following are unique tokens used during processing.
-;;; They need not be symbols; they need not even be atoms.
-(defvar *comma* 'unquote)
-(defvar *comma-atsign* 'unquote-splicing)
-
-(defvar *bq-list* (make-symbol "BQ-LIST"))
-(defvar *bq-append* (make-symbol "BQ-APPEND"))
-(defvar *bq-list** (make-symbol "BQ-LIST*"))
-(defvar *bq-nconc* (make-symbol "BQ-NCONC"))
-(defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
-(defvar *bq-quote* (make-symbol "BQ-QUOTE"))
-(defvar *bq-quote-nil* (list *bq-quote* nil))
-
-;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
-;;; the expression foo, looking for occurrences of #:COMMA,
-;;; #:COMMA-ATSIGN, and #:COMMA-DOT. It constructs code in strict
-;;; accordance with the rules on pages 349-350 of the first edition
-;;; (pages 528-529 of this second edition). It then optionally
-;;; applies a code simplifier.
-
-;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
-;;; processing applies the code simplifier. If the value is NIL,
-;;; then the code resulting from BACKQUOTE is exactly that
-;;; specified by the official rules.
-(defparameter *bq-simplify* t)
-
-(defmacro backquote (x)
- (bq-completely-process x))
-
-;;; Backquote processing proceeds in three stages:
-;;;
-;;; (1) BQ-PROCESS applies the rules to remove occurrences of
-;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
-;;; this level of BACKQUOTE. (It also causes embedded calls to
-;;; BACKQUOTE to be expanded so that nesting is properly handled.)
-;;; Code is produced that is expressed in terms of functions
-;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE. This is done
-;;; so that the simplifier will simplify only list construction
-;;; functions actually generated by BACKQUOTE and will not involve
-;;; any user code in the simplification. #:BQ-LIST means LIST,
-;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
-;;; but indicates places where "%." was used and where NCONC may
-;;; therefore be introduced by the simplifier for efficiency.
-;;;
-;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
-;;; BQ-PROCESS to produce equivalent but faster code. The
-;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
-;;; introduced into the code.
-;;;
-;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
-;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
-;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
-;;; replaced by its argument). #:BQ-LIST* is replaced by either
-;;; LIST* or CONS (the latter is used in the two-argument case,
-;;; purely to make the resulting code a tad more readable).
-
-(defun bq-completely-process (x)
- (let ((raw-result (bq-process x)))
- (bq-remove-tokens (if *bq-simplify*
- (bq-simplify raw-result)
- raw-result))))
-
-(defun bq-process (x)
- (cond ((atom x)
- (list *bq-quote* x))
- ((eq (car x) 'backquote)
- (bq-process (bq-completely-process (cadr x))))
- ((eq (car x) *comma*) (cadr x))
- ((eq (car x) *comma-atsign*)
- (error ",@~S after `" (cadr x)))
- ;; ((eq (car x) *comma-dot*)
- ;; ;; (error ",.~S after `" (cadr x))
- ;; (error "ill-formed"))
- (t (do ((p x (cdr p))
- (q '() (cons (bracket (car p)) q)))
- ((atom p)
- (cons *bq-append*
- (nreconc q (list (list *bq-quote* p)))))
- (when (eq (car p) *comma*)
- (unless (null (cddr p))
- (error "Malformed ,~S" p))
- (return (cons *bq-append*
- (nreconc q (list (cadr p))))))
- (when (eq (car p) *comma-atsign*)
- (error "Dotted ,@~S" p))
- ;; (when (eq (car p) *comma-dot*)
- ;; ;; (error "Dotted ,.~S" p)
- ;; (error "Dotted"))
- ))))
-
-;;; This implements the bracket operator of the formal rules.
-(defun bracket (x)
- (cond ((atom x)
- (list *bq-list* (bq-process x)))
- ((eq (car x) *comma*)
- (list *bq-list* (cadr x)))
- ((eq (car x) *comma-atsign*)
- (cadr x))
- ;; ((eq (car x) *comma-dot*)
- ;; (list *bq-clobberable* (cadr x)))
- (t (list *bq-list* (bq-process x)))))
-
-;;; This auxiliary function is like MAPCAR but has two extra
-;;; purposes: (1) it handles dotted lists; (2) it tries to make
-;;; the result share with the argument x as much as possible.
-(defun maptree (fn x)
- (if (atom x)
- (funcall fn x)
- (let ((a (funcall fn (car x)))
- (d (maptree fn (cdr x))))
- (if (and (eql a (car x)) (eql d (cdr x)))
- x
- (cons a d)))))
-
-;;; This predicate is true of a form that when read looked
-;;; like %@foo or %.foo.
-(defun bq-splicing-frob (x)
- (and (consp x)
- (or (eq (car x) *comma-atsign*)
- ;; (eq (car x) *comma-dot*)
- )))
-
-;;; This predicate is true of a form that when read
-;;; looked like %@foo or %.foo or just plain %foo.
-(defun bq-frob (x)
- (and (consp x)
- (or (eq (car x) *comma*)
- (eq (car x) *comma-atsign*)
- ;; (eq (car x) *comma-dot*)
- )))
-
-;;; The simplifier essentially looks for calls to #:BQ-APPEND and
-;;; tries to simplify them. The arguments to #:BQ-APPEND are
-;;; processed from right to left, building up a replacement form.
-;;; At each step a number of special cases are handled that,
-;;; loosely speaking, look like this:
-;;;
-;;; (APPEND (LIST a b c) foo) => (LIST* a b c foo)
-;;; provided a, b, c are not splicing frobs
-;;; (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
-;;; provided a, b, c are not splicing frobs
-;;; (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
-;;; (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
-(defun bq-simplify (x)
- (if (atom x)
- x
- (let ((x (if (eq (car x) *bq-quote*)
- x
- (maptree #'bq-simplify x))))
- (if (not (eq (car x) *bq-append*))
- x
- (bq-simplify-args x)))))
-
-(defun bq-simplify-args (x)
- (do ((args (reverse (cdr x)) (cdr args))
- (result
- nil
- (cond ((atom (car args))
- (bq-attach-append *bq-append* (car args) result))
- ((and (eq (caar args) *bq-list*)
- (notany #'bq-splicing-frob (cdar args)))
- (bq-attach-conses (cdar args) result))
- ((and (eq (caar args) *bq-list**)
- (notany #'bq-splicing-frob (cdar args)))
- (bq-attach-conses
- (reverse (cdr (reverse (cdar args))))
- (bq-attach-append *bq-append*
- (car (last (car args)))
- result)))
- ((and (eq (caar args) *bq-quote*)
- (consp (cadar args))
- (not (bq-frob (cadar args)))
- (null (cddar args)))
- (bq-attach-conses (list (list *bq-quote*
- (caadar args)))
- result))
- ((eq (caar args) *bq-clobberable*)
- (bq-attach-append *bq-nconc* (cadar args) result))
- (t (bq-attach-append *bq-append*
- (car args)
- result)))))
- ((null args) result)))
-
-(defun null-or-quoted (x)
- (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
-
-;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
-;;; or #:BQ-NCONC. This produces a form (op item result) but
-;;; some simplifications are done on the fly:
-;;;
-;;; (op '(a b c) '(d e f g)) => '(a b c d e f g)
-;;; (op item 'nil) => item, provided item is not a splicable frob
-;;; (op item 'nil) => (op item), if item is a splicable frob
-;;; (op item (op a b c)) => (op item a b c)
-(defun bq-attach-append (op item result)
- (cond ((and (null-or-quoted item) (null-or-quoted result))
- (list *bq-quote* (append (cadr item) (cadr result))))
- ((or (null result) (equal result *bq-quote-nil*))
- (if (bq-splicing-frob item) (list op item) item))
- ((and (consp result) (eq (car result) op))
- (list* (car result) item (cdr result)))
- (t (list op item result))))
-
-;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
-;;; `(LIST* ,@items ,result) but some simplifications are done
-;;; on the fly.
-;;;
-;;; (LIST* 'a 'b 'c 'd) => '(a b c . d)
-;;; (LIST* a b c 'nil) => (LIST a b c)
-;;; (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
-;;; (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
-(defun bq-attach-conses (items result)
- (cond ((and (every #'null-or-quoted items)
- (null-or-quoted result))
- (list *bq-quote*
- (append (mapcar #'cadr items) (cadr result))))
- ((or (null result) (equal result *bq-quote-nil*))
- (cons *bq-list* items))
- ((and (consp result)
- (or (eq (car result) *bq-list*)
- (eq (car result) *bq-list**)))
- (cons (car result) (append items (cdr result))))
- (t (cons *bq-list** (append items (list result))))))
-
-;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
-;;; (CONS a b) instead of (LIST* a b), purely for readability.
-(defun bq-remove-tokens (x)
- (cond ((eq x *bq-list*) 'list)
- ((eq x *bq-append*) 'append)
- ((eq x *bq-nconc*) 'nconc)
- ((eq x *bq-list**) 'list*)
- ((eq x *bq-quote*) 'quote)
- ((atom x) x)
- ((eq (car x) *bq-clobberable*)
- (bq-remove-tokens (cadr x)))
- ((and (eq (car x) *bq-list**)
- (consp (cddr x))
- (null (cdddr x)))
- (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
- (t (maptree #'bq-remove-tokens x))))
-
(define-transformation backquote (form)
(bq-completely-process form))
(define-builtin-comparison >= ">=")
(define-builtin-comparison <= "<=")
(define-builtin-comparison = "==")
+(define-builtin-comparison /= "!=")
(define-builtin numberp (x)
(js!bool (code "(typeof (" x ") == \"number\")")))
(define-builtin boundp (x)
(js!bool (code "(" x ".value !== undefined)")))
+(define-builtin fboundp (x)
+ (js!bool (code "(" x ".fvalue !== undefined)")))
+
(define-builtin symbol-value (x)
(js!selfcall
"var symbol = " x ";" *newline*
(define-builtin in (key object)
(js!bool (code "(xstring(" key ") in (" object "))")))
+(define-builtin map-for-in (function object)
+ (js!selfcall
+ "var f = " function ";" *newline*
+ "var g = (typeof f === 'function' ? f : f.fvalue);" *newline*
+ "var o = " object ";" *newline*
+ "for (var key in o){" *newline*
+ (indent "g(" (if *multiple-value-p* "values" "pv") ", 1, o[key]);" *newline*)
+ "}"
+ " return " (ls-compile nil) ";" *newline*))
+
(define-builtin functionp (x)
(js!bool (code "(typeof " x " == 'function')")))
(indent "r.push(" (ls-compile nil) ");" *newline*)
"return r;" *newline*))
+;;; FIXME: should take optional min-extension.
+;;; FIXME: should use fill-pointer instead of the absolute end of array
+(define-builtin vector-push-extend (new vector)
+ (js!selfcall
+ "var v = " vector ";" *newline*
+ "v.push(" new ");" *newline*
+ "return v;"))
+
(define-builtin arrayp (x)
(js!bool
(js!selfcall
"if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
"return x[i] = " value ";" *newline*))
+(define-builtin afind (value array)
+ (js!selfcall
+ "var v = " value ";" *newline*
+ "var x = " array ";" *newline*
+ "return x.indexOf(v);" *newline*))
+
+(define-builtin aresize (array new-size)
+ (js!selfcall
+ "var x = " array ";" *newline*
+ "var n = " new-size ";" *newline*
+ "return x.length = n;" *newline*))
+
(define-builtin get-internal-real-time ()
"(new Date()).getTime()")
`(%js-vref ,var))))
-#+common-lisp
+#-jscl
(defvar *macroexpander-cache*
(make-hash-table :test #'eq))
(if (and b (eq (binding-type b) 'macro))
(let ((expander (binding-value b)))
(cond
- #+common-lisp
+ #-jscl
((gethash b *macroexpander-cache*)
(setq expander (gethash b *macroexpander-cache*)))
((listp expander)
;; function with the compiled one.
;;
#+jscl (setf (binding-value b) compiled)
- #+common-lisp (setf (gethash b *macroexpander-cache*) compiled)
+ #-jscl (setf (gethash b *macroexpander-cache*) compiled)
(setq expander compiled))))
expander)
nil)))
((and (consp form) (symbolp (car form)))
(let ((macrofun (!macro-function (car form))))
(if macrofun
- (values (apply macrofun (cdr form)) t)
+ (values (funcall macrofun (cdr form)) t)
(values form nil))))
(t
(values form nil))))
(concat (translate-function function) arglist))
((and (symbolp function)
#+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
- #+common-lisp t)
+ #-jscl t)
(code (ls-compile `',function) ".fvalue" arglist))
(t
(code (ls-compile `#',function) arglist)))))
-(defun ls-compile-block (sexps &optional return-last-p)
- (if return-last-p
- (code (ls-compile-block (butlast sexps))
- "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
- (join-trailing
- (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
- (concat ";" *newline*))))
+(defun ls-compile-block (sexps &optional return-last-p decls-allowed-p)
+ (multiple-value-bind (sexps decls)
+ (parse-body sexps :declarations decls-allowed-p)
+ (declare (ignore decls))
+ (if return-last-p
+ (code (ls-compile-block (butlast sexps) nil decls-allowed-p)
+ "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
+ (join-trailing
+ (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
+ (concat ";" *newline*)))))
(defun ls-compile (sexp &optional multiple-value-p)
(multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
--- /dev/null
+;;; defstruct.lisp ---
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
+
+;; A very simple defstruct built on lists. It supports just slot with
+;; an optional default initform, and it will create a constructor,
+;; predicate and accessors for you.
+(defmacro def!struct (name &rest slots)
+ (unless (symbolp name)
+ (error "It is not a full defstruct implementation."))
+ (let* ((name-string (symbol-name name))
+ (slot-descriptions
+ (mapcar (lambda (sd)
+ (cond
+ ((symbolp sd)
+ (list sd))
+ ((and (listp sd) (car sd) (cddr sd))
+ sd)
+ (t
+ (error "Bad slot description `~S'." sd))))
+ slots))
+ (predicate (intern (concat name-string "-P"))))
+ `(progn
+ ;; Constructor
+ (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
+ (list ',name ,@(mapcar #'car slot-descriptions)))
+ ;; Predicate
+ (defun ,predicate (x)
+ (and (consp x) (eq (car x) ',name)))
+ ;; Copier
+ (defun ,(intern (concat "COPY-" name-string)) (x)
+ (copy-list x))
+ ;; Slot accessors
+ ,@(with-collect
+ (let ((index 1))
+ (dolist (slot slot-descriptions)
+ (let* ((name (car slot))
+ (accessor-name (intern (concat name-string "-" (string name)))))
+ (collect
+ `(defun ,accessor-name (x)
+ (unless (,predicate x)
+ (error "The object `~S' is not of type `~S'" x ,name-string))
+ (nth ,index x)))
+ ;; TODO: Implement this with a higher level
+ ;; abstraction like defsetf or (defun (setf ..))
+ (collect
+ `(define-setf-expander ,accessor-name (x)
+ (let ((object (gensym))
+ (new-value (gensym)))
+ (values (list object)
+ (list x)
+ (list new-value)
+ `(progn
+ (rplaca (nthcdr ,',index ,object) ,new-value)
+ ,new-value)
+ `(,',accessor-name ,object)))))
+ (incf index)))))
+ ',name)))
--- /dev/null
+;;; lambda-list.lisp --- Lambda list parsing and destructuring
+
+;;; Copyright (C) 2013 David Vazquez
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
+
+(defvar !lambda-list-keywords
+ '(&optional &rest &key &aux &allow-other-keys &body &optional))
+
+;;;; Lambda list parsing
+
+(def!struct optvar
+ variable initform supplied-p-parameter)
+
+(def!struct keyvar
+ variable keyword-name initform supplied-p-parameter)
+
+(def!struct auxvar
+ variable initform)
+
+(def!struct d-lambda-list
+ wholevar
+ reqvars
+ optvars
+ restvar
+ allow-other-keys
+ keyvars
+ auxvars)
+
+(defun var-or-pattern (x)
+ (etypecase x
+ (symbol x)
+ (cons (parse-destructuring-lambda-list x))))
+
+(defun parse-optvar (desc)
+ (etypecase desc
+ (symbol
+ (make-optvar :variable desc))
+ (cons
+ (let ((variable (first desc))
+ (initform (second desc))
+ (supplied-p-parameter (third desc)))
+ (unless (null (cdddr desc))
+ (error "Bad optional parameter specification `~S'" desc))
+ (unless (symbolp supplied-p-parameter)
+ (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
+ (make-optvar :variable (var-or-pattern variable)
+ :initform initform
+ :supplied-p-parameter supplied-p-parameter)))))
+
+(defun parse-keyvar (desc)
+ (etypecase desc
+ (symbol
+ (make-keyvar :variable desc :keyword-name (intern (string desc) "KEYWORD")))
+ (cons
+ (let (variable
+ keyword-name
+ (initform (second desc))
+ (supplied-p-parameter (third desc)))
+ (unless (null (cdddr desc))
+ (error "Bad keyword parameter specification `~S'" desc))
+ (unless (symbolp supplied-p-parameter)
+ (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
+ (let ((name (first desc)))
+ (etypecase name
+ (symbol
+ (setq keyword-name (intern (string name) "KEYWORD"))
+ (setq variable name))
+ (cons
+ (unless (null (cddr name))
+ (error "Bad keyword argument name description `~S'" name))
+ (setq keyword-name (first name))
+ (setq variable (second name)))))
+ (unless (symbolp keyword-name)
+ (error "~S is not a valid keyword-name." keyword-name))
+ (make-keyvar :variable (var-or-pattern variable)
+ :keyword-name keyword-name
+ :initform initform
+ :supplied-p-parameter supplied-p-parameter)))))
+
+(defun parse-auxvar (desc)
+ (etypecase desc
+ (symbol
+ (make-auxvar :variable desc))
+ (cons
+ (let ((variable (first desc))
+ (initform (second desc)))
+ (unless (null (cdddr desc))
+ (error "Bad aux variable specification `~S'" desc))
+ (make-auxvar :variable (var-or-pattern variable)
+ :initform initform)))))
+
+(defun parse-destructuring-lambda-list (lambda-list)
+ (let (;; Destructured lambda list structure where we accumulate the
+ ;; results of the parsing.
+ (d-ll (make-d-lambda-list))
+ ;; List of lambda list keywords which we have already seen.
+ (lambda-keywords nil))
+ (flet ( ;; Check if we are in the beginning of the section NAME in
+ ;; the lambda list. It checks also if the section is in the
+ ;; proper place and it is new.
+ (lambda-section (name)
+ (let ((section (first lambda-list)))
+ (when (find section lambda-keywords)
+ (error "Bad placed ~a in the lambda-list ~S." section lambda-list))
+ (when (eq name section)
+ (push name lambda-keywords)
+ (pop lambda-list)
+ t)))
+ ;; Check if we are in the middle of a lambda list section,
+ ;; looking for a lambda list keyword in the current
+ ;; position of the lambda list.
+ (in-section-p ()
+ (and (consp lambda-list)
+ (not (find (first lambda-list) !lambda-list-keywords)))))
+
+ ;; &whole var
+ (when (lambda-section '&whole)
+ (let ((wholevar (pop lambda-list)))
+ (setf (d-lambda-list-wholevar d-ll) (var-or-pattern wholevar))))
+
+ ;; required vars
+ (while (in-section-p)
+ (let ((var (pop lambda-list)))
+ (push (var-or-pattern var) (d-lambda-list-reqvars d-ll))))
+ (setf (d-lambda-list-reqvars d-ll)
+ (reverse (d-lambda-list-reqvars d-ll)))
+
+ ;; optional vars
+ (when (lambda-section '&optional)
+ (while (in-section-p)
+ (push (parse-optvar (pop lambda-list))
+ (d-lambda-list-optvars d-ll)))
+ (setf (d-lambda-list-optvars d-ll)
+ (reverse (d-lambda-list-optvars d-ll))))
+
+ ;; Dotted lambda-list and &rest/&body vars. If the lambda-list
+ ;; is dotted. Convert it the tail to a &rest and finish.
+ (when (and lambda-list (atom lambda-list))
+ (push lambda-list (d-lambda-list-restvar d-ll))
+ (setq lambda-list nil))
+ (when (find (car lambda-list) '(&body &rest))
+ (pop lambda-list)
+ (setf (d-lambda-list-restvar d-ll)
+ (var-or-pattern (pop lambda-list))))
+
+ ;; Keyword arguments
+ (when (lambda-section '&key)
+ (while (in-section-p)
+ (push (parse-keyvar (pop lambda-list))
+ (d-lambda-list-keyvars d-ll)))
+ (setf (d-lambda-list-keyvars d-ll)
+ (reverse (d-lambda-list-keyvars d-ll))))
+ (when (lambda-section '&allow-other-keys)
+ (setf (d-lambda-list-allow-other-keys d-ll) t))
+
+ ;; Aux variables
+ (when (lambda-section '&aux)
+ (while (in-section-p)
+ (push (parse-auxvar (pop lambda-list))
+ (d-lambda-list-auxvars d-ll)))
+ (setf (d-lambda-list-auxvars d-ll)
+ (reverse (d-lambda-list-auxvars d-ll))))
+ d-ll)))
+
+
+;;;; Destructuring
+
+(defmacro do-keywords (var value list &body body)
+ (let ((g!list (gensym)))
+ `(let ((,g!list ,list))
+ (while ,g!list
+ (let ((,var (car ,g!list))
+ (,value (cadr ,g!list)))
+ ,@body)
+ (setq ,g!list (cddr ,g!list))))))
+
+;;; Return T if KEYWORD is supplied in the list of arguments LIST.
+(defun keyword-supplied-p (keyword list)
+ (do-keywords key value list
+ (declare (ignore value))
+ (when (eq key keyword) (return t))
+ (setq list (cddr list))))
+
+;;; Return the value of KEYWORD in the list of arguments LIST or NIL
+;;; if it is not supplied.
+(defun keyword-lookup (keyword list)
+ (do-keywords key value list
+ (when (eq key keyword) (return value))
+ (setq list (cddr list))))
+
+(defun validate-reqvars (list n)
+ (unless (listp list)
+ (error "`~S' is not a list." list))
+ (unless (<= n (length list))
+ (error "Invalid number of elements in `~S'" list))
+ list)
+
+(defun validate-max-args (list)
+ (unless (null list)
+ (error "Too many elements `~S' in the lambda-list" list))
+ list)
+
+;;; Validate a list of keyword arguments.
+(defun validate-keyvars (list keyword-list &optional allow-other-keys)
+ (let (;; If it is non-NIL, we have to check for unknown keyword
+ ;; arguments in the list to signal an error in that case.
+ (allow-other-keys
+ (or allow-other-keys (keyword-lookup :allow-other-keys list))))
+ (unless allow-other-keys
+ (do-keywords key value list
+ (declare (ignore value))
+ (unless (find key keyword-list)
+ (error "Unknown keyword argument `~S'." key))))
+ (do* ((tail list (cddr tail))
+ (key (car tail) (car tail)))
+ ((null tail) list)
+ (unless (symbolp key)
+ (error "Keyword argument `~S' is not a symbol." key))
+ (unless (consp (cdr tail))
+ (error "Odd number of keyword arguments.")))))
+
+
+(defun !expand-destructuring-bind (lambda-list expression &rest body)
+ (multiple-value-bind (d-ll)
+ (parse-destructuring-lambda-list lambda-list)
+ (let ((bindings '()))
+ (labels ( ;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),
+ ;; such that there are N calls to CDR.
+ (nth-chain (x n &optional tail)
+ (if tail
+ (if (zerop n) x `(cdr ,(nth-chain x (1- n) t)))
+ `(car ,(nth-chain x n t))))
+ ;; Compute the bindings for a pattern against FORM. If
+ ;; PATTERN is a lambda-list the pattern is bound to an
+ ;; auxiliary variable, otherwise PATTERN must be a
+ ;; symbol it will be bound to the form. The variable
+ ;; where the form is bound is returned.
+ (compute-pbindings (pattern form)
+ (cond
+ ((null pattern))
+ ((symbolp pattern)
+ (push `(,pattern ,form) bindings)
+ pattern)
+ ((d-lambda-list-p pattern)
+ (compute-bindings pattern form))))
+
+ ;; Compute the bindings for the full D-LAMBDA-LIST d-ll
+ ;; against FORM.
+ (compute-bindings (d-ll form)
+ (let ((reqvar-count (length (d-lambda-list-reqvars d-ll)))
+ (optvar-count (length (d-lambda-list-optvars d-ll)))
+ (whole (or (d-lambda-list-wholevar d-ll) (gensym))))
+ ;; Create a binding for the whole expression
+ ;; FORM. It will match to D-LL, so we validate the
+ ;; number of elements on the result of FORM.
+ (compute-pbindings whole `(validate-reqvars ,form ,reqvar-count))
+
+ (let ((count 0))
+ ;; Required vars
+ (dolist (reqvar (d-lambda-list-reqvars d-ll))
+ (compute-pbindings reqvar (nth-chain whole count))
+ (incf count))
+ ;; Optional vars
+ (dolist (optvar (d-lambda-list-optvars d-ll))
+ (when (optvar-supplied-p-parameter optvar)
+ (compute-pbindings (optvar-supplied-p-parameter optvar)
+ `(not (null ,(nth-chain whole count t)))))
+ (compute-pbindings (optvar-variable optvar)
+ `(if (null ,(nth-chain whole count t))
+ ,(optvar-initform optvar)
+ ,(nth-chain whole count)))
+ (incf count))
+
+ ;; Rest-variable and keywords
+
+ ;; If there is a rest or keyword variable, we
+ ;; will add a binding for the rest or an
+ ;; auxiliary variable. The computations in of the
+ ;; keyword start in this variable, so we avoid
+ ;; the long tail of nested CAR/CDR operations
+ ;; each time. We also include validation of
+ ;; keywords if there is any.
+ (let* ((chain (nth-chain whole (+ reqvar-count optvar-count) t))
+ (restvar (d-lambda-list-restvar d-ll))
+ (pattern (or restvar (gensym)))
+ (keywords (mapcar #'keyvar-keyword-name (d-lambda-list-keyvars d-ll)))
+ (rest
+ ;; Create a binding for the rest of the
+ ;; arguments. If there is keywords, then
+ ;; validate this list. If there is no
+ ;; keywords and no &rest variable, then
+ ;; validate that the rest is empty, it is
+ ;; to say, there is no more arguments
+ ;; that we expect.
+ (cond
+ (keywords (compute-pbindings pattern `(validate-keyvars ,chain ',keywords ,(d-lambda-list-allow-other-keys d-ll))))
+ (restvar (compute-pbindings pattern chain))
+ (t (compute-pbindings pattern `(validate-max-args ,chain))))))
+ (when (d-lambda-list-keyvars d-ll)
+ ;; Keywords
+ (dolist (keyvar (d-lambda-list-keyvars d-ll))
+ (let ((variable (keyvar-variable keyvar))
+ (keyword (keyvar-keyword-name keyvar))
+ (supplied (or (keyvar-supplied-p-parameter keyvar)
+ (gensym))))
+ (when supplied
+ (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
+ (compute-pbindings variable `(if ,supplied
+ (keyword-lookup ,keyword ,rest)
+ ,(keyvar-initform keyvar)))))))
+ ;; Aux variables
+ (dolist (auxvar (d-lambda-list-auxvars d-ll))
+ (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))
+
+ whole)))
+
+ ;; Macroexpansion. Compute bindings and generate code for them
+ ;; and some necessary checking.
+ (compute-bindings d-ll expression)
+ `(let* ,(reverse bindings)
+ ,@body)))))
+
+
+;;; Because DEFMACRO uses destructuring-bind to parse the arguments of
+;;; the macro-function, we can't define DESTRUCTURING-BIND with
+;;; defmacro to avoid a circularity. So just define the macro function
+;;; explicitly.
+
+#-jscl
+(defmacro !destructuring-bind (lambda-list expression &body body)
+ (apply #'!expand-destructuring-bind lambda-list expression body))
+
+#+jscl
+(eval-when-compile
+ (let ((macroexpander
+ '#'(lambda (form &optional environment)
+ (declare (ignore environment))
+ (apply #'!expand-destructuring-bind form))))
+ (%compile-defmacro '!destructuring-bind macroexpander)
+ (%compile-defmacro 'destructuring-bind macroexpander)))
;;;; Various list functions
-(defun cons (x y ) (cons x y))
+(defun cons (x y) (cons x y))
(defun consp (x) (consp x))
(defun listp (x)
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))
-(defun cadar (x) (car (cdr (car x))))
-(defun caddr (x) (car (cdr (cdr x))))
-(defun cdddr (x) (cdr (cdr (cdr x))))
-(defun cadddr (x) (car (cdr (cdr (cdr x)))))
-
-(defun cadar (x) (car (cdar x)))
-(defun caaar (x) (car (caar x)))
-(defun caadr (x) (car (cadr x)))
-(defun cdaar (x) (cdr (caar x)))
-(defun cdadr (x) (cdr (cadr x)))
-(defun cddar (x) (cdr (cdar x)))
+
+(defun caaar (x) (car (caar x)))
+(defun caadr (x) (car (cadr x)))
+(defun cadar (x) (car (cdar x)))
+(defun caddr (x) (car (cddr x)))
+(defun cdaar (x) (cdr (caar x)))
+(defun cdadr (x) (cdr (cadr x)))
+(defun cddar (x) (cdr (cdar x)))
+(defun cdddr (x) (cdr (cddr x)))
+
(defun caaaar (x) (car (caaar x)))
(defun caaadr (x) (car (caadr x)))
(defun caadar (x) (car (cadar x)))
(defun cadaar (x) (car (cdaar x)))
(defun cadadr (x) (car (cdadr x)))
(defun caddar (x) (car (cddar x)))
+(defun cadddr (x) (car (cdddr x)))
(defun cdaaar (x) (cdr (caaar x)))
(defun cdaadr (x) (cdr (caadr x)))
(defun cdadar (x) (cdr (cadar x)))
(defun cdddar (x) (cdr (cddar x)))
(defun cddddr (x) (cdr (cdddr x)))
+(defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
+ (when (and testp test-not-p)
+ (error "Both test and test-not are set"))
+ (labels ((s (tree)
+ (let* ((key-val (if key (funcall key tree) tree))
+ (replace (if test-not-p
+ (assoc key-val alist :test-not test-not)
+ (assoc key-val alist :test test)))
+ (x (if replace (cdr replace) tree)))
+ (if (atom x)
+ x
+ (cons (s (car x)) (s (cdr x)))))))
+ (s tree)))
+
+(defun subst (new old tree &key key (test #'eql testp) (test-not #'eql test-not-p))
+ (labels ((s (x)
+ (cond ((satisfies-test-p old x :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p)
+ new)
+ ((atom x) x)
+ (t (let ((a (s (car x)))
+ (b (s (cdr x))))
+ (if (and (eq a (car x))
+ (eq b (cdr x)))
+ x
+ (cons a b)))))))
+ (s tree)))
(defun copy-list (x)
(mapcar #'identity x))
(copy-tree (cdr tree)))
tree))
-(defun tree-equal (tree1 tree2 &key (test #'eql))
- (if (atom tree1)
- (and (atom tree2) (funcall test tree1 tree2))
- (and (consp tree2)
- (tree-equal (car tree1) (car tree2) :test test)
- (tree-equal (cdr tree1) (cdr tree2) :test test))))
+(defun tree-equal (tree1 tree2 &key (test #'eql testp)
+ (test-not #'eql test-not-p))
+ (when (and testp test-not-p) (error "Both test and test-not are set"))
+ (let ((func (if test-not-p (complement test-not) test)))
+ (labels ((%tree-equal (tree1 tree2)
+ (if (atom tree1)
+ (and (atom tree2) (funcall func tree1 tree2))
+ (and (consp tree2)
+ (%tree-equal (car tree1) (car tree2))
+ (%tree-equal (cdr tree1) (cdr tree2))))))
+ (%tree-equal tree1 tree2))))
(defun tailp (object list)
(do ((tail list (cdr tail)))
(when (eql tail object)
(return-from tailp t))))
-(defun subst (new old tree &key (key #'identity) (test #'eql))
- (cond
- ((funcall test (funcall key tree) (funcall key old))
- new)
- ((consp tree)
- (cons (subst new old (car tree) :key key :test test)
- (subst new old (cdr tree) :key key :test test)))
- (t tree)))
-
(defmacro pop (place)
(multiple-value-bind (dummies vals newval setter getter)
(get-setf-expansion place)
(rplaca tail (cdar tail)))
(collect (apply func elems))))))))
+(defun mapc (func &rest lists)
+ (do* ((elems (map1 #'car lists) (map1 #'car lists-rest))
+ (lists-rest (map1 #'cdr lists) (map1 #'cdr lists-rest)))
+ ((dolist (x elems) (when (null x) (return t)))
+ (car lists))
+ (apply func elems)))
+
(defun last (x)
(while (consp (cdr x))
(setq x (cdr x)))
(and (consp (cdr x))
(cons (car x) (butlast (cdr x)))))
-(defun member (x list &key (key #'identity) (test #'eql))
+(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p))
(while list
- (when (funcall test x (funcall key (car list)))
+ (when (satisfies-test-p x (car list) :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p)
(return list))
(setq list (cdr list))))
-(defun assoc (x alist &key (test #'eql))
+(defun assoc (x alist &key key (test #'eql testp) (test-not #'eql test-not-p))
(while alist
- (if (funcall test x (caar alist))
+ (if (satisfies-test-p x (caar alist) :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p)
(return)
(setq alist (cdr alist))))
(car alist))
-(defun rassoc (x alist &key (test #'eql))
+(defun rassoc (x alist &key key (test #'eql) (test #'eql testp)
+ (test-not #'eql test-not-p))
(while alist
- (if (funcall test x (cdar alist))
+ (if (satisfies-test-p x (cdar alist) :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p)
(return)
(setq alist (cdr alist))))
(car alist))
--- /dev/null
+;;; misc.lisp --
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
+
+(defparameter *features* '(:jscl :common-lisp))
+
+(defun lisp-implementation-type ()
+ "JSCL")
+
+(defmacro time (form)
+ (let ((start (gensym))
+ (end (gensym)))
+ `(let ((,start (get-internal-real-time))
+ (,end))
+ (prog1 (progn ,form)
+ (setq ,end (get-internal-real-time))
+ (format t "Execution took ~a seconds.~%" (/ (- ,end ,start) 1000.0))))))
+
+
+;;;; TRACE
+
+;;; This trace implementation works on symbols, replacing the function
+;;; with a wrapper. So it will not trace calls to the function if they
+;;; got the function object before it was traced.
+
+;;; An alist of the form (NAME FUNCTION), where NAME is the name of a
+;;; function, and FUNCTION is the function traced.
+(defvar *traced-functions* nil)
+(defvar *trace-level* 0)
+
+(defun trace-report-call (name args)
+ (dotimes (i *trace-level*) (write-string " "))
+ (format t "~a: ~S~%" *trace-level* (cons name args)))
+
+(defun trace-report-return (name values)
+ (dotimes (i *trace-level*) (write-string " "))
+ (format t "~a: ~S returned " *trace-level* name)
+ (dolist (value values) (format t "~S " value))
+ (format t "~%"))
+
+(defun trace-functions (names)
+ (if (null names)
+ (mapcar #'car *traced-functions*)
+ (dolist (name names names)
+ (if (find name *traced-functions* :key #'car)
+ (format t "`~S' is already traced.~%" name)
+ (let ((func (fdefinition name)))
+ (fset name (lambda (&rest args)
+ (let (values)
+ (trace-report-call name args)
+ (let ((*trace-level* (+ *trace-level* 1)))
+ (setq values (multiple-value-list (apply func args))))
+ (trace-report-return name values)
+ (values-list values))))
+ (push (cons name func) *traced-functions*))))))
+
+(defun untrace-functions (names)
+ (when (null names)
+ (setq names (mapcar #'car *traced-functions*)))
+ (dolist (name names)
+ (let ((func (cdr (find name *traced-functions* :key #'car))))
+ (if func
+ (fset name func)
+ (format t "~S is not being traced.~%" name)))))
+
+(defmacro trace (&rest names)
+ `(trace-functions ',names))
+
+(defmacro untrace (&rest names)
+ `(untrace-functions ',names))
--- /dev/null
+;;; numbers.lisp
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Various numeric functions and constants
+
+;; TODO: Use MACROLET when it exists
+(defmacro define-variadic-op (operator initial-value)
+ (let ((init-sym (gensym))
+ (dolist-sym (gensym)))
+ `(defun ,operator (&rest args)
+ (let ((,init-sym ,initial-value))
+ (dolist (,dolist-sym args)
+ (setq ,init-sym (,operator ,init-sym ,dolist-sym)))
+ ,init-sym))))
+
+(define-variadic-op + 0)
+(define-variadic-op * 1)
+
+;; - and / work differently from the above macro.
+;; If only one arg is given, it negates it or takes its reciprocal.
+;; Otherwise all the other args are subtracted from or divided by it.
+;; TODO: Use MACROLET when it exists
+(defmacro define-sub-or-div (operator unary-form)
+ `(defun ,operator (x &rest args)
+ (cond
+ ((null args) ,unary-form)
+ (t (dolist (y args)
+ (setq x (,operator x y)))
+ x))))
+
+(define-sub-or-div - (- x))
+(define-sub-or-div / (/ 1 x))
+
+(defun 1+ (x) (+ x 1))
+(defun 1- (x) (- x 1))
+
+(defun truncate (x &optional (y 1))
+ (floor (/ x y)))
+
+(defun integerp (x)
+ (and (numberp x) (= (floor x) x)))
+
+(defun floatp (x)
+ (and (numberp x) (not (integerp x))))
+
+(defun minusp (x) (< x 0))
+(defun zerop (x) (= x 0))
+(defun plusp (x) (< 0 x))
+
+;; TODO: Use MACROLET when it exists
+(defmacro defcomparison (operator)
+ `(defun ,operator (x &rest args)
+ (dolist (y args)
+ (if (,operator x y)
+ (setq x (car args))
+ (return-from ,operator nil)))
+ t))
+
+(defcomparison >)
+(defcomparison >=)
+(defcomparison =)
+(defcomparison <)
+(defcomparison <=)
+(defcomparison /=)
+
+(defconstant pi 3.141592653589793)
+
+(defun evenp (x) (= (mod x 2) 0))
+(defun oddp (x) (not (evenp x)))
+
+(flet ((%max-min (x xs func)
+ (dolist (y xs)
+ (setq x (if (funcall func x (car xs)) x y)))
+ x))
+ (defun max (x &rest xs) (%max-min x xs #'>))
+ (defun min (x &rest xs) (%max-min x xs #'<)))
+
+(defun abs (x) (if (> x 0) x (- x)))
+
+(defun expt (base power) (expt base power))
+(defun exp (power) (expt 2.718281828459045 power))
(defvar *package-list* nil)
(defun list-all-packages ()
- *package-list*)
+ (copy-list *package-list*))
(defun make-package (name &key use)
(let ((package (new))
(if (in "package" symbol)
(find-package-or-fail (oget symbol "package"))
*common-lisp-package*))
- (symbols (%package-symbols package)))
+ (symbols (%package-symbols package))
+ (exports (%package-external-symbols package)))
(oset symbol "package" package)
+ (oset symbols (symbol-name symbol) symbol)
+ ;; Turn keywords self-evaluated and export them.
(when (eq package *keyword-package*)
- (oset symbol "value" symbol))
- (oset symbols (symbol-name symbol) symbol)))
+ (oset symbol "value" symbol)
+ (oset exports (symbol-name symbol) symbol))))
(defun find-symbol (name &optional (package *package*))
(let* ((package (find-package-or-fail package))
(let ((exports (%package-external-symbols package)))
(dolist (symb symbols t)
(oset exports (symbol-name symb) symb))))
+
+(defun %map-external-symbols (function package)
+ (map-for-in function (%package-external-symbols package)))
+
+(defun %map-symbols (function package)
+ (map-for-in function (%package-symbols package))
+ (dolist (used (package-use-list package))
+ (%map-external-symbols function used)))
+
+(defun %map-all-symbols (function)
+ (dolist (package *package-list*)
+ (map-for-in function (%package-symbols package))))
+
+(defmacro do-symbols ((var &optional (package '*package*) result-form)
+ &body body)
+ `(block nil
+ (%map-symbols
+ (lambda (,var) ,@body)
+ (find-package ,package))
+ ,result-form))
+
+(defmacro do-external-symbols ((var &optional (package '*package*)
+ result-form)
+ &body body)
+ `(block nil
+ (%map-external-symbols
+ (lambda (,var) ,@body)
+ (find-package ,package))
+ ,result-form))
+
+(defmacro do-all-symbols ((var &optional result-form) &body body)
+ `(block nil (%map-all-symbols (lambda (,var) ,@body)) ,result-form))
+
+(defun find-all-symbols (string)
+ (let (symbols)
+ (dolist (package *package-list* symbols)
+ (multiple-value-bind (symbol status) (find-symbol string package)
+ (when status
+ (pushnew symbol symbols :test #'eq))))))
s))
(defvar *print-escape* t)
+(defvar *print-circle* nil)
-(defun write-to-string (form)
- (cond
- ((null form) "NIL")
- ((symbolp form)
- (let ((name (symbol-name form))
- (package (symbol-package form)))
- ;; Check if the symbol is accesible from the current package. It
- ;; is true even if the symbol's home package is not the current
- ;; package, because it could be inherited.
- (if (eq form (find-symbol (symbol-name form)))
- (escape-token (symbol-name form) (not (eq package *js-package*)))
- ;; Symbol is not accesible from *PACKAGE*, so let us prefix
- ;; the symbol with the optional package or uninterned mark.
- (concat (cond
- ((null package) "#")
- ((eq package (find-package "KEYWORD")) "")
- (t (escape-token (package-name package) t)))
- ":"
- (if (and package
- (eq (second (multiple-value-list
- (find-symbol name package)))
- :internal))
- ":"
- "")
- (escape-token name (not (eq package *js-package*)))))))
- ((integerp form) (integer-to-string form))
- ((floatp form) (float-to-string form))
- ((characterp form)
- (concat "#\\"
- (case form
- (#\newline "newline")
- (#\space "space")
- (otherwise (string form)))))
- ((stringp form) (if *print-escape*
- (concat "\"" (escape-string form) "\"")
- form))
- ((functionp form)
- (let ((name (oget form "fname")))
- (if name
- (concat "#<FUNCTION " name ">")
- (concat "#<FUNCTION>"))))
- ((listp form)
- (concat "("
- (join-trailing (mapcar #'write-to-string (butlast form)) " ")
- (let ((last (last form)))
- (if (null (cdr last))
- (write-to-string (car last))
- (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
- ")"))
- ((arrayp form)
- (concat "#" (if (zerop (length form))
- "()"
- (write-to-string (vector-to-list form)))))
- ((packagep form)
- (concat "#<PACKAGE " (package-name form) ">"))
- (t
- (concat "#<javascript object>"))))
+(defun write-to-string (form &optional known-objects object-ids)
+ (when (and (not known-objects) *print-circle*)
+ ;; To support *print-circle* some objects must be tracked for
+ ;; sharing: conses, arrays and apparently-uninterned symbols.
+ ;; These objects are placed in an array and a parallel array is
+ ;; used to mark if they're found multiple times by assining them
+ ;; an id starting from 1.
+ ;;
+ ;; After the tracking has been completed the printing phas can
+ ;; begin: if an object has an id > 0 then #<n>= is prefixed and
+ ;; the id is changed to negative. If an object has an id < 0 then
+ ;; #<-n># is printed instead of the object.
+ ;;
+ ;; The processing is O(n^2) with n = number of tracked objects,
+ ;; but it should be reasonably fast because is based on afind that
+ ;; is a primitive function that compiles to [].indexOf.
+ (setf known-objects (make-array 100))
+ (setf object-ids (make-array 100))
+ (let ((n 0)
+ (sz 100)
+ (count 0))
+ (labels ((mark (x)
+ (let ((i (afind x known-objects)))
+ (if (= i -1)
+ (progn
+ (when (= n sz)
+ (setf sz (* 2 sz))
+ (aresize known-objects sz)
+ (aresize object-ids sz))
+ (aset known-objects (1- (incf n)) x)
+ t)
+ (unless (aref object-ids i)
+ (aset object-ids i (incf count))
+ nil))))
+ (visit (x)
+ (cond
+ ((and x (symbolp x) (null (symbol-package x)))
+ (mark x))
+ ((consp x)
+ (when (mark x)
+ (visit (car x))
+ (visit (cdr x))))
+ ((arrayp x)
+ (when (mark x)
+ (dotimes (i (length x))
+ (visit (aref x i))))))))
+ (visit form))))
+ (let ((prefix ""))
+ (when (and *print-circle*
+ (or (consp form)
+ (arrayp form)
+ (and form (symbolp form) (null (symbol-package form)))))
+ (let* ((ix (afind form known-objects))
+ (id (aref object-ids ix)))
+ (cond
+ ((and id (> id 0))
+ (setf prefix (format nil "#~S=" id))
+ (aset object-ids ix (- id)))
+ ((and id (< id 0))
+ (return-from write-to-string (format nil "#~S#" (- id)))))))
+ (concat prefix
+ (cond
+ ((null form) "NIL")
+ ((symbolp form)
+ (let ((name (symbol-name form))
+ (package (symbol-package form)))
+ ;; Check if the symbol is accesible from the current package. It
+ ;; is true even if the symbol's home package is not the current
+ ;; package, because it could be inherited.
+ (if (eq form (find-symbol (symbol-name form)))
+ (escape-token (symbol-name form) (not (eq package *js-package*)))
+ ;; Symbol is not accesible from *PACKAGE*, so let us prefix
+ ;; the symbol with the optional package or uninterned mark.
+ (concat (cond
+ ((null package) "#")
+ ((eq package (find-package "KEYWORD")) "")
+ (t (escape-token (package-name package) t)))
+ ":"
+ (if (and package
+ (eq (second (multiple-value-list
+ (find-symbol name package)))
+ :internal))
+ ":"
+ "")
+ (escape-token name (not (eq package *js-package*)))))))
+ ((integerp form) (integer-to-string form))
+ ((floatp form) (float-to-string form))
+ ((characterp form)
+ (concat "#\\"
+ (case form
+ (#\newline "newline")
+ (#\space "space")
+ (otherwise (string form)))))
+ ((stringp form) (if *print-escape*
+ (concat "\"" (escape-string form) "\"")
+ form))
+ ((functionp form)
+ (let ((name (oget form "fname")))
+ (if name
+ (concat "#<FUNCTION " name ">")
+ (concat "#<FUNCTION>"))))
+ ((listp form)
+ (concat "("
+ (join-trailing (mapcar (lambda (x)
+ (write-to-string x known-objects object-ids))
+ (butlast form)) " ")
+ (let ((last (last form)))
+ (if (null (cdr last))
+ (write-to-string (car last) known-objects object-ids)
+ (concat (write-to-string (car last) known-objects object-ids)
+ " . "
+ (write-to-string (cdr last) known-objects object-ids))))
+ ")"))
+ ((arrayp form)
+ (let ((result "#(")
+ (sep ""))
+ (dotimes (i (length form))
+ (setf result (concat result sep
+ (write-to-string (aref form i)
+ known-objects
+ object-ids)))
+ (setf sep " "))
+ (concat result ")")))
+ ((packagep form)
+ (concat "#<PACKAGE " (package-name form) ">"))
+ (t "#<javascript object>")))))
(defun prin1-to-string (form)
(let ((*print-escape* t))
;;; The Lisp reader, parse strings and return Lisp objects. The main
;;; entry points are `ls-read' and `ls-read-from-string'.
+;;; #= / ## implementation
+
+;; For now associations label->object are kept in a plist
+;; May be it makes sense to use a vector instead if speed
+;; is considered a problem with many labelled objects
+(defvar *labelled-objects* nil)
+
+(defun new-labelled-objects-table ()
+ (setf *labelled-objects* nil))
+
+(defun find-labelled-object (id)
+ (assoc id *labelled-objects*))
+
+(defun add-labelled-object (id value)
+ (push (cons id value) *labelled-objects*))
+
+;; A unique value used to mark in the labelled objects
+;; table an object that is being constructed
+;; (e.g. #1# while reading elements of "#1=(#1# #1# #1#)")
+(defvar *future-value* (make-symbol "future"))
+
+;; A unique value used to mark temporary values that will
+;; be replaced when fixups are run.
+(defvar *fixup-value* (make-symbol "fixup"))
+
+;; Fixup locations keeps a list of conses where the CAR
+;; is a callable to be called with the value of the object
+;; associated to label stored in CDR once reading is completed
+(defvar *fixup-locations* nil)
+
+(defun fixup-backrefs ()
+ (while *fixup-locations*
+ (let* ((fixup (pop *fixup-locations*))
+ (callable (car fixup))
+ (cell (find-labelled-object (cdr fixup))))
+ (if cell
+ (funcall callable (cdr cell))
+ (error "Internal error in fixup-backrefs: object #~S# not found"
+ (cdr fixup))))))
+
+;; A function that will need to return a fixup callback
+;; for the object that is being read. The returned callback will
+;; be called with the result of reading.
+(defvar *make-fixup-function*
+ (lambda ()
+ (error "Internal error in fixup creation during read")))
+
(defun make-string-stream (string)
(cons string 0))
(unless (char= ch expected)
(error "Character ~S was found but ~S was expected." ch expected))))
-(defun %read-list (stream)
+(defun %read-list (stream &optional (eof-error-p t) eof-value)
(skip-whitespaces-and-comments stream)
(let ((ch (%peek-char stream)))
(cond
(discard-char stream #\))
nil)
(t
- (let* ((eof (gensym))
- (next (ls-read stream nil eof)))
+ (let* ((cell (cons nil nil))
+ (*make-fixup-function* (lambda ()
+ (lambda (obj)
+ (rplaca cell obj))))
+ (eof (gensym))
+ (next (ls-read stream nil eof t)))
+ (rplaca cell next)
(skip-whitespaces-and-comments stream)
(cond
((eq next eof)
- (discard-char stream #\)))
+ (discard-char stream #\))
+ nil)
(t
- (cons next
- (if (char= (%peek-char stream) #\.)
- (progn
- (discard-char stream #\.)
- (if (terminalp (%peek-char stream))
- (prog1 (ls-read stream) ; Dotted pair notation
- (skip-whitespaces-and-comments stream)
- (let ((ch (%peek-char stream)))
- (if (or (null ch) (char= #\) ch))
- (discard-char stream #\))
- (error "Multiple objects following . in a list"))))
- (let ((token (concat "." (read-escaped-until stream #'terminalp))))
- (cons (interpret-token token)
- (%read-list stream)))))
- (%read-list stream))))))))))
+ (if (char= (%peek-char stream) #\.)
+ (progn
+ (discard-char stream #\.)
+ (if (terminalp (%peek-char stream))
+ (let ((*make-fixup-function* (lambda ()
+ (lambda (obj)
+ (rplacd cell obj)))))
+ ;; Dotted pair notation
+ (rplacd cell (ls-read stream eof-error-p eof-value t))
+ (skip-whitespaces-and-comments stream)
+ (let ((ch (%peek-char stream)))
+ (if (or (null ch) (char= #\) ch))
+ (discard-char stream #\))
+ (error "Multiple objects following . in a list"))))
+ (let ((token (concat "." (read-escaped-until stream #'terminalp))))
+ (rplacd cell (cons (interpret-token token)
+ (%read-list stream eof-error-p eof-value))))))
+ (rplacd cell (%read-list stream eof-error-p eof-value)))
+ cell)))))))
(defun read-string (stream)
(let ((string "")
(defun read-sharp (stream &optional eof-error-p eof-value)
(%read-char stream)
- (ecase (%read-char stream)
- (#\'
- (list 'function (ls-read stream)))
- (#\( (list-to-vector (%read-list stream)))
- (#\: (make-symbol
- (unescape-token
- (string-upcase-noescaped
- (read-escaped-until stream #'terminalp)))))
- (#\\
- (let ((cname
- (concat (string (%read-char stream))
- (read-until stream #'terminalp))))
- (cond
- ((string= cname "space") #\space)
- ((string= cname "tab") #\tab)
- ((string= cname "newline") #\newline)
- (t (char cname 0)))))
- (#\+
- (let ((feature (let ((symbol (ls-read stream)))
- (unless (symbolp symbol)
- (error "Invalid feature ~S" symbol))
- (intern (string symbol) "KEYWORD"))))
- (ecase feature
- (:common-lisp
- (ls-read stream)
- (ls-read stream eof-error-p eof-value))
- (:jscl
- (ls-read stream eof-error-p eof-value))
- (:nil
- (ls-read stream)
- (ls-read stream eof-error-p eof-value)))))))
+ (let ((ch (%read-char stream)))
+ (cond
+ ((char= ch #\')
+ (list 'function (ls-read stream eof-error-p eof-value t)))
+ ((char= ch #\()
+ (do ((elements nil)
+ (result nil)
+ (index 0 (1+ index)))
+ ((progn (skip-whitespaces-and-comments stream)
+ (or (null (%peek-char stream))
+ (char= (%peek-char stream) #\))))
+ (discard-char stream #\))
+ (setf result (make-array index))
+ (dotimes (i index)
+ (aset result (decf index) (pop elements)))
+ result)
+ (let* ((ix index) ; Can't just use index: the same var would be captured in all fixups
+ (*make-fixup-function* (lambda ()
+ (lambda (obj)
+ (aset result ix obj))))
+ (eof (gensym))
+ (value (ls-read stream nil eof t)))
+ (push value elements))))
+ ((char= ch #\:)
+ (make-symbol
+ (unescape-token
+ (string-upcase-noescaped
+ (read-escaped-until stream #'terminalp)))))
+ ((char= ch #\\)
+ (let ((cname
+ (concat (string (%read-char stream))
+ (read-until stream #'terminalp))))
+ (cond
+ ((string= cname "space") #\space)
+ ((string= cname "tab") #\tab)
+ ((string= cname "newline") #\newline)
+ (t (char cname 0)))))
+ ((or (char= ch #\+)
+ (char= ch #\-))
+ (let ((feature (let ((symbol (ls-read stream eof-error-p eof-value t)))
+ (unless (symbolp symbol)
+ (error "Invalid feature ~S" symbol))
+ (intern (string symbol) "KEYWORD"))))
+ (if (eql (char= ch #\+)
+ (and (find feature *features*) t))
+ (ls-read stream eof-error-p eof-value t)
+ (prog2 (ls-read stream)
+ (ls-read stream eof-error-p eof-value t)))))
+ ((and ch (digit-char-p ch))
+ (let ((id (digit-char-p ch)))
+ (while (and (%peek-char stream)
+ (digit-char-p (%peek-char stream)))
+ (setf id (+ (* id 10) (digit-char-p (%read-char stream)))))
+ (ecase (%peek-char stream)
+ (#\=
+ (%read-char stream)
+ (if (find-labelled-object id)
+ (error "Duplicated label #~S=" id)
+ (progn
+ (add-labelled-object id *future-value*)
+ (let ((obj (ls-read stream eof-error-p eof-value t)))
+ ;; FIXME: somehow the more natural
+ ;; (setf (cdr (find-labelled-object id)) obj)
+ ;; doesn't work
+ (rplacd (find-labelled-object id) obj)
+ obj))))
+ (#\#
+ (%read-char stream)
+ (let ((cell (find-labelled-object id)))
+ (if cell
+ (if (eq (cdr cell) *future-value*)
+ (progn
+ (push (cons (funcall *make-fixup-function*)
+ id)
+ *fixup-locations*)
+ *fixup-value*)
+ (cdr cell))
+ (error "Invalid labelled object #~S#" id)))))))
+ (t
+ (error "Invalid dispatch character after #")))))
(defun unescape-token (x)
(let ((result ""))
(read-float string)
(read-symbol string)))
-(defun ls-read (stream &optional (eof-error-p t) eof-value)
- (skip-whitespaces-and-comments stream)
- (let ((ch (%peek-char stream)))
- (cond
- ((or (null ch) (char= ch #\)))
- (if eof-error-p
- (error "End of file")
- eof-value))
- ((char= ch #\()
- (%read-char stream)
- (%read-list stream))
- ((char= ch #\')
- (%read-char stream)
- (list 'quote (ls-read stream)))
- ((char= ch #\`)
- (%read-char stream)
- (list 'backquote (ls-read stream)))
- ((char= ch #\")
- (%read-char stream)
- (read-string stream))
- ((char= ch #\,)
- (%read-char stream)
- (if (eql (%peek-char stream) #\@)
- (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
- (list 'unquote (ls-read stream))))
- ((char= ch #\#)
- (read-sharp stream))
- (t
- (let ((string (read-escaped-until stream #'terminalp)))
- (interpret-token string))))))
+(defun ls-read (stream &optional (eof-error-p t) eof-value recursive-p)
+ (let ((save-labelled-objects *labelled-objects*)
+ (save-fixup-locations *fixup-locations*))
+ (unless recursive-p
+ (setf *fixup-locations* nil)
+ (setf *labelled-objects* (new-labelled-objects-table)))
+ (prog1
+ (progn
+ (skip-whitespaces-and-comments stream)
+ (let ((ch (%peek-char stream)))
+ (cond
+ ((or (null ch) (char= ch #\)))
+ (if eof-error-p
+ (error "End of file")
+ eof-value))
+ ((char= ch #\()
+ (%read-char stream)
+ (%read-list stream eof-error-p eof-value))
+ ((char= ch #\')
+ (%read-char stream)
+ (list 'quote (ls-read stream eof-error-p eof-value t)))
+ ((char= ch #\`)
+ (%read-char stream)
+ (list 'backquote (ls-read stream eof-error-p eof-value t)))
+ ((char= ch #\")
+ (%read-char stream)
+ (read-string stream))
+ ((char= ch #\,)
+ (%read-char stream)
+ (if (eql (%peek-char stream) #\@)
+ (progn (%read-char stream) (list 'unquote-splicing
+ (ls-read stream eof-error-p eof-value t)))
+ (list 'unquote (ls-read stream eof-error-p eof-value t))))
+ ((char= ch #\#)
+ (read-sharp stream eof-error-p eof-value))
+ (t
+ (let ((string (read-escaped-until stream #'terminalp)))
+ (interpret-token string))))))
+ (unless recursive-p
+ (fixup-backrefs)
+ (setf *labelled-objects* save-labelled-objects)
+ (setf *fixup-locations* save-fixup-locations)))))
(defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
(ls-read (make-string-stream string) eof-error-p eof-value))
--- /dev/null
+;;; sequence.lisp
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
+
+(defun not-seq-error (thing)
+ (error "`~S' is not of type SEQUENCE" thing))
+
+(defmacro do-sequence ((elt seq &optional (index (gensym "i") index-p)) &body body)
+ (let ((nseq (gensym "seq")))
+ (unless (symbolp elt)
+ (error "`~S' must be a symbol." elt))
+ `(let ((,nseq ,seq))
+ (if (listp ,nseq)
+ ,(if index-p
+ `(let ((,index -1))
+ (dolist (,elt ,nseq)
+ (incf ,index)
+ ,@body))
+ `(dolist (,elt ,nseq)
+ ,@body))
+ (dotimes (,index (length ,nseq))
+ (let ((,elt (aref ,nseq ,index)))
+ ,@body))))))
+
+(defun find (item seq &key key (test #'eql testp) (test-not #'eql test-not-p))
+ (do-sequence (x seq)
+ (when (satisfies-test-p item x :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p)
+ (return x))))
+
+(defun find-if (predicate sequence &key key)
+ (if key
+ (do-sequence (x sequence)
+ (when (funcall predicate (funcall key x))
+ (return x)))
+ (do-sequence (x sequence)
+ (when (funcall predicate x)
+ (return x)))))
+
+(defun position (elt sequence &key key (test #'eql testp)
+ (test-not #'eql test-not-p))
+ (do-sequence (x sequence index)
+ (when (satisfies-test-p elt x :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p )
+ (return index))))
+
+(defun remove (x seq &key key (test #'eql testp) (test-not #'eql test-not-p))
+ (cond
+ ((null seq)
+ nil)
+ ((listp seq)
+ (let* ((head (cons nil nil))
+ (tail head))
+ (do-sequence (elt seq)
+ (unless (satisfies-test-p x elt :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p)
+ (let ((new (list elt)))
+ (rplacd tail new)
+ (setq tail new))))
+ (cdr head)))
+ (t
+ (let (vector)
+ (do-sequence (elt seq index)
+ (if (satisfies-test-p x elt :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p)
+ ;; Copy the beginning of the vector only when we find an element
+ ;; that does not match.
+ (unless vector
+ (setq vector (make-array 0))
+ (dotimes (i index)
+ (vector-push-extend (aref seq i) vector)))
+ (when vector
+ (vector-push-extend elt vector))))
+ (or vector seq)))))
+
+
+(defun some (function seq)
+ (do-sequence (elt seq)
+ (when (funcall function elt)
+ (return-from some t))))
+
+(defun every (function seq)
+ (do-sequence (elt seq)
+ (unless (funcall function elt)
+ (return-from every nil)))
+ t)
+
+(defun remove-if (func seq)
+ (cond
+ ((listp seq) (list-remove-if func seq nil))
+ ((arrayp seq) (vector-remove-if func seq nil))
+ (t (not-seq-error seq))))
+
+(defun remove-if-not (func seq)
+ (cond
+ ((listp seq) (list-remove-if func seq t))
+ ((arrayp seq) (vector-remove-if func seq t))
+ (t (not-seq-error seq))))
+
+(defun list-remove-if (func list negate)
+ (if (endp list)
+ ()
+ (let ((test (funcall func (car list))))
+ (if (if negate (not test) test)
+ (list-remove-if func (cdr list) negate)
+ (cons (car list) (list-remove-if func (cdr list) negate))))))
+
+(defun vector-remove-if (func vector negate)
+ (let ((out-vector (make-array 0)))
+ (do-sequence (element vector i)
+ (let ((test (funcall func element)))
+ (when (if negate test (not test))
+ (vector-push-extend element out-vector))))
+ out-vector))
+
+(defun subseq (seq a &optional b)
+ (cond
+ ((listp seq)
+ (if b
+ (let ((diff (- b a)))
+ (cond
+ ((zerop diff) ())
+ ((minusp diff)
+ (error "Start index must be smaller than end index"))
+ (t
+ (let* ((drop-a (copy-list (nthcdr a seq)))
+ (pointer drop-a))
+ (dotimes (_ (1- diff))
+ (setq pointer (cdr pointer))
+ (when (null pointer)
+ (error "Ending index larger than length of list")))
+ (rplacd pointer ())
+ drop-a))))
+ (copy-list (nthcdr a seq))))
+ ((arrayp seq)
+ (if b
+ (slice seq a b)
+ (slice seq a)))
+ (t (not-seq-error seq))))
(t (char-to-string x))))
(defun string= (s1 s2)
- (let ((n (length s1)))
+ (let* ((s1 (string s1))
+ (s2 (string s2))
+ (n (length s1)))
(when (= (length s2) n)
(dotimes (i n t)
(unless (char= (char s1 i) (char s2 i))
(return-from string= nil))))))
+(defun string< (s1 s2)
+ (let ((len-1 (length s1))
+ (len-2 (length s2)))
+ (cond ((= len-2 0) nil)
+ ((= len-1 0) 0)
+ (t (dotimes (i len-1 nil)
+ (when (char< (char s1 i) (char s2 i))
+ (return-from string< i))
+ (when (and (= i (1- len-1)) (> len-2 len-1))
+ (return-from string< (1+ i))))))))
+
+(defun stringp (s)
+ (stringp s))
+
(define-setf-expander char (string index)
(let ((g!string (gensym))
(g!index (gensym))
+ -)
(values-list /))
-(export '(&body &key &optional &rest * ** *** *gensym-counter* *package* + ++
- +++ - / // /// 1+ 1- < <= = = > >= acons adjoin and append apply aref
- arrayp assoc atom block boundp butlast cadar caaar caadr cdaar cdadr
- cddar caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar
- cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr caar cadddr caddr
- cadr car car case catch cdar cdddr cddr cdr cdr char
- char-code char= code-char cond cons consp constantly
- copy-alist copy-list copy-tree decf declaim declare defconstant
- define-setf-expander define-symbol-macro defmacro defparameter defun
- defvar digit-char digit-char-p disassemble do do* documentation
- dolist dotimes ecase eighth eq eql equal error eval every export expt
- fdefinition fifth find-package find-symbol first flet format fourth
- fset funcall function functionp gensym get-internal-real-time
- get-setf-expansion get-universal-time go identity if in-package
- incf integerp intern intersection keywordp labels lambda last length
- let let* list list* list-all-packages listp loop make-array
- make-package make-symbol mapcar member minusp mod multiple-value-bind
- multiple-value-call multiple-value-list multiple-value-prog1
- nconc nil ninth not nreconc nth nthcdr null numberp or otherwise
- package-name package-use-list packagep pairlis parse-integer plusp
- pop prin1-to-string print proclaim prog1 prog2 progn psetq push
- quote rassoc read-from-string remove remove-if remove-if-not return
- return-from revappend reverse rplaca rplacd second set setf seventh
- setq sixth some string string-upcase string= stringp subseq subst
- symbol-function symbol-name symbol-package symbol-plist
- symbol-value symbolp t tagbody tailp tenth third throw tree-equal
- truncate unless unwind-protect values values-list variable warn when
- write-line write-string zerop))
+(export
+ '(&allow-other-keys &aux &body &environment &key &optional &rest &whole
+ * ** *** *break-on-signals* *compile-file-pathname*
+ *compile-file-truename* *compile-print* *compile-verbose* *debug-io*
+ *debugger-hook* *default-pathname-defaults* *error-output* *features*
+ *gensym-counter* *load-pathname* *load-print* *load-truename*
+ *load-verbose* *macroexpand-hook* *modules* *package* *print-array*
+ *print-base* *print-case* *print-circle* *print-escape* *print-gensym*
+ *print-length* *print-level* *print-lines* *print-miser-width*
+ *print-pprint-dispatch* *print-pretty* *print-radix* *print-readably*
+ *print-right-margin* *query-io* *random-state* *read-base*
+ *read-default-float-format* *read-eval* *read-suppress* *readtable*
+ *standard-input* *standard-output* *terminal-io* *trace-output* + ++
+ +++ - / // /// /= 1+ 1- < <= = > >= abort abs acons acos acosh
+ add-method adjoin adjust-array adjustable-array-p allocate-instance
+ alpha-char-p alphanumericp and append apply 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 base-char base-string
+ bignum 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 car case catch ccase cdaaar cdaadr cdaar
+ cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr
+ cdr ceiling cell-error cell-error-name cerror change-class char
+ char-code char-code-limit char-downcase char-equal char-greaterp
+ char-int char-lessp char-name char-not-equal char-not-greaterp
+ char-not-lessp char-upcase char/= char< char<= char= char> char>=
+ character characterp check-type cis class class-name class-of
+ clear-input clear-output close clrhash code-char coerce
+ compilation-speed compile compile-file compile-file-pathname
+ compiled-function compiled-function-p 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-alist 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-symbol-macro defmacro
+ defmethod defpackage defparameter defsetf defstruct deftype defun
+ defvar delete delete-duplicates delete-file delete-if delete-if-not
+ delete-package denominator deposit-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 documentation dolist
+ dotimes double-float double-float-epsilon
+ double-float-negative-epsilon dpb dribble dynamic-extent ecase
+ echo-stream echo-stream-input-stream echo-stream-output-stream ed
+ eighth elt encode-universal-time end-of-file endp enough-namestring
+ ensure-directories-exist ensure-generic-function eq eql equal equalp
+ error etypecase eval eval-when evenp every exp export expt
+ extended-char fboundp fceiling fdefinition ffloor 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-overflow floating-point-underflow floatp floor
+ fmakunbound force-output format formatter fourth fresh-line fround
+ ftruncate ftype funcall function function-keywords
+ function-lambda-expression functionp gcd generic-function gensym
+ gentemp get get-decoded-time get-dispatch-macro-character
+ get-internal-real-time get-internal-run-time get-macro-character
+ get-output-stream-string get-properties get-setf-expansion
+ get-universal-time getf gethash go graphic-char-p handler-bind
+ handler-case 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 ignorable ignore
+ ignore-errors imagpart import in-package incf initialize-instance
+ inline input-stream-p inspect 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 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-float
+ least-negative-normalized-single-float least-negative-short-float
+ least-negative-single-float 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-implementation-type
+ lisp-implementation-version list list* list-all-packages list-length
+ listen listp load load-logical-pathname-translations 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 macrolet make-array
+ make-broadcast-stream make-concatenated-stream make-condition
+ make-dispatch-macro-character make-echo-stream make-hash-table
+ make-instance make-instances-obsolete make-list make-load-form
+ make-load-form-saving-slots make-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-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-double-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-list
+ multiple-value-prog1 multiple-value-setq multiple-values-limit
+ 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-capitalize nstring-downcase nstring-upcase nsublis nsubst
+ nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not
+ 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 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 print-unreadable-object probe-file proclaim prog prog*
+ prog1 prog2 progn program-error progv provide psetf psetq push pushnew
+ quote random random-state random-state-p rassoc rassoc-if
+ rassoc-if-not ratio rational rationalize rationalp read read-byte
+ read-char read-char-no-hang read-delimited-list read-from-string
+ read-line read-preserving-whitespace read-sequence 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-difference
+ set-dispatch-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-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 string string-capitalize
+ string-downcase string-equal string-greaterp string-left-trim
+ string-lessp string-not-equal string-not-greaterp string-not-lessp
+ string-right-trim string-stream string-trim string-upcase string/=
+ string< string<= string= string> string>= stringp structure
+ structure-class structure-object style-warning 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 t tagbody tailp tan tanh tenth
+ terpri the third throw time trace translate-logical-pathname
+ translate-pathname tree-equal truename truncate two-way-stream
+ two-way-stream-input-stream two-way-stream-output-stream type
+ type-error type-error-datum type-error-expected-type type-of typecase
+ typep unbound-slot unbound-slot-instance unbound-variable
+ undefined-function unexport unintern union unless 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-homedir-pathname values values-list variable 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 write-string write-to-string y-or-n-p
+ yes-or-no-p zerop))
(setq *package* *user-package*)
`(setq ,variable (concat ,variable (progn ,@form))))
;;; This couple of helper functions will be defined in both Common
-;;; Lisp and in Ecmalisp.
+;;; Lisp and in JSCL
(defun ensure-list (x)
(if (listp x)
x
(defun float-to-string (x)
#+jscl (float-to-string x)
- #+common-lisp (format nil "~f" x))
+ #-jscl (format nil "~f" x))
+
+(defun satisfies-test-p (x y &key key (test #'eql) testp (test-not #'eql) test-not-p)
+ (when (and testp test-not-p)
+ (error "Both test and test-not are set"))
+ (let ((key-val (if key (funcall key y) y))
+ (fn (if test-not-p (complement test-not) test)))
+ (funcall fn x key-val)))
(format t "Test `~S' passed unexpectedly!~%" ',condition))
(incf *unexpected-passes*))
(t
- (format t "Test `~S' failed failed expectedly.~%" ',condition)
+ (format t "Test `~S' failed expectedly.~%" ',condition)
(incf *expected-failures*)))
(incf *total-tests*)))
(zfoo 5 rf 3)
out)))
'(-5 -4 -3 999 1 2 3 4 5)))
+
+;; COMPLEMENT
+(test (funcall (complement #'zerop) 1))
+;; FIXME: Uncomment whenever characterp is defined
+;(test (not (funcall (complement #'characterp) #\A)))
+(test (not (funcall (complement #'member) 'a '(a b c))))
+(test (funcall (complement #'member) 'd '(a b c)))
;; Tests for list functions
-;; TODO: EQUAL doesn't compare lists correctly at the moment.
-;; Once it does the lists can be compared directly in many of these tests
+;; CONS
+(test (equal (cons 1 2) '(1 . 2)))
+(test (equal (cons 1 nil) '(1)))
+(test (equal (cons nil 2) '(NIL . 2)))
+(test (equal (cons nil nil) '(NIL)))
+(test (equal (cons 1 (cons 2 (cons 3 (cons 4 nil)))) '(1 2 3 4)))
+(test (equal (cons 'a 'b) '(A . B)))
+(test (equal (cons 'a (cons 'b (cons 'c '()))) '(A B C)))
+(test (equal (cons 'a '(b c d)) '(A B C D)))
+
+;; CONSP
+(test (not (consp 'nil)))
+(test (not (consp nil)))
+(test (not (consp ())))
+(test (not (consp '())))
+(test (consp (cons 1 2)))
+
+;; ATOM
+(test (atom 'sss))
+(test (not (atom (cons 1 2))))
+(test (atom nil))
+(test (atom '()))
+(test (atom 3))
+
+;; RPLACA
+(let ((some-list (list* 'one 'two 'three 'four)))
+ (test (equal (rplaca some-list 'uno) '(UNO TWO THREE . FOUR)))
+ (test (equal some-list '(UNO TWO THREE . FOUR))))
+
+;; RPLACD
+(let ((some-list (list* 'one 'two 'three 'four)))
+ (test (equal (rplacd (last some-list) (list 'IV)) '(THREE IV)))
+ (test (equal some-list '(ONE TWO THREE IV))))
+
+;; CAR, CDR and variants
+(test (equal (car nil) nil))
+(test (equal (cdr '(1 . 2)) 2))
+(test (equal (cdr '(1 2)) '(2)))
+(test (equal (cadr '(1 2)) 2))
+(test (equal (car '(a b c)) 'a))
+(test (equal (cdr '(a b c)) '(b c)))
+(test (equal (caar '((1 2) 3)) 1))
+(test (equal (cadr '(1 2 3)) 2))
+(test (equal (cdar '((1 2) 3)) '(2)))
+(test (equal (cddr '(1 2 3)) '(3)))
+(test (equal (caaar '(((1)))) 1))
+(test (equal (caadr '(1 (2))) 2))
+(test (equal (cadar '((1 2))) 2))
+(test (equal (caddr '(1 2 3)) 3))
+(test (equal (cdaar '(((1 2)))) '(2)))
+(test (equal (cdadr '(1 (2 3))) '(3)))
+(test (equal (cddar '((1 2 3))) '(3)))
+(test (equal (cdddr '(1 2 3 4)) '(4)))
+(test (equal (caaaar '((((1))))) 1))
+(test (equal (caaadr '(1 ((2)))) 2))
+(test (equal (caadar '((1 (2)))) 2))
+(test (equal (caaddr '(1 2 (3))) 3))
+(test (equal (cadaar '(((1 2)))) 2))
+(test (equal (cadadr '(1 (2 3))) 3))
+(test (equal (caddar '((1 2 3))) 3))
+(test (equal (cadddr '(1 2 3 4)) 4))
+(test (equal (cdaaar '((((1 2))))) '(2)))
+(test (equal (cdaadr '(1 ((2 3)))) '(3)))
+(test (equal (cdadar '((1 (2 3)))) '(3)))
+(test (equal (cdaddr '(1 2 (3 4))) '(4)))
+(test (equal (cddaar '(((1 2 3)))) '(3)))
+(test (equal (cddadr '(1 (2 3 4))) '(4)))
+(test (equal (cdddar '((1 2 3 4))) '(4)))
+(test (equal (cddddr '(1 2 3 4 5)) '(5)))
+
+;; SUBLIS
+(test (equal (sublis '((x . 100) (z . zprime))
+ '(plus x (minus g z x p) 4 . x))
+ '(PLUS 100 (MINUS G ZPRIME 100 P) 4 . 100)))
+(test (equal (sublis '(((+ x y) . (- x y)) ((- x y) . (+ x y)))
+ '(* (/ (+ x y) (+ x p)) (- x y))
+ :test #'equal)
+ '(* (/ (- X Y) (+ X P)) (+ X Y))))
+(let ((tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4))))))
+ (test (equal (sublis '((3 . "three")) tree1)
+ '(1 (1 2) ((1 2 "three")) (((1 2 "three" 4))))))
+ (test (equal (sublis '((t . "string"))
+ (sublis '((1 . "") (4 . 44)) tree1)
+ :key #'stringp)
+ '("string" ("string" 2) (("string" 2 3)) ((("string" 2 3 44))))))
+ (test (equal tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4)))))))
+(let ((tree2 '("one" ("one" "two") (("one" "Two" "three")))))
+ (test (equal (sublis '(("two" . 2)) tree2)
+ '("one" ("one" "two") (("one" "Two" "three")))))
+ (test (equal tree2 '("one" ("one" "two") (("one" "Two" "three")))))
+ (test (equal (sublis '(("two" . 2)) tree2 :test 'equal)
+ '("one" ("one" 2) (("one" "Two" "three"))))))
+
+;; SUBST
+(let ((tree1 '(1 (1 2) (1 2 3) (1 2 3 4))))
+ (test (equal (subst "two" 2 tree1) '(1 (1 "two") (1 "two" 3) (1 "two" 3 4))))
+ (test (equal (subst "five" 5 tree1) '(1 (1 2) (1 2 3) (1 2 3 4))))
+ (test (eq tree1 (subst "five" 5 tree1))) ; Implementation dependent
+ (test (equal tree1 '(1 (1 2) (1 2 3) (1 2 3 4)))))
+(test (equal (subst 'tempest 'hurricane
+ '(shakespeare wrote (the hurricane)))
+ '(SHAKESPEARE WROTE (THE TEMPEST))))
+(test (equal (subst 'foo 'nil '(shakespeare wrote (twelfth night)))
+ '(SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO)))
+(test (equal (subst '(a . cons) '(old . pair)
+ '((old . spice) ((old . shoes) old . pair) (old . pair))
+ :test #'equal)
+ '((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS))))
; COPY-TREE
(test (let* ((foo (list '(1 2) '(3 4)))
; TREE-EQUAL
(test (tree-equal '(1 2 3) '(1 2 3)))
+(test (not (tree-equal '(1 2 3) '(3 2 1))))
(test (tree-equal '(1 (2 (3 4) 5) 6) '(1 (2 (3 4) 5) 6)))
-(test (tree-equal (cons 1 2) (cons 2 3)
- :test (lambda (a b) (not (= a b)))))
+(test (tree-equal (cons 1 2) (cons 2 3) :test (lambda (a b) (not (= a b)))))
+(test (tree-equal '(1 . 2) '(2 . 1) :test-not #'eql))
+(test (not (tree-equal '(1 . 2) '(1 . 2) :test-not #'eql)))
; FIRST to TENTH
(let ((nums '(1 2 3 4 5 6 7 8 9 10)))
(test (equal (assoc 1 alist) '(1 . 2)))
(test (equal (rassoc 2 alist) '(1 . 2)))
(test (not (assoc 2 alist)))
- (test (not (rassoc 1 alist))))
+ (test (not (rassoc 1 alist)))
+ (test (equal (assoc 3 alist :test-not #'=) '(1 . 2)))
+ (test (equal (rassoc 4 alist :test-not #'=) '(1 . 2)))
+ (test (equal (assoc 1 alist :key (lambda (x) (/ x 3))) '(3 . 4)))
+ (test (equal (rassoc 2 alist :key (lambda (x) (/ x 2))) '(3 . 4))))
; MEMBER
(test (equal (member 2 '(1 2 3)) '(2 3)))
(test (not (member 4 '(1 2 3))))
(test (equal (member 4 '((1 . 2) (3 . 4)) :key #'cdr) '((3 . 4))))
(test (member '(2) '((1) (2) (3)) :test #'equal))
+(test (member 1 '(1 2 3) :test-not #'eql))
; ADJOIN
(test (equal (adjoin 1 '(2 3)) '(1 2 3)))
(test (not (intersection '(1 2 3) '(4 5 6))))
(test (equal (intersection '((1) (2)) '((2) (3)) :test #'equal) '((2))))
-; SUBST
-; Can't really test this until EQUAL works properly on lists
-
; POP
(test (let* ((foo '(1 2 3))
(bar (pop foo)))
(and (= bar 1)
(= (car foo) 2))))
+
+;; MAPCAR
+(test (equal (mapcar #'+ '(1 2) '(3) '(4 5 6)) '(8)))
+
+;; MAPC
+(test (equal (mapc #'+ '(1 2) '(3) '(4 5 6)) '(1 2)))
+(test (let (foo)
+ (mapc (lambda (x y z) (push (+ x y z) foo)) '(1 2) '(3) '(4 5 6))
+ (equal foo '(8))))
--- /dev/null
+;;;; Tests for numeric functions
+
+;;; ABS
+(test (= (abs 3) 3))
+(test (= (abs -3) 3))
+
+;;; MAX
+(test (= (max 1) 1))
+(test (= (max 1 2 3) 3))
+(test (= (max 3 2 1) 3))
+
+;;; MIN
+(test (= (min 1) 1))
+(test (= (min 1 2 3) 1))
+(test (= (min 3 2 1) 1))
+
+;;; EVENP
+(test (evenp 2))
+(test (evenp -2))
+(test (not (evenp 1)))
+(test (evenp 0))
+
+;;; ODDP
+(test (oddp 3))
+(test (oddp -3))
+(test (not (oddp 2)))
+(test (not (oddp 0)))
+
+;;; +, -, *, /
+;;; The builtin definition of these is variadic, but the function definition
+;;; should be as well. So, test it using MAPCAR
+(let* ((a '(1 2))
+ (b a)
+ (c a))
+ (test (equal (mapcar #'+ a b c) '( 3 6)))
+ (test (equal (mapcar #'- a b c) '(-1 -2)))
+ (test (equal (mapcar #'* a b c) '( 1 8)))
+ ;; This test will need to be changed when rationals are introduced
+ (test (equal (mapcar #'/ a b c) '( 1 0.5))))
+
+;;; >, >=, =, <, <=, /=
+;;; As above, we need to make sure the function is called, not the builtin
+(let ((a '(1 3 1 2 1))
+ (b '(2 2 2 2 1))
+ (c '(3 1 2 1 1)))
+ (test (equal (mapcar #'> a b c) '(nil t nil nil nil)))
+ (test (equal (mapcar #'>= a b c) '(nil t nil t t)))
+ (test (equal (mapcar #'= a b c) '(nil nil nil nil t)))
+ (test (equal (mapcar #'< a b c) '( t nil nil nil nil)))
+ (test (equal (mapcar #'<= a b c) '( t nil t nil t)))
+ (test (equal (mapcar #'/= a b c) '( t t nil nil nil))))
+
+;;; INTEGERP
+(test (integerp 1))
+(test (integerp -1))
+(test (integerp 0))
+
+;;; FLOATP
+
+;; It is a known bug. Javascript does not distinguish between floats
+;; and integers, and we represent both numbers in the same way. So 1
+;; == 1.0 and integer and float types are not disjoint.
+(expected-failure (floatp 1.0))
+
+(test (floatp 1.1))
+(test (floatp pi))
+(test (floatp (- pi)))
+(test (not (floatp 1)))
--- /dev/null
+(test (not (eq (list-all-packages) (list-all-packages))))
+
+(test (equal (multiple-value-list (do-symbols (symbol *package* (values 1 2)))) '(1 2)))
+
+(test
+ (let ((package (make-package 'foo :use '(cl)))
+ foo-symbols
+ cl-symbols)
+ (do-symbols (symbol package)
+ (push symbol foo-symbols))
+ (do-external-symbols (symbol 'cl)
+ (push symbol cl-symbols))
+ (and (not (null foo-symbols))
+ (equal foo-symbols cl-symbols))))
+
+(test
+ (let* ((package (make-package 'bar))
+ (baz (intern (string 'baz) package)))
+ (let (symbols)
+ (do-all-symbols (symbol)
+ (push symbol symbols))
+ (and (member 'car symbols)
+ (member baz symbols)))))
+
+(test (member 'car (find-all-symbols (string 'car))))
(test (equal (read-from-string "(1 .25)") '(1 0.25)))
(test (equal (read-from-string ".25") 0.25))
(test (equal (read-from-string "(1 . 25)") '(1 . 25)))
+
+(test (equal (read-from-string "(#1=99 2 3 #1#)") '(99 2 3 99)))
+(let ((v (read-from-string "#(#1=99 2 3 #1#)")))
+ (test (and (eql (aref v 0) 99)
+ (eql (aref v 1) 2)
+ (eql (aref v 2) 3)
+ (eql (aref v 3) 99))))
+
+(test (let ((x (read-from-string "#1=(42 . #1#)")))
+ (and (eql (nth 99 x) 42)
+ (progn
+ (rplaca x 13)
+ (eql (nth 99 x) 13))
+ (eq x (cdr x)))))
+
+(test (let ((x (read-from-string "#1=#(1 #2=99 #1# #2#)")))
+ (and (eql (aref x 0) 1)
+ (eql (aref x 1) 99)
+ (eq (aref x 2) x)
+ (eql (aref x 3) 99))))
+
+(test (let ((x (read-from-string "#1=(1 2 #2=#(3 4 #1#) 5 #2#)")))
+ (and (eql (nth 0 x) 1)
+ (eql (nth 1 x) 2)
+ (eql (aref (nth 2 x) 0) 3)
+ (eql (aref (nth 2 x) 1) 4)
+ (eq (aref (nth 2 x) 2) x)
+ (eql (nth 3 x) 5)
+ (eq (nth 4 x) (nth 2 x)))))
+
--- /dev/null
+; Functions used as :KEY argument in tests
+(defvar halve (lambda (x) (/ x 2)))
+(defvar double (lambda (x) (* x 2)))
+
+; FIND
+(test (find 1 #(2 1 3)))
+(test (find 1 '(2 1 3)))
+(test (not (find 1 #(2 2 2))))
+(test (not (find 1 '(2 2 2))))
+(test (not (find 1 #(1 1 1) :test-not #'=)))
+(test (not (find 1 '(1 1 1) :test-not #'=)))
+(test (not (find 1 #(1 2 3) :key double)))
+(test (not (find 1 '(1 2 3) :key double)))
+
+; REMOVE
+(test (not (find 1 (remove 1 #(1 2 3 1)))))
+(test (not (find 1 (remove 1 '(1 2 3 1)))))
+(test (not (find 2 (remove 1 #(1 2 3 1) :key halve))))
+(test (not (find 2 (remove 1 '(1 2 3 1) :key halve))))
+;; TODO: Rewrite this test when EQUALP exists and works on vectors
+(test (equal (length (remove '(1 2) #((1 2) (1 2)) :test #'equal)) 0))
+(test (null (remove '(1 2) '((1 2) (1 2)) :test #'equal)))
+(test (find 2 (remove 2 #(1 2 3) :test-not #'=)))
+(test (find 2 (remove 2 '(1 2 3) :test-not #'=)))
+
+; POSITION
+(test (= (position 1 #(1 2 3)) 0))
+(test (= (position 1 '(1 2 3)) 0))
+(test (= (position 1 #(1 2 3 1)) 0))
+(test (= (position 1 '(1 2 3 1)) 0))
+(test (not (position 1 #(2 3 4))))
+(test (not (position 1 '(2 3 4))))
+(test (= (position 1 '(1 2 3) :key halve) 1))
+(test (= (position 1 #(1 2 3) :key halve) 1))
+(test (= (position '(1 2) '((1 2) (3 4)) :test #'equal) 0))
+(test (= (position '(1 2) #((1 2) (3 4)) :test #'equal) 0))
+(test (= (position 1 #(1 1 3) :test-not #'=) 2))
+(test (= (position 1 '(1 1 3) :test-not #'=) 2))
+
+; REMOVE-IF
+(test (equal (remove-if #'zerop '(1 0 2 0 3)) '(1 2 3)))
+(test (equal (remove-if-not #'zerop '(1 0 2 0 3)) '(0 0)))
+;; TODO: Rewrite these tests when EQUALP exists and works on vectors
+(let ((v1 (remove-if #'zerop #(1 0 2 0 3))))
+ (test (and (= (aref v1 0) 1) (= (aref v1 1) 2) (= (aref v1 2) 3))))
+(test (every #'zerop (remove-if-not #'zerop #(1 0 2 0 3))))
+
+; SUBSEQ
+(let ((nums '(1 2 3 4 5)))
+ (test (equal (subseq nums 3) '(4 5)))
+ (test (equal (subseq nums 2 4) '(3 4)))
+ ; Test that nums hasn't been altered: SUBSEQ should construct fresh lists
+ (test (equal nums '(1 2 3 4 5))))
(test (not (string= "Foo" "foo")))
(test (not (string= "foo" "foox")))
+(test (= (string< "one" "two") 0))
+(test (= (string< "oob" "ooc") 2))
+(test (null (string< "" "")))
+(test (null (string< "a" "")))
+(test (= (string< "" "a") 0))
+(test (= (string< "aaa" "aaaaa") 3))
+
;;; BUG: The compiler will macroexpand the forms below (char str N)
;;; will expand to internal SBCL code instead of our (setf char). It
;;; is because macrodefinitions during bootstrapping are not included
projects / jscl.git / commitdiff