src/boot.lisp

   1 ;;; boot.lisp --- First forms to be cross compiled
   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 ;;; This code is executed when JSCL compiles this file itself. The
  20 ;;; compiler provides compilation of some special forms, as well as
  21 ;;; funcalls and macroexpansion, but no functions. So, we define the
  22 ;;; Lisp world from scratch. This code has to define enough language
  23 ;;; to the compiler to be able to run.
  24
  25 (eval-when-compile
  26   (%compile-defmacro 'defmacro
  27                      '(function
  28                        (lambda (name args &rest body)
  29                         `(eval-when-compile
  30                            (%compile-defmacro ',name
  31                                               '(function
  32                                                 (lambda ,(mapcar #'(lambda (x)
  33                                                                      (if (eq x '&body)
  34                                                                          '&rest
  35                                                                          x))
  36                                                                  args)
  37                                                  ,@body))))))))
  38
  39 (defmacro declaim (&rest decls)
  40   `(eval-when-compile
  41      ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
  42
  43 (defmacro defconstant (name value &optional docstring)
  44   `(progn
  45      (declaim (special ,name))
  46      (declaim (constant ,name))
  47      (setq ,name ,value)
  48      ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
  49      ',name))
  50
  51 (defconstant t 't)
  52 (defconstant nil 'nil)
  53 (%js-vset "nil" nil)
  54
  55 (defmacro lambda (args &body body)
  56   `(function (lambda ,args ,@body)))
  57
  58 (defmacro when (condition &body body)
  59   `(if ,condition (progn ,@body) nil))
  60
  61 (defmacro unless (condition &body body)
  62   `(if ,condition nil (progn ,@body)))
  63
  64 (defmacro defvar (name value &optional docstring)
  65   `(progn
  66      (declaim (special ,name))
  67      (unless (boundp ',name) (setq ,name ,value))
  68      ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
  69      ',name))
  70
  71 (defmacro defparameter (name value &optional docstring)
  72   `(progn
  73      (setq ,name ,value)
  74      ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
  75      ',name))
  76
  77 (defmacro defun (name args &rest body)
  78   `(progn
  79      (fset ',name #'(named-lambda ,name ,args ,@body))
  80      ',name))
  81
  82 (defun null (x)
  83   (eq x nil))
  84
  85 (defun endp (x)
  86   (if (null x)
  87       t
  88       (if (consp x)
  89           nil
  90           (error "type-error"))))
  91
  92 (defmacro return (&optional value)
  93   `(return-from nil ,value))
  94
  95 (defmacro while (condition &body body)
  96   `(block nil (%while ,condition ,@body)))
  97
  98 (defvar *gensym-counter* 0)
  99 (defun gensym (&optional (prefix "G"))
 100   (setq *gensym-counter* (+ *gensym-counter* 1))
 101   (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
 102
 103 (defun boundp (x)
 104   (boundp x))
 105
 106 ;; Basic functions
 107 (defun = (x y) (= x y))
 108 (defun * (x y) (* x y))
 109 (defun / (x y) (/ x y))
 110 (defun 1+ (x) (+ x 1))
 111 (defun 1- (x) (- x 1))
 112 (defun zerop (x) (= x 0))
 113
 114 (defun truncate (x &optional (y 1))
 115   (floor (/ x y)))
 116
 117 (defun eql (x y) (eq x y))
 118
 119 (defun not (x) (if x nil t))
 120
 121 (defun cons (x y ) (cons x y))
 122 (defun consp (x) (consp x))
 123
 124 (defun car (x)
 125   "Return the CAR part of a cons, or NIL if X is null."
 126   (car x))
 127
 128 (defun cdr (x) (cdr x))
 129 (defun caar (x) (car (car x)))
 130 (defun cadr (x) (car (cdr x)))
 131 (defun cdar (x) (cdr (car x)))
 132 (defun cddr (x) (cdr (cdr x)))
 133 (defun cadar (x) (car (cdr (car x))))
 134 (defun caddr (x) (car (cdr (cdr x))))
 135 (defun cdddr (x) (cdr (cdr (cdr x))))
 136 (defun cadddr (x) (car (cdr (cdr (cdr x)))))
 137 (defun first (x) (car x))
 138 (defun second (x) (cadr x))
 139 (defun third (x) (caddr x))
 140 (defun fourth (x) (cadddr x))
 141 (defun rest (x) (cdr x))
 142
 143 (defun list (&rest args) args)
 144 (defun atom (x)
 145   (not (consp x)))
 146
 147 ;; Basic macros
 148
 149 (defmacro incf (place &optional (delta 1))
 150   (multiple-value-bind (dummies vals newval setter getter)
 151       (get-setf-expansion place)
 152     (let ((d (gensym)))
 153       `(let* (,@(mapcar #'list dummies vals)
 154               (,d ,delta)
 155                 (,(car newval) (+ ,getter ,d))
 156                 ,@(cdr newval))
 157          ,setter))))
 158
 159 (defmacro decf (place &optional (delta 1))
 160   (multiple-value-bind (dummies vals newval setter getter)
 161       (get-setf-expansion place)
 162     (let ((d (gensym)))
 163       `(let* (,@(mapcar #'list dummies vals)
 164               (,d ,delta)
 165               (,(car newval) (- ,getter ,d))
 166               ,@(cdr newval))
 167          ,setter))))
 168
 169 (defmacro push (x place)
 170   (multiple-value-bind (dummies vals newval setter getter)
 171       (get-setf-expansion place)
 172     (let ((g (gensym)))
 173       `(let* ((,g ,x)
 174               ,@(mapcar #'list dummies vals)
 175               (,(car newval) (cons ,g ,getter))
 176               ,@(cdr newval))
 177          ,setter))))
 178
 179 (defmacro dolist (iter &body body)
 180   (let ((var (first iter))
 181         (g!list (gensym)))
 182     `(block nil
 183        (let ((,g!list ,(second iter))
 184              (,var nil))
 185          (%while ,g!list
 186                  (setq ,var (car ,g!list))
 187                  (tagbody ,@body)
 188                  (setq ,g!list (cdr ,g!list)))
 189          ,(third iter)))))
 190
 191 (defmacro dotimes (iter &body body)
 192   (let ((g!to (gensym))
 193         (var (first iter))
 194         (to (second iter))
 195         (result (third iter)))
 196     `(block nil
 197        (let ((,var 0)
 198              (,g!to ,to))
 199          (%while (< ,var ,g!to)
 200                  (tagbody ,@body)
 201                  (incf ,var))
 202          ,result))))
 203
 204 (defmacro cond (&rest clausules)
 205   (if (null clausules)
 206     nil
 207     (if (eq (caar clausules) t)
 208       `(progn ,@(cdar clausules))
 209       (let ((test-symbol (gensym)))
 210         `(let ((,test-symbol ,(caar clausules)))
 211            (if ,test-symbol
 212              ,(if (null (cdar clausules))
 213                 test-symbol
 214                 `(progn ,@(cdar clausules)))
 215              (cond ,@(cdr clausules))))))))
 216
 217 (defmacro case (form &rest clausules)
 218   (let ((!form (gensym)))
 219     `(let ((,!form ,form))
 220        (cond
 221          ,@(mapcar (lambda (clausule)
 222                      (if (eq (car clausule) t)
 223                          clausule
 224                          `((eql ,!form ',(car clausule))
 225                            ,@(cdr clausule))))
 226                    clausules)))))
 227
 228 (defmacro ecase (form &rest clausules)
 229   `(case ,form
 230      ,@(append
 231         clausules
 232         `((t
 233            (error "ECASE expression failed."))))))
 234
 235 (defmacro and (&rest forms)
 236   (cond
 237     ((null forms)
 238      t)
 239     ((null (cdr forms))
 240      (car forms))
 241     (t
 242      `(if ,(car forms)
 243           (and ,@(cdr forms))
 244           nil))))
 245
 246 (defmacro or (&rest forms)
 247   (cond
 248     ((null forms)
 249      nil)
 250     ((null (cdr forms))
 251      (car forms))
 252     (t
 253      (let ((g (gensym)))
 254        `(let ((,g ,(car forms)))
 255           (if ,g ,g (or ,@(cdr forms))))))))
 256
 257 (defmacro prog1 (form &body body)
 258   (let ((value (gensym)))
 259     `(let ((,value ,form))
 260        ,@body
 261        ,value)))
 262
 263 (defmacro prog2 (form1 result &body body)
 264   `(prog1 (progn ,form1 ,result) ,@body))
 265
 266
 267
 268 ;;; Go on growing the Lisp language in Ecmalisp, with more high level
 269 ;;; utilities as well as correct versions of other constructions.
 270
 271 (defun + (&rest args)
 272   (let ((r 0))
 273     (dolist (x args r)
 274       (incf r x))))
 275
 276 (defun - (x &rest others)
 277   (if (null others)
 278       (- x)
 279       (let ((r x))
 280         (dolist (y others r)
 281           (decf r y)))))
 282
 283 (defun append-two (list1 list2)
 284   (if (null list1)
 285       list2
 286       (cons (car list1)
 287             (append (cdr list1) list2))))
 288
 289 (defun append (&rest lists)
 290   (!reduce #'append-two lists))
 291
 292 (defun revappend (list1 list2)
 293   (while list1
 294     (push (car list1) list2)
 295     (setq list1 (cdr list1)))
 296   list2)
 297
 298 (defun reverse (list)
 299   (revappend list '()))
 300
 301 (defmacro psetq (&rest pairs)
 302   (let (;; For each pair, we store here a list of the form
 303         ;; (VARIABLE GENSYM VALUE).
 304         (assignments '()))
 305     (while t
 306       (cond
 307         ((null pairs) (return))
 308         ((null (cdr pairs))
 309          (error "Odd paris in PSETQ"))
 310         (t
 311          (let ((variable (car pairs))
 312                (value (cadr pairs)))
 313            (push `(,variable ,(gensym) ,value)  assignments)
 314            (setq pairs (cddr pairs))))))
 315     (setq assignments (reverse assignments))
 316     ;;
 317     `(let ,(mapcar #'cdr assignments)
 318        (setq ,@(!reduce #'append (mapcar #'butlast assignments))))))
 319
 320 (defmacro do (varlist endlist &body body)
 321   `(block nil
 322      (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
 323        (while t
 324          (when ,(car endlist)
 325            (return (progn ,@(cdr endlist))))
 326          (tagbody ,@body)
 327          (psetq
 328           ,@(apply #'append
 329                    (mapcar (lambda (v)
 330                              (and (consp (cddr v))
 331                                   (list (first v) (third v))))
 332                            varlist)))))))
 333
 334 (defmacro do* (varlist endlist &body body)
 335   `(block nil
 336      (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
 337        (while t
 338          (when ,(car endlist)
 339            (return (progn ,@(cdr endlist))))
 340          (tagbody ,@body)
 341          (setq
 342           ,@(apply #'append
 343                    (mapcar (lambda (v)
 344                              (and (consp (cddr v))
 345                                   (list (first v) (third v))))
 346                            varlist)))))))
 347
 348 (defun list-length (list)
 349   (let ((l 0))
 350     (while (not (null list))
 351       (incf l)
 352       (setq list (cdr list)))
 353     l))
 354
 355 (defun length (seq)
 356   (cond
 357     ((stringp seq)
 358      (string-length seq))
 359     ((arrayp seq)
 360      (oget seq "length"))
 361     ((listp seq)
 362      (list-length seq))))
 363
 364 (defun concat-two (s1 s2)
 365   (concat-two s1 s2))
 366
 367 (defmacro with-collect (&body body)
 368   (let ((head (gensym))
 369         (tail (gensym)))
 370     `(let* ((,head (cons 'sentinel nil))
 371             (,tail ,head))
 372        (flet ((collect (x)
 373                 (rplacd ,tail (cons x nil))
 374                 (setq ,tail (cdr ,tail))
 375                 x))
 376          ,@body)
 377        (cdr ,head))))
 378
 379 (defun map1 (func list)
 380   (with-collect
 381     (while list
 382       (collect (funcall func (car list)))
 383       (setq list (cdr list)))))
 384
 385 (defmacro loop (&body body)
 386   `(while t ,@body))
 387
 388 (defun mapcar (func list &rest lists)
 389   (let ((lists (cons list lists)))
 390     (with-collect
 391       (block loop
 392         (loop
 393            (let ((elems (map1 #'car lists)))
 394              (do ((tail lists (cdr tail)))
 395                  ((null tail))
 396                (when (null (car tail)) (return-from loop))
 397                (rplaca tail (cdar tail)))
 398              (collect (apply func elems))))))))
 399
 400 (defun identity (x) x)
 401
 402 (defun constantly (x)
 403   (lambda (&rest args)
 404     x))
 405
 406 (defun copy-list (x)
 407   (mapcar #'identity x))
 408
 409 (defun list* (arg &rest others)
 410   (cond ((null others) arg)
 411         ((null (cdr others)) (cons arg (car others)))
 412         (t (do ((x others (cdr x)))
 413                ((null (cddr x)) (rplacd x (cadr x))))
 414            (cons arg others))))
 415
 416 (defun code-char (x) x)
 417 (defun char-code (x) x)
 418 (defun char= (x y) (= x y))
 419
 420 (defun integerp (x)
 421   (and (numberp x) (= (floor x) x)))
 422
 423 (defun floatp (x)
 424   (and (numberp x) (not (integerp x))))
 425
 426 (defun plusp (x) (< 0 x))
 427 (defun minusp (x) (< x 0))
 428
 429 (defun listp (x)
 430   (or (consp x) (null x)))
 431
 432 (defun nthcdr (n list)
 433   (while (and (plusp n) list)
 434     (setq n (1- n))
 435     (setq list (cdr list)))
 436   list)
 437
 438 (defun nth (n list)
 439   (car (nthcdr n list)))
 440
 441 (defun last (x)
 442   (while (consp (cdr x))
 443     (setq x (cdr x)))
 444   x)
 445
 446 (defun butlast (x)
 447   (and (consp (cdr x))
 448        (cons (car x) (butlast (cdr x)))))
 449
 450 (defun member (x list)
 451   (while list
 452     (when (eql x (car list))
 453       (return list))
 454     (setq list (cdr list))))
 455
 456 (defun find (item list &key key (test #'eql))
 457   (dolist (x list)
 458     (when (funcall test (funcall key x) item)
 459       (return x))))
 460
 461 (defun remove (x list)
 462   (cond
 463     ((null list)
 464      nil)
 465     ((eql x (car list))
 466      (remove x (cdr list)))
 467     (t
 468      (cons (car list) (remove x (cdr list))))))
 469
 470 (defun remove-if (func list)
 471   (cond
 472     ((null list)
 473      nil)
 474     ((funcall func (car list))
 475      (remove-if func (cdr list)))
 476     (t
 477      ;;
 478      (cons (car list) (remove-if func (cdr list))))))
 479
 480 (defun remove-if-not (func list)
 481   (cond
 482     ((null list)
 483      nil)
 484     ((funcall func (car list))
 485      (cons (car list) (remove-if-not func (cdr list))))
 486     (t
 487      (remove-if-not func (cdr list)))))
 488
 489 (defun digit-char-p (x)
 490   (if (and (<= #\0 x) (<= x #\9))
 491       (- x #\0)
 492       nil))
 493
 494 (defun digit-char (weight)
 495   (and (<= 0 weight 9)
 496        (char "0123456789" weight)))
 497
 498 (defun subseq (seq a &optional b)
 499   (cond
 500     ((stringp seq)
 501      (if b
 502          (slice seq a b)
 503          (slice seq a)))
 504     (t
 505      (error "Unsupported argument."))))
 506
 507 (defmacro do-sequence (iteration &body body)
 508   (let ((seq (gensym))
 509         (index (gensym)))
 510     `(let ((,seq ,(second iteration)))
 511        (cond
 512          ;; Strings
 513          ((stringp ,seq)
 514           (let ((,index 0))
 515             (dotimes (,index (length ,seq))
 516               (let ((,(first iteration)
 517                      (char ,seq ,index)))
 518                 ,@body))))
 519          ;; Lists
 520          ((listp ,seq)
 521           (dolist (,(first iteration) ,seq)
 522             ,@body))
 523          (t
 524           (error "type-error!"))))))
 525
 526 (defun some (function seq)
 527   (do-sequence (elt seq)
 528     (when (funcall function elt)
 529       (return-from some t))))
 530
 531 (defun every (function seq)
 532   (do-sequence (elt seq)
 533     (unless (funcall function elt)
 534       (return-from every nil)))
 535   t)
 536
 537 (defun position (elt sequence)
 538   (let ((pos 0))
 539     (do-sequence (x seq)
 540       (when (eq elt x)
 541         (return))
 542       (incf pos))
 543     pos))
 544
 545 (defun assoc (x alist &key (test #'eql))
 546   (while alist
 547     (if (funcall test x (caar alist))
 548         (return)
 549         (setq alist (cdr alist))))
 550   (car alist))
 551
 552 (defun string (x)
 553   (cond ((stringp x) x)
 554         ((symbolp x) (symbol-name x))
 555         (t (char-to-string x))))
 556
 557 (defun equal (x y)
 558   (cond
 559     ((eql x y) t)
 560     ((consp x)
 561      (and (consp y)
 562           (equal (car x) (car y))
 563           (equal (cdr x) (cdr y))))
 564     ((arrayp x)
 565      (and (arrayp y)
 566           (let ((n (length x)))
 567             (when (= (length y) n)
 568               (dotimes (i n)
 569                 (unless (equal (aref x i) (aref y i))
 570                   (return-from equal nil)))
 571               t))))
 572     (t nil)))
 573
 574 (defun string= (s1 s2)
 575   (equal s1 s2))
 576
 577 (defun fdefinition (x)
 578   (cond
 579     ((functionp x)
 580      x)
 581     ((symbolp x)
 582      (symbol-function x))
 583     (t
 584      (error "Invalid function"))))
 585
 586 (defun disassemble (function)
 587   (write-line (lambda-code (fdefinition function)))
 588   nil)
 589
 590 (defun documentation (x type)
 591   "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
 592   (ecase type
 593     (function
 594      (let ((func (fdefinition x)))
 595        (oget func "docstring")))
 596     (variable
 597      (unless (symbolp x)
 598        (error "Wrong argument type! it should be a symbol"))
 599      (oget x "vardoc"))))
 600
 601 (defmacro multiple-value-bind (variables value-from &body body)
 602   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
 603                           ,@body)
 604      ,value-from))
 605
 606 (defmacro multiple-value-list (value-from)
 607   `(multiple-value-call #'list ,value-from))
 608
 609
 610 ;;; Generalized references (SETF)
 611
 612 (defvar *setf-expanders* nil)
 613
 614 (defun get-setf-expansion (place)
 615   (if (symbolp place)
 616       (let ((value (gensym)))
 617         (values nil
 618                 nil
 619                 `(,value)
 620                 `(setq ,place ,value)
 621                 place))
 622       (let ((place (ls-macroexpand-1 place)))
 623         (let* ((access-fn (car place))
 624                (expander (cdr (assoc access-fn *setf-expanders*))))
 625           (when (null expander)
 626             (error "Unknown generalized reference."))
 627           (apply expander (cdr place))))))
 628
 629 (defmacro define-setf-expander (access-fn lambda-list &body body)
 630   (unless (symbolp access-fn)
 631     (error "ACCESS-FN must be a symbol."))
 632   `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
 633                 *setf-expanders*)
 634           ',access-fn))
 635
 636 (defmacro setf (&rest pairs)
 637   (cond
 638     ((null pairs)
 639      nil)
 640     ((null (cdr pairs))
 641      (error "Odd number of arguments to setf."))
 642     ((null (cddr pairs))
 643      (let ((place (ls-macroexpand-1 (first pairs)))
 644            (value (second pairs)))
 645        (multiple-value-bind (vars vals store-vars writer-form)
 646            (get-setf-expansion place)
 647          ;; TODO: Optimize the expansion a little bit to avoid let*
 648          ;; or multiple-value-bind when unnecesary.
 649          `(let* ,(mapcar #'list vars vals)
 650             (multiple-value-bind ,store-vars
 651                 ,value
 652               ,writer-form)))))
 653     (t
 654      `(progn
 655         ,@(do ((pairs pairs (cddr pairs))
 656                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
 657               ((null pairs)
 658                (reverse result)))))))
 659
 660 (define-setf-expander car (x)
 661   (let ((cons (gensym))
 662         (new-value (gensym)))
 663     (values (list cons)
 664             (list x)
 665             (list new-value)
 666             `(progn (rplaca ,cons ,new-value) ,new-value)
 667             `(car ,cons))))
 668
 669 (define-setf-expander cdr (x)
 670   (let ((cons (gensym))
 671         (new-value (gensym)))
 672     (values (list cons)
 673             (list x)
 674             (list new-value)
 675             `(progn (rplacd ,cons ,new-value) ,new-value)
 676             `(car ,cons))))
 677
 678 ;; Incorrect typecase, but used in NCONC.
 679 (defmacro typecase (x &rest clausules)
 680   (let ((value (gensym)))
 681     `(let ((,value ,x))
 682        (cond
 683          ,@(mapcar (lambda (c)
 684                      (if (eq (car c) t)
 685                          `((t ,@(rest c)))
 686                          `((,(ecase (car c)
 687                                     (integer 'integerp)
 688                                     (cons 'consp)
 689                                     (symbol 'symbolp)
 690                                     (array 'arrayp)
 691                                     (string 'stringp)
 692                                     (atom 'atom)
 693                                     (null 'null))
 694                              ,value)
 695                            ,@(or (rest c)
 696                                  (list nil)))))
 697                    clausules)))))
 698
 699 ;; The NCONC function is based on the SBCL's one.
 700 (defun nconc (&rest lists)
 701   (flet ((fail (object)
 702            (error "type-error in nconc")))
 703     (do ((top lists (cdr top)))
 704         ((null top) nil)
 705       (let ((top-of-top (car top)))
 706         (typecase top-of-top
 707           (cons
 708            (let* ((result top-of-top)
 709                   (splice result))
 710              (do ((elements (cdr top) (cdr elements)))
 711                  ((endp elements))
 712                (let ((ele (car elements)))
 713                  (typecase ele
 714                    (cons (rplacd (last splice) ele)
 715                          (setf splice ele))
 716                    (null (rplacd (last splice) nil))
 717                    (atom (if (cdr elements)
 718                              (fail ele)
 719                              (rplacd (last splice) ele))))))
 720              (return result)))
 721           (null)
 722           (atom
 723            (if (cdr top)
 724                (fail top-of-top)
 725                (return top-of-top))))))))
 726
 727 (defun nreconc (x y)
 728   (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
 729        (2nd x 1st)                ; 2nd follows first down the list.
 730        (3rd y 2nd))               ;3rd follows 2nd down the list.
 731       ((atom 2nd) 3rd)
 732     (rplacd 2nd 3rd)))
 733
 734 (defun notany (fn seq)
 735   (not (some fn seq)))
 736
 737
 738 ;; Packages
 739
 740 (defvar *package-list* nil)
 741
 742 (defun list-all-packages ()
 743   *package-list*)
 744
 745 (defun make-package (name &key use)
 746   (let ((package (new))
 747         (use (mapcar #'find-package-or-fail use)))
 748     (oset package "packageName" name)
 749     (oset package "symbols" (new))
 750     (oset package "exports" (new))
 751     (oset package "use" use)
 752     (push package *package-list*)
 753     package))
 754
 755 (defun packagep (x)
 756   (and (objectp x) (in "symbols" x)))
 757
 758 (defun find-package (package-designator)
 759   (when (packagep package-designator)
 760     (return-from find-package package-designator))
 761   (let ((name (string package-designator)))
 762     (dolist (package *package-list*)
 763       (when (string= (package-name package) name)
 764         (return package)))))
 765
 766 (defun find-package-or-fail (package-designator)
 767   (or (find-package package-designator)
 768       (error "Package unknown.")))
 769
 770 (defun package-name (package-designator)
 771   (let ((package (find-package-or-fail package-designator)))
 772     (oget package "packageName")))
 773
 774 (defun %package-symbols (package-designator)
 775   (let ((package (find-package-or-fail package-designator)))
 776     (oget package "symbols")))
 777
 778 (defun package-use-list (package-designator)
 779   (let ((package (find-package-or-fail package-designator)))
 780     (oget package "use")))
 781
 782 (defun %package-external-symbols (package-designator)
 783   (let ((package (find-package-or-fail package-designator)))
 784     (oget package "exports")))
 785
 786 (defvar *common-lisp-package*
 787   (make-package "CL"))
 788
 789 (defvar *js-package*
 790   (make-package "JS"))
 791
 792 (defvar *user-package*
 793   (make-package "CL-USER" :use (list *common-lisp-package*)))
 794
 795 (defvar *keyword-package*
 796   (make-package "KEYWORD"))
 797
 798 (defun keywordp (x)
 799   (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
 800
 801 (defvar *package* *common-lisp-package*)
 802
 803 (defmacro in-package (package-designator)
 804   `(eval-when-compile
 805      (setq *package* (find-package-or-fail ,package-designator))))
 806
 807 ;; This function is used internally to initialize the CL package
 808 ;; with the symbols built during bootstrap.
 809 (defun %intern-symbol (symbol)
 810   (let* ((package
 811           (if (in "package" symbol)
 812               (find-package-or-fail (oget symbol "package"))
 813               *common-lisp-package*))
 814          (symbols (%package-symbols package)))
 815     (oset symbol "package" package)
 816     (when (eq package *keyword-package*)
 817       (oset symbol "value" symbol))
 818     (oset symbols (symbol-name symbol) symbol)))
 819
 820 (defun find-symbol (name &optional (package *package*))
 821   (let* ((package (find-package-or-fail package))
 822          (externals (%package-external-symbols package))
 823          (symbols (%package-symbols package)))
 824     (cond
 825       ((in name externals)
 826        (values (oget externals name) :external))
 827       ((in name symbols)
 828        (values (oget symbols name) :internal))
 829       (t
 830        (dolist (used (package-use-list package) (values nil nil))
 831          (let ((exports (%package-external-symbols used)))
 832            (when (in name exports)
 833              (return (values (oget exports name) :inherit)))))))))
 834
 835 (defun intern (name &optional (package *package*))
 836   (let ((package (find-package-or-fail package)))
 837     (multiple-value-bind (symbol foundp)
 838         (find-symbol name package)
 839       (if foundp
 840           (values symbol foundp)
 841           (let ((symbols (%package-symbols package)))
 842             (oget symbols name)
 843             (let ((symbol (make-symbol name)))
 844               (oset symbol "package" package)
 845               (when (eq package *keyword-package*)
 846                 (oset symbol "value" symbol)
 847                 (export (list symbol) package))
 848               (when (eq package *js-package*)
 849                 (let ((sym-name (symbol-name symbol))
 850                       (args (gensym)))
 851                   ;; Generate a trampoline to call the JS function
 852                   ;; properly. This trampoline is very inefficient,
 853                   ;; but it still works. Ideas to optimize this are
 854                   ;; provide a special lambda keyword
 855                   ;; cl::&rest-vector to avoid list argument
 856                   ;; consing, as well as allow inline declarations.
 857                   (fset symbol
 858                         (eval `(lambda (&rest ,args)
 859                                  (let ((,args (list-to-vector ,args)))
 860                                    (%js-call (%js-vref ,sym-name) ,args)))))
 861                   ;; Define it as a symbol macro to access to the
 862                   ;; Javascript variable literally.
 863                   (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
 864               (oset symbols name symbol)
 865               (values symbol nil)))))))
 866
 867 (defun symbol-package (symbol)
 868   (unless (symbolp symbol)
 869     (error "it is not a symbol"))
 870   (oget symbol "package"))
 871
 872 (defun export (symbols &optional (package *package*))
 873   (let ((exports (%package-external-symbols package)))
 874     (dolist (symb symbols t)
 875       (oset exports (symbol-name symb) symb))))
 876
 877
 878 (defconstant internal-time-units-per-second 1000)
 879
 880 (defun get-internal-real-time ()
 881   (get-internal-real-time))
 882
 883 (defun get-unix-time ()
 884   (truncate (/ (get-internal-real-time) 1000)))
 885
 886 (defun get-universal-time ()
 887   (+ (get-unix-time) 2208988800))
 888
 889 (defun concat (&rest strs)
 890   (!reduce #'concat-two strs :initial-value ""))
 891
 892 (defun values-list (list)
 893   (values-array (list-to-vector list)))
 894
 895 (defun values (&rest args)
 896   (values-list args))