src/toplevel.lisp

   1 ;;; toplevel.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; JSCL is free software: you can redistribute it and/or
   7 ;; modify it under the terms of the GNU General Public License as
   8 ;; published by the Free Software Foundation, either version 3 of the
   9 ;; License, or (at your option) any later version.
  10 ;;
  11 ;; JSCL is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (/debug "loading toplevel.lisp!")
  20
  21 (defun eval (x)
  22   (js-eval (compile-toplevel x t)))
  23
  24 (defvar * nil)
  25 (defvar ** nil)
  26 (defvar *** nil)
  27 (defvar / nil)
  28 (defvar // nil)
  29 (defvar /// nil)
  30 (defvar + nil)
  31 (defvar ++ nil)
  32 (defvar +++ nil)
  33 (defvar - nil)
  34
  35 (defun eval-interactive (x)
  36   (setf - x)
  37   (let ((results (multiple-value-list (eval x))))
  38     (setf /// //
  39           // /
  40           / results
  41           *** **
  42           ** *
  43           * (car results)))
  44   (unless (boundp '*)
  45     ;; FIXME: Handle error
  46     (setf * nil))
  47   (setf +++ ++
  48         ++ +
  49         + -)
  50   (values-list /))
  51
  52 (export
  53  '(&allow-other-keys &aux &body &environment &key &optional &rest &whole
  54    * ** *** *break-on-signals* *compile-file-pathname*
  55    *compile-file-truename* *compile-print* *compile-verbose* *debug-io*
  56    *debugger-hook* *default-pathname-defaults* *error-output* *features*
  57    *gensym-counter* *load-pathname* *load-print* *load-truename*
  58    *load-verbose* *macroexpand-hook* *modules* *package* *print-array*
  59    *print-base* *print-case* *print-circle* *print-escape* *print-gensym*
  60    *print-length* *print-level* *print-lines* *print-miser-width*
  61    *print-pprint-dispatch* *print-pretty* *print-radix* *print-readably*
  62    *print-right-margin* *query-io* *random-state* *read-base*
  63    *read-default-float-format* *read-eval* *read-suppress* *readtable*
  64    *standard-input* *standard-output* *terminal-io* *trace-output* + ++
  65    +++ - / // /// /= 1+ 1- < <= = > >= abort abs acons acos acosh
  66    add-method adjoin adjust-array adjustable-array-p allocate-instance
  67    alpha-char-p alphanumericp and append apply apropos apropos-list aref
  68    arithmetic-error arithmetic-error-operands arithmetic-error-operation
  69    array array-dimension array-dimension-limit array-dimensions
  70    array-displacement array-element-type array-has-fill-pointer-p
  71    array-in-bounds-p array-rank array-rank-limit array-row-major-index
  72    array-total-size array-total-size-limit arrayp ash asin asinh assert
  73    assoc assoc-if assoc-if-not atan atanh atom base-char base-string
  74    bignum bit bit-and bit-andc1 bit-andc2 bit-eqv bit-ior bit-nand
  75    bit-nor bit-not bit-orc1 bit-orc2 bit-vector bit-vector-p bit-xor
  76    block boole boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1
  77    boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1
  78    boole-orc2 boole-set boole-xor boolean both-case-p boundp break
  79    broadcast-stream broadcast-stream-streams built-in-class butlast byte
  80    byte-position byte-size caaaar caaadr caaar caadar caaddr caadr caar
  81    cadaar cadadr cadar caddar cadddr caddr cadr call-arguments-limit
  82    call-method call-next-method car case catch ccase cdaaar cdaadr cdaar
  83    cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr
  84    cdr ceiling cell-error cell-error-name cerror change-class char
  85    char-code char-code-limit char-downcase char-equal char-greaterp
  86    char-int char-lessp char-name char-not-equal char-not-greaterp
  87    char-not-lessp char-upcase char/= char< char<= char= char> char>=
  88    character characterp check-type cis class class-name class-of
  89    clear-input clear-output close clrhash code-char coerce
  90    compilation-speed compile compile-file compile-file-pathname
  91    compiled-function compiled-function-p compiler-macro
  92    compiler-macro-function complement complex complexp
  93    compute-applicable-methods compute-restarts concatenate
  94    concatenated-stream concatenated-stream-streams cond condition
  95    conjugate cons consp constantly constantp continue control-error
  96    copy-alist copy-list copy-pprint-dispatch copy-readtable copy-seq
  97    copy-structure copy-symbol copy-tree cos cosh count count-if
  98    count-if-not ctypecase debug decf declaim declaration declare
  99    decode-float decode-universal-time defclass defconstant defgeneric
 100    define-compiler-macro define-condition define-method-combination
 101    define-modify-macro define-setf-expander define-symbol-macro defmacro
 102    defmethod defpackage defparameter defsetf defstruct deftype defun
 103    defvar delete delete-duplicates delete-file delete-if delete-if-not
 104    delete-package denominator deposit-field describe describe-object
 105    destructuring-bind digit-char digit-char-p directory
 106    directory-namestring disassemble division-by-zero do do*
 107    do-all-symbols do-external-symbols do-symbols documentation dolist
 108    dotimes double-float double-float-epsilon
 109    double-float-negative-epsilon dpb dribble dynamic-extent ecase
 110    echo-stream echo-stream-input-stream echo-stream-output-stream ed
 111    eighth elt encode-universal-time end-of-file endp enough-namestring
 112    ensure-directories-exist ensure-generic-function eq eql equal equalp
 113    error etypecase eval eval-when evenp every exp export expt
 114    extended-char fboundp fceiling fdefinition ffloor fifth file-author
 115    file-error file-error-pathname file-length file-namestring
 116    file-position file-stream file-string-length file-write-date fill
 117    fill-pointer find find-all-symbols find-class find-if find-if-not
 118    find-method find-package find-restart find-symbol finish-output first
 119    fixnum flet float float-digits float-precision float-radix float-sign
 120    floating-point-inexact floating-point-invalid-operation
 121    floating-point-overflow floating-point-underflow floatp floor
 122    fmakunbound force-output format formatter fourth fresh-line fround
 123    ftruncate ftype funcall function function-keywords
 124    function-lambda-expression functionp gcd generic-function gensym
 125    gentemp get get-decoded-time get-dispatch-macro-character
 126    get-internal-real-time get-internal-run-time get-macro-character
 127    get-output-stream-string get-properties get-setf-expansion
 128    get-universal-time getf gethash go graphic-char-p handler-bind
 129    handler-case hash-table hash-table-count hash-table-p
 130    hash-table-rehash-size hash-table-rehash-threshold hash-table-size
 131    hash-table-test host-namestring identity if ignorable ignore
 132    ignore-errors imagpart import in-package incf initialize-instance
 133    inline input-stream-p inspect integer integer-decode-float
 134    integer-length integerp interactive-stream-p intern
 135    internal-time-units-per-second intersection invalid-method-error
 136    invoke-debugger invoke-restart invoke-restart-interactively isqrt
 137    keyword keywordp labels lambda lambda-list-keywords
 138    lambda-parameters-limit last lcm ldb ldb-test ldiff
 139    least-negative-double-float least-negative-long-float
 140    least-negative-normalized-double-float
 141    least-negative-normalized-long-float
 142    least-negative-normalized-short-float
 143    least-negative-normalized-single-float least-negative-short-float
 144    least-negative-single-float least-positive-double-float
 145    least-positive-long-float least-positive-normalized-double-float
 146    least-positive-normalized-long-float
 147    least-positive-normalized-short-float
 148    least-positive-normalized-single-float least-positive-short-float
 149    least-positive-single-float length let let* lisp-implementation-type
 150    lisp-implementation-version list list* list-all-packages list-length
 151    listen listp load load-logical-pathname-translations load-time-value
 152    locally log logand logandc1 logandc2 logbitp logcount logeqv
 153    logical-pathname logical-pathname-translations logior lognand lognor
 154    lognot logorc1 logorc2 logtest logxor long-float long-float-epsilon
 155    long-float-negative-epsilon long-site-name loop loop-finish
 156    lower-case-p machine-instance machine-type machine-version
 157    macro-function macroexpand macroexpand-1 macrolet make-array
 158    make-broadcast-stream make-concatenated-stream make-condition
 159    make-dispatch-macro-character make-echo-stream make-hash-table
 160    make-instance make-instances-obsolete make-list make-load-form
 161    make-load-form-saving-slots make-method make-package make-pathname
 162    make-random-state make-sequence make-string make-string-input-stream
 163    make-string-output-stream make-symbol make-synonym-stream
 164    make-two-way-stream makunbound map map-into mapc mapcan mapcar mapcon
 165    maphash mapl maplist mask-field max member member-if member-if-not
 166    merge merge-pathnames method method-combination
 167    method-combination-error method-qualifiers min minusp mismatch mod
 168    most-negative-double-float most-negative-fixnum
 169    most-negative-long-float most-negative-short-float
 170    most-negative-single-float most-positive-double-float
 171    most-positive-fixnum most-positive-long-float
 172    most-positive-short-float most-positive-single-float muffle-warning
 173    multiple-value-bind multiple-value-call multiple-value-list
 174    multiple-value-prog1 multiple-value-setq multiple-values-limit
 175    name-char namestring nbutlast nconc next-method-p nil nintersection
 176    ninth no-applicable-method no-next-method not notany notevery
 177    notinline nreconc nreverse nset-difference nset-exclusive-or
 178    nstring-capitalize nstring-downcase nstring-upcase nsublis nsubst
 179    nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not
 180    nth nth-value nthcdr null number numberp numerator nunion oddp open
 181    open-stream-p optimize or otherwise output-stream-p package
 182    package-error package-error-package package-name package-nicknames
 183    package-shadowing-symbols package-use-list package-used-by-list
 184    packagep pairlis parse-error parse-integer parse-namestring pathname
 185    pathname-device pathname-directory pathname-host pathname-match-p
 186    pathname-name pathname-type pathname-version pathnamep peek-char phase
 187    pi plusp pop position position-if position-if-not pprint
 188    pprint-dispatch pprint-exit-if-list-exhausted pprint-fill
 189    pprint-indent pprint-linear pprint-logical-block pprint-newline
 190    pprint-pop pprint-tab pprint-tabular prin1 prin1-to-string princ
 191    princ-to-string print print-not-readable print-not-readable-object
 192    print-object print-unreadable-object probe-file proclaim prog prog*
 193    prog1 prog2 progn program-error progv provide psetf psetq push pushnew
 194    quote random random-state random-state-p rassoc rassoc-if
 195    rassoc-if-not ratio rational rationalize rationalp read read-byte
 196    read-char read-char-no-hang read-delimited-list read-from-string
 197    read-line read-preserving-whitespace read-sequence reader-error
 198    readtable readtable-case readtablep real realp realpart reduce
 199    reinitialize-instance rem remf remhash remove remove-duplicates
 200    remove-if remove-if-not remove-method remprop rename-file
 201    rename-package replace require rest restart restart-bind restart-case
 202    restart-name return return-from revappend reverse room rotatef round
 203    row-major-aref rplaca rplacd safety satisfies sbit scale-float schar
 204    search second sequence serious-condition set set-difference
 205    set-dispatch-macro-character set-exclusive-or set-macro-character
 206    set-pprint-dispatch set-syntax-from-char setf setq seventh shadow
 207    shadowing-import shared-initialize shiftf short-float
 208    short-float-epsilon short-float-negative-epsilon short-site-name
 209    signal signed-byte signum simple-array simple-base-string
 210    simple-bit-vector simple-bit-vector-p simple-condition
 211    simple-condition-format-arguments simple-condition-format-control
 212    simple-error simple-string simple-string-p simple-type-error
 213    simple-vector simple-vector-p simple-warning sin single-float
 214    single-float-epsilon single-float-negative-epsilon sinh sixth sleep
 215    slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound
 216    slot-value software-type software-version some sort space special
 217    special-operator-p speed sqrt stable-sort standard standard-char
 218    standard-char-p standard-class standard-generic-function
 219    standard-method standard-object step storage-condition store-value
 220    stream stream-element-type stream-error stream-error-stream
 221    stream-external-format streamp string string-capitalize
 222    string-downcase string-equal string-greaterp string-left-trim
 223    string-lessp string-not-equal string-not-greaterp string-not-lessp
 224    string-right-trim string-stream string-trim string-upcase string/=
 225    string< string<= string= string> string>= stringp structure
 226    structure-class structure-object style-warning sublis subseq subsetp
 227    subst subst-if subst-if-not substitute substitute-if substitute-if-not
 228    subtypep svref sxhash symbol symbol-function symbol-macrolet
 229    symbol-name symbol-package symbol-plist symbol-value symbolp
 230    synonym-stream synonym-stream-symbol t tagbody tailp tan tanh tenth
 231    terpri the third throw time trace translate-logical-pathname
 232    translate-pathname tree-equal truename truncate two-way-stream
 233    two-way-stream-input-stream two-way-stream-output-stream type
 234    type-error type-error-datum type-error-expected-type type-of typecase
 235    typep unbound-slot unbound-slot-instance unbound-variable
 236    undefined-function unexport unintern union unless unread-char
 237    unsigned-byte untrace unuse-package unwind-protect
 238    update-instance-for-different-class
 239    update-instance-for-redefined-class upgraded-array-element-type
 240    upgraded-complex-part-type upper-case-p use-package use-value
 241    user-homedir-pathname values values-list variable vector vector-pop
 242    vector-push vector-push-extend vectorp warn warning when
 243    wild-pathname-p with-accessors with-compilation-unit
 244    with-condition-restarts with-hash-table-iterator
 245    with-input-from-string with-open-file with-open-stream
 246    with-output-to-string with-package-iterator with-simple-restart
 247    with-slots with-standard-io-syntax write write-byte write-char
 248    write-line write-sequence write-string write-to-string y-or-n-p
 249    yes-or-no-p zerop))
 250
 251 (setq *package* *user-package*)
 252
 253 (defvar *root* (%js-vref "window"))
 254
 255
 256 (defun load-history ()
 257   (#j:jqconsole:SetHistory (#j:JSON:parse (#j:localStorage:getItem "jqhist"))))
 258
 259 (defun save-history ()
 260   (#j:localStorage:setItem "jqhist" (#j:JSON:stringify (#j:jqconsole:GetHistory))))
 261
 262 (defun toplevel ()
 263   (let ((prompt (format nil "~a> " (package-name *package*))))
 264     (#j:jqconsole:Write prompt "jqconsole-prompt"))
 265   (flet ((process-input (input)
 266            (let* ((form (read-from-string input))
 267                   (successp nil)
 268                   result)
 269              ;; Capture errors. We evaluate the form and set successp
 270              ;; to T. However, if a non-local exist happens, we cancel
 271              ;; it, so it is not propagated more.
 272              (block nil
 273                (unwind-protect
 274                     (progn
 275                       (setq result (multiple-value-list (eval-interactive form)))
 276                       (setq successp t))
 277                  (return)))
 278
 279              (if successp
 280                  (dolist (x result)
 281                    (#j:jqconsole:Write (format nil "~S~%" x) "jqconsole-return"))
 282                  (#j:jqconsole:Write (format nil "Error occurred~%") "jqconsole-error"))
 283
 284              (save-history))
 285            (toplevel)))
 286     (#j:jqconsole:Prompt t #'process-input)))
 287
 288
 289 (defun init (&rest args)
 290   (#j:jqconsole:RegisterMatching "(" ")" "parents")
 291   (load-history)
 292   (toplevel))
 293
 294 (#j:window:addEventListener "load" #'init)