src/toplevel.lisp

   1 ;;; toplevel.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; This program 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 ;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19
  20 (defun eval (x)
  21   (js-eval (ls-compile-toplevel x t)))
  22
  23 (defvar * nil)
  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
  34 (defun eval-interactive (x)
  35   (setf - x)
  36   (let ((results (multiple-value-list (eval x))))
  37     (setf /// //
  38           // /
  39           / results
  40           *** **
  41           ** *
  42           * (car results)))
  43   (unless (boundp '*)
  44     ;; FIXME: Handle error
  45     (setf * nil))
  46   (setf +++ ++
  47         ++ +
  48         + -)
  49   (values-list /))
  50
  51 (export '(&body &key &optional &rest * ** *** *gensym-counter* *package* + ++
  52           +++ - / // /// 1+ 1- < <= = = > >= and append apply aref
  53           arrayp assoc atom block boundp butlast caar cadddr caddr
  54           cadr car car case catch cdar cdddr cddr cdr cdr char
  55           char-code char= code-char cond cons consp constantly
  56           copy-list decf declaim defconstant define-setf-expander
  57           define-symbol-macro defmacro defparameter defun defvar
  58           digit-char digit-char-p disassemble do do* documentation
  59           dolist dotimes ecase eq eql equal error eval every export expt
  60           fdefinition find-package find-symbol first flet fourth fset
  61           funcall function functionp gensym get-internal-real-time
  62           get-setf-expansion get-universal-time go identity if in-package
  63           incf integerp intern keywordp labels lambda last length let let* list
  64           list* list-all-packages listp loop make-array make-package
  65           make-symbol mapcar member minusp mod multiple-value-bind
  66           multiple-value-call multiple-value-list multiple-value-prog1
  67           nconc nil not nreconc nth nthcdr null numberp or
  68           package-name package-use-list packagep parse-integer plusp
  69           prin1-to-string print proclaim prog1 prog2 progn psetq push
  70           quote remove remove-if remove-if-not return return-from
  71           revappend reverse rplaca rplacd second set setf setq some
  72           string string-upcase string= stringp subseq symbol-function
  73           symbol-name symbol-package symbol-plist symbol-value symbolp
  74           t tagbody third throw truncate unless unwind-protect values
  75           values-list variable warn when write-line write-string zerop))
  76
  77 (setq *package* *user-package*)
  78
  79 (js-eval "var lisp")
  80 (%js-vset "lisp" (new))
  81 (%js-vset "lisp.read" #'ls-read-from-string)
  82 (%js-vset "lisp.print" #'prin1-to-string)
  83 (%js-vset "lisp.eval" #'eval)
  84 (%js-vset "lisp.compile" (lambda (s) (ls-compile-toplevel s t)))
  85 (%js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
  86 (%js-vset "lisp.evalInput" (lambda (str) (eval-interactive (ls-read-from-string str))))
  87 (%js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t)))
  88
  89 ;; Set the initial global environment to be equal to the host global
  90 ;; environment at this point of the compilation.
  91 (eval-when-compile
  92   (toplevel-compilation
  93    (ls-compile `(setq *environment* ',*environment*))))
  94
  95 (eval-when-compile
  96   (toplevel-compilation
  97    (ls-compile
  98     `(progn
  99        ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
 100                  *literal-symbols*)
 101        (setq *literal-symbols* ',*literal-symbols*)
 102        (setq *variable-counter* ,*variable-counter*)
 103        (setq *gensym-counter* ,*gensym-counter*)
 104        (setq *block-counter* ,*block-counter*)))))
 105
 106 (eval-when-compile
 107   (toplevel-compilation
 108    (ls-compile
 109     `(setq *literal-counter* ,*literal-counter*))))