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