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