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 &key (test #'eql))
 557   (while alist
 558     (if (funcall test 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 equal (x y)
 569   (cond
 570     ((eql x y) t)
 571     ((consp x)
 572      (and (consp y)
 573           (equal (car x) (car y))
 574           (equal (cdr x) (cdr y))))
 575     ((arrayp x)
 576      (and (arrayp y)
 577           (let ((n (length x)))
 578             (when (= (length y) n)
 579               (dotimes (i n)
 580                 (unless (equal (aref x i) (aref y i))
 581                   (return-from equal nil)))
 582               t))))
 583     (t nil)))
 584
 585 (defun string= (s1 s2)
 586   (equal s1 s2))
 587
 588 (defun fdefinition (x)
 589   (cond
 590     ((functionp x)
 591      x)
 592     ((symbolp x)
 593      (symbol-function x))
 594     (t
 595      (error "Invalid function"))))
 596
 597 (defun disassemble (function)
 598   (write-line (lambda-code (fdefinition function)))
 599   nil)
 600
 601 (defun documentation (x type)
 602   "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
 603   (ecase type
 604     (function
 605      (let ((func (fdefinition x)))
 606        (oget func "docstring")))
 607     (variable
 608      (unless (symbolp x)
 609        (error "Wrong argument type! it should be a symbol"))
 610      (oget x "vardoc"))))
 611
 612 (defmacro multiple-value-bind (variables value-from &body body)
 613   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
 614                           ,@body)
 615      ,value-from))
 616
 617 (defmacro multiple-value-list (value-from)
 618   `(multiple-value-call #'list ,value-from))
 619
 620
 621 ;;; Generalized references (SETF)
 622
 623 (defvar *setf-expanders* nil)
 624
 625 (defun get-setf-expansion (place)
 626   (if (symbolp place)
 627       (let ((value (gensym)))
 628         (values nil
 629                 nil
 630                 `(,value)
 631                 `(setq ,place ,value)
 632                 place))
 633       (let ((place (ls-macroexpand-1 place)))
 634         (let* ((access-fn (car place))
 635                (expander (cdr (assoc access-fn *setf-expanders*))))
 636           (when (null expander)
 637             (error "Unknown generalized reference."))
 638           (apply expander (cdr place))))))
 639
 640 (defmacro define-setf-expander (access-fn lambda-list &body body)
 641   (unless (symbolp access-fn)
 642     (error "ACCESS-FN must be a symbol."))
 643   `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
 644                 *setf-expanders*)
 645           ',access-fn))
 646
 647 (defmacro setf (&rest pairs)
 648   (cond
 649     ((null pairs)
 650      nil)
 651     ((null (cdr pairs))
 652      (error "Odd number of arguments to setf."))
 653     ((null (cddr pairs))
 654      (let ((place (ls-macroexpand-1 (first pairs)))
 655            (value (second pairs)))
 656        (multiple-value-bind (vars vals store-vars writer-form reader-form)
 657            (get-setf-expansion place)
 658          ;; TODO: Optimize the expansion a little bit to avoid let*
 659          ;; or multiple-value-bind when unnecesary.
 660          `(let* ,(mapcar #'list vars vals)
 661             (multiple-value-bind ,store-vars
 662                 ,value
 663               ,writer-form)))))
 664     (t
 665      `(progn
 666         ,@(do ((pairs pairs (cddr pairs))
 667                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
 668               ((null pairs)
 669                (reverse result)))))))
 670
 671 (define-setf-expander car (x)
 672   (let ((cons (gensym))
 673         (new-value (gensym)))
 674     (values (list cons)
 675             (list x)
 676             (list new-value)
 677             `(progn (rplaca ,cons ,new-value) ,new-value)
 678             `(car ,cons))))
 679
 680 (define-setf-expander cdr (x)
 681   (let ((cons (gensym))
 682         (new-value (gensym)))
 683     (values (list cons)
 684             (list x)
 685             (list new-value)
 686             `(progn (rplacd ,cons ,new-value) ,new-value)
 687             `(car ,cons))))
 688
 689 ;; Incorrect typecase, but used in NCONC.
 690 (defmacro typecase (x &rest clausules)
 691   (let ((value (gensym)))
 692     `(let ((,value ,x))
 693        (cond
 694          ,@(mapcar (lambda (c)
 695                      (if (eq (car c) t)
 696                          `((t ,@(rest c)))
 697                          `((,(ecase (car c)
 698                                     (integer 'integerp)
 699                                     (cons 'consp)
 700                                     (symbol 'symbolp)
 701                                     (array 'arrayp)
 702                                     (string 'stringp)
 703                                     (atom 'atom)
 704                                     (null 'null))
 705                              ,value)
 706                            ,@(or (rest c)
 707                                  (list nil)))))
 708                    clausules)))))
 709
 710 ;; The NCONC function is based on the SBCL's one.
 711 (defun nconc (&rest lists)
 712   (flet ((fail (object)
 713            (error "type-error in nconc")))
 714     (do ((top lists (cdr top)))
 715         ((null top) nil)
 716       (let ((top-of-top (car top)))
 717         (typecase top-of-top
 718           (cons
 719            (let* ((result top-of-top)
 720                   (splice result))
 721              (do ((elements (cdr top) (cdr elements)))
 722                  ((endp elements))
 723                (let ((ele (car elements)))
 724                  (typecase ele
 725                    (cons (rplacd (last splice) ele)
 726                          (setf splice ele))
 727                    (null (rplacd (last splice) nil))
 728                    (atom (if (cdr elements)
 729                              (fail ele)
 730                              (rplacd (last splice) ele))))))
 731              (return result)))
 732           (null)
 733           (atom
 734            (if (cdr top)
 735                (fail top-of-top)
 736                (return top-of-top))))))))
 737
 738 (defun nreconc (x y)
 739   (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
 740        (2nd x 1st)                ; 2nd follows first down the list.
 741        (3rd y 2nd))               ;3rd follows 2nd down the list.
 742       ((atom 2nd) 3rd)
 743     (rplacd 2nd 3rd)))
 744
 745 (defun notany (fn seq)
 746   (not (some fn seq)))
 747
 748
 749 ;; Packages
 750
 751 (defvar *package-list* nil)
 752
 753 (defun list-all-packages ()
 754   *package-list*)
 755
 756 (defun make-package (name &key use)
 757   (let ((package (new))
 758         (use (mapcar #'find-package-or-fail use)))
 759     (oset package "packageName" name)
 760     (oset package "symbols" (new))
 761     (oset package "exports" (new))
 762     (oset package "use" use)
 763     (push package *package-list*)
 764     package))
 765
 766 (defun packagep (x)
 767   (and (objectp x) (in "symbols" x)))
 768
 769 (defun find-package (package-designator)
 770   (when (packagep package-designator)
 771     (return-from find-package package-designator))
 772   (let ((name (string package-designator)))
 773     (dolist (package *package-list*)
 774       (when (string= (package-name package) name)
 775         (return package)))))
 776
 777 (defun find-package-or-fail (package-designator)
 778   (or (find-package package-designator)
 779       (error "Package unknown.")))
 780
 781 (defun package-name (package-designator)
 782   (let ((package (find-package-or-fail package-designator)))
 783     (oget package "packageName")))
 784
 785 (defun %package-symbols (package-designator)
 786   (let ((package (find-package-or-fail package-designator)))
 787     (oget package "symbols")))
 788
 789 (defun package-use-list (package-designator)
 790   (let ((package (find-package-or-fail package-designator)))
 791     (oget package "use")))
 792
 793 (defun %package-external-symbols (package-designator)
 794   (let ((package (find-package-or-fail package-designator)))
 795     (oget package "exports")))
 796
 797 (defvar *common-lisp-package*
 798   (make-package "CL"))
 799
 800 (defvar *js-package*
 801   (make-package "JS"))
 802
 803 (defvar *user-package*
 804   (make-package "CL-USER" :use (list *common-lisp-package*)))
 805
 806 (defvar *keyword-package*
 807   (make-package "KEYWORD"))
 808
 809 (defun keywordp (x)
 810   (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
 811
 812 (defvar *package* *common-lisp-package*)
 813
 814 (defmacro in-package (package-designator)
 815   `(eval-when-compile
 816      (setq *package* (find-package-or-fail ,package-designator))))
 817
 818 ;; This function is used internally to initialize the CL package
 819 ;; with the symbols built during bootstrap.
 820 (defun %intern-symbol (symbol)
 821   (let* ((package
 822           (if (in "package" symbol)
 823               (find-package-or-fail (oget symbol "package"))
 824               *common-lisp-package*))
 825          (symbols (%package-symbols package)))
 826     (oset symbol "package" package)
 827     (when (eq package *keyword-package*)
 828       (oset symbol "value" symbol))
 829     (oset symbols (symbol-name symbol) symbol)))
 830
 831 (defun find-symbol (name &optional (package *package*))
 832   (let* ((package (find-package-or-fail package))
 833          (externals (%package-external-symbols package))
 834          (symbols (%package-symbols package)))
 835     (cond
 836       ((in name externals)
 837        (values (oget externals name) :external))
 838       ((in name symbols)
 839        (values (oget symbols name) :internal))
 840       (t
 841        (dolist (used (package-use-list package) (values nil nil))
 842          (let ((exports (%package-external-symbols used)))
 843            (when (in name exports)
 844              (return (values (oget exports name) :inherit)))))))))
 845
 846 (defun intern (name &optional (package *package*))
 847   (let ((package (find-package-or-fail package)))
 848     (multiple-value-bind (symbol foundp)
 849         (find-symbol name package)
 850       (if foundp
 851           (values symbol foundp)
 852           (let ((symbols (%package-symbols package)))
 853             (oget symbols name)
 854             (let ((symbol (make-symbol name)))
 855               (oset symbol "package" package)
 856               (when (eq package *keyword-package*)
 857                 (oset symbol "value" symbol)
 858                 (export (list symbol) package))
 859               (when (eq package *js-package*)
 860                 (let ((sym-name (symbol-name symbol))
 861                       (args (gensym)))
 862                   ;; Generate a trampoline to call the JS function
 863                   ;; properly. This trampoline is very inefficient,
 864                   ;; but it still works. Ideas to optimize this are
 865                   ;; provide a special lambda keyword
 866                   ;; cl::&rest-vector to avoid list argument
 867                   ;; consing, as well as allow inline declarations.
 868                   (fset symbol
 869                         (eval `(lambda (&rest ,args)
 870                                  (let ((,args (list-to-vector ,args)))
 871                                    (%js-call (%js-vref ,sym-name) ,args)))))
 872                   ;; Define it as a symbol macro to access to the
 873                   ;; Javascript variable literally.
 874                   (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
 875               (oset symbols name symbol)
 876               (values symbol nil)))))))
 877
 878 (defun symbol-package (symbol)
 879   (unless (symbolp symbol)
 880     (error "it is not a symbol"))
 881   (oget symbol "package"))
 882
 883 (defun export (symbols &optional (package *package*))
 884   (let ((exports (%package-external-symbols package)))
 885     (dolist (symb symbols t)
 886       (oset exports (symbol-name symb) symb))))
 887
 888
 889 (defconstant internal-time-units-per-second 1000)
 890
 891 (defun get-internal-real-time ()
 892   (get-internal-real-time))
 893
 894 (defun get-unix-time ()
 895   (truncate (/ (get-internal-real-time) 1000)))
 896
 897 (defun get-universal-time ()
 898   (+ (get-unix-time) 2208988800))
 899
 900 (defun concat (&rest strs)
 901   (!reduce #'concat-two strs :initial-value ""))
 902
 903 (defun values-list (list)
 904   (values-array (list-to-vector list)))
 905
 906 (defun values (&rest args)
 907   (values-list args))