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