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 ;; JSCL 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 ;; JSCL 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 JSCL.  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   (let ((defmacro-macroexpander
  27          '#'(lambda (form)
  28               (destructuring-bind (name args &body body)
  29                   form
  30                 (let ((whole (gensym)))
  31                   `(eval-when-compile
  32                      (%compile-defmacro ',name
  33                                         '#'(lambda (,whole)
  34                                              (destructuring-bind ,args ,whole
  35                                                ,@body)))))))))
  36     (%compile-defmacro 'defmacro defmacro-macroexpander)))
  37
  38 (defmacro declaim (&rest decls)
  39   `(eval-when-compile
  40      ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
  41
  42 (defmacro defconstant (name value &optional docstring)
  43   `(progn
  44      (declaim (special ,name))
  45      (declaim (constant ,name))
  46      (setq ,name ,value)
  47      ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
  48      ',name))
  49
  50 (defconstant t 't)
  51 (defconstant nil 'nil)
  52 (%js-vset "nil" nil)
  53
  54 (defmacro lambda (args &body body)
  55   `(function (lambda ,args ,@body)))
  56
  57 (defmacro when (condition &body body)
  58   `(if ,condition (progn ,@body) nil))
  59
  60 (defmacro unless (condition &body body)
  61   `(if ,condition nil (progn ,@body)))
  62
  63 (defmacro defvar (name &optional (value nil value-p) docstring)
  64   `(progn
  65      (declaim (special ,name))
  66      ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
  67      ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
  68      ',name))
  69
  70 (defmacro defparameter (name value &optional docstring)
  71   `(progn
  72      (setq ,name ,value)
  73      ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
  74      ',name))
  75
  76 (defmacro defun (name args &rest body)
  77   `(progn
  78      (fset ',name #'(named-lambda ,name ,args ,@body))
  79      ',name))
  80
  81 (defmacro return (&optional value)
  82   `(return-from nil ,value))
  83
  84 (defmacro while (condition &body body)
  85   `(block nil (%while ,condition ,@body)))
  86
  87 (defvar *gensym-counter* 0)
  88 (defun gensym (&optional (prefix "G"))
  89   (setq *gensym-counter* (+ *gensym-counter* 1))
  90   (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
  91
  92 (defun boundp (x)
  93   (boundp x))
  94
  95 (defun fboundp (x)
  96   (fboundp x))
  97
  98 ;; Basic functions
  99 (defun = (x y) (= x y))
 100 (defun * (x y) (* x y))
 101 (defun / (x y) (/ x y))
 102 (defun 1+ (x) (+ x 1))
 103 (defun 1- (x) (- x 1))
 104 (defun zerop (x) (= x 0))
 105
 106 (defun truncate (x &optional (y 1))
 107   (floor (/ x y)))
 108
 109 (defun eql (x y) (eq x y))
 110
 111 (defun not (x) (if x nil t))
 112
 113 ;; Basic macros
 114
 115 (defmacro incf (place &optional (delta 1))
 116   (multiple-value-bind (dummies vals newval setter getter)
 117       (get-setf-expansion place)
 118     (let ((d (gensym)))
 119       `(let* (,@(mapcar #'list dummies vals)
 120               (,d ,delta)
 121                 (,(car newval) (+ ,getter ,d))
 122                 ,@(cdr newval))
 123          ,setter))))
 124
 125 (defmacro decf (place &optional (delta 1))
 126   (multiple-value-bind (dummies vals newval setter getter)
 127       (get-setf-expansion place)
 128     (let ((d (gensym)))
 129       `(let* (,@(mapcar #'list dummies vals)
 130               (,d ,delta)
 131               (,(car newval) (- ,getter ,d))
 132               ,@(cdr newval))
 133          ,setter))))
 134
 135 (defmacro push (x place)
 136   (multiple-value-bind (dummies vals newval setter getter)
 137       (get-setf-expansion place)
 138     (let ((g (gensym)))
 139       `(let* ((,g ,x)
 140               ,@(mapcar #'list dummies vals)
 141               (,(car newval) (cons ,g ,getter))
 142               ,@(cdr newval))
 143          ,setter))))
 144
 145 (defmacro dolist ((var list &optional result) &body body)
 146   (let ((g!list (gensym)))
 147     (unless (symbolp var) (error "`~S' is not a symbol." var))
 148     `(block nil
 149        (let ((,g!list ,list)
 150              (,var nil))
 151          (%while ,g!list
 152                  (setq ,var (car ,g!list))
 153                  (tagbody ,@body)
 154                  (setq ,g!list (cdr ,g!list)))
 155          ,result))))
 156
 157 (defmacro dotimes ((var count &optional result) &body body)
 158   (let ((g!count (gensym)))
 159     (unless (symbolp var) (error "`~S' is not a symbol." var))
 160     `(block nil
 161        (let ((,var 0)
 162              (,g!count ,count))
 163          (%while (< ,var ,g!count)
 164                  (tagbody ,@body)
 165                  (incf ,var))
 166          ,result))))
 167
 168 (defmacro cond (&rest clausules)
 169   (unless (null clausules)
 170     (destructuring-bind (condition &body body)
 171         (first clausules)
 172       (cond
 173         ((eq condition t)
 174          `(progn ,@body))
 175         ((null body)
 176          (let ((test-symbol (gensym)))
 177            `(let ((,test-symbol ,condition))
 178               (if ,test-symbol
 179                   ,test-symbol
 180                   (cond ,@(rest clausules))))))
 181         (t
 182          `(if ,condition
 183               (progn ,@body)
 184               (cond ,@(rest clausules))))))))
 185
 186 (defmacro case (form &rest clausules)
 187   (let ((!form (gensym)))
 188     `(let ((,!form ,form))
 189        (cond
 190          ,@(mapcar (lambda (clausule)
 191                      (destructuring-bind (keys &body body)
 192                          clausule
 193                        (if (or (eq keys 't) (eq keys 'otherwise))
 194                            `(t nil ,@body)
 195                            (let ((keys (if (listp keys) keys (list keys))))
 196                              `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
 197                                nil ,@body)))))
 198                    clausules)))))
 199
 200 (defmacro ecase (form &rest clausules)
 201   (let ((g!form (gensym)))
 202     `(let ((,g!form ,form))
 203        (case ,g!form
 204          ,@(append
 205             clausules
 206             `((t
 207                (error "ECASE expression failed for the object `~S'." ,g!form))))))))
 208
 209 (defmacro and (&rest forms)
 210   (cond
 211     ((null forms)
 212      t)
 213     ((null (cdr forms))
 214      (car forms))
 215     (t
 216      `(if ,(car forms)
 217           (and ,@(cdr forms))
 218           nil))))
 219
 220 (defmacro or (&rest forms)
 221   (cond
 222     ((null forms)
 223      nil)
 224     ((null (cdr forms))
 225      (car forms))
 226     (t
 227      (let ((g (gensym)))
 228        `(let ((,g ,(car forms)))
 229           (if ,g ,g (or ,@(cdr forms))))))))
 230
 231 (defmacro prog1 (form &body body)
 232   (let ((value (gensym)))
 233     `(let ((,value ,form))
 234        ,@body
 235        ,value)))
 236
 237 (defmacro prog2 (form1 result &body body)
 238   `(prog1 (progn ,form1 ,result) ,@body))
 239
 240 (defmacro prog (inits &rest body )
 241   (multiple-value-bind (forms decls docstring) (parse-body body)
 242     `(block nil
 243        (let ,inits
 244          ,@decls
 245          (tagbody ,@forms)))))
 246
 247
 248 ;;; Go on growing the Lisp language in Ecmalisp, with more high level
 249 ;;; utilities as well as correct versions of other constructions.
 250
 251 (defun + (&rest args)
 252   (let ((r 0))
 253     (dolist (x args r)
 254       (incf r x))))
 255
 256 (defun - (x &rest others)
 257   (if (null others)
 258       (- x)
 259       (let ((r x))
 260         (dolist (y others r)
 261           (decf r y)))))
 262
 263 (defun append-two (list1 list2)
 264   (if (null list1)
 265       list2
 266       (cons (car list1)
 267             (append (cdr list1) list2))))
 268
 269 (defun append (&rest lists)
 270   (!reduce #'append-two lists nil))
 271
 272 (defun revappend (list1 list2)
 273   (while list1
 274     (push (car list1) list2)
 275     (setq list1 (cdr list1)))
 276   list2)
 277
 278 (defun reverse (list)
 279   (revappend list '()))
 280
 281 (defmacro psetq (&rest pairs)
 282   (let (;; For each pair, we store here a list of the form
 283         ;; (VARIABLE GENSYM VALUE).
 284         (assignments '()))
 285     (while t
 286       (cond
 287         ((null pairs) (return))
 288         ((null (cdr pairs))
 289          (error "Odd paris in PSETQ"))
 290         (t
 291          (let ((variable (car pairs))
 292                (value (cadr pairs)))
 293            (push `(,variable ,(gensym) ,value)  assignments)
 294            (setq pairs (cddr pairs))))))
 295     (setq assignments (reverse assignments))
 296     ;;
 297     `(let ,(mapcar #'cdr assignments)
 298        (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
 299
 300 (defmacro do (varlist endlist &body body)
 301   `(block nil
 302      (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
 303        (while t
 304          (when ,(car endlist)
 305            (return (progn ,@(cdr endlist))))
 306          (tagbody ,@body)
 307          (psetq
 308           ,@(apply #'append
 309                    (mapcar (lambda (v)
 310                              (and (consp (cddr v))
 311                                   (list (first v) (third v))))
 312                            varlist)))))))
 313
 314 (defmacro do* (varlist endlist &body body)
 315   `(block nil
 316      (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
 317        (while t
 318          (when ,(car endlist)
 319            (return (progn ,@(cdr endlist))))
 320          (tagbody ,@body)
 321          (setq
 322           ,@(apply #'append
 323                    (mapcar (lambda (v)
 324                              (and (consp (cddr v))
 325                                   (list (first v) (third v))))
 326                            varlist)))))))
 327
 328 (defun list-length (list)
 329   (let ((l 0))
 330     (while (not (null list))
 331       (incf l)
 332       (setq list (cdr list)))
 333     l))
 334
 335 (defun length (seq)
 336   (cond
 337     ((stringp seq)
 338      (string-length seq))
 339     ((arrayp seq)
 340      (oget seq "length"))
 341     ((listp seq)
 342      (list-length seq))))
 343
 344 (defun concat-two (s1 s2)
 345   (concat-two s1 s2))
 346
 347 (defmacro with-collect (&body body)
 348   (let ((head (gensym))
 349         (tail (gensym)))
 350     `(let* ((,head (cons 'sentinel nil))
 351             (,tail ,head))
 352        (flet ((collect (x)
 353                 (rplacd ,tail (cons x nil))
 354                 (setq ,tail (cdr ,tail))
 355                 x))
 356          ,@body)
 357        (cdr ,head))))
 358
 359
 360 (defmacro loop (&body body)
 361   `(while t ,@body))
 362
 363 (defun identity (x) x)
 364
 365 (defun complement (x)
 366   (lambda (&rest args)
 367     (not (apply x args))))
 368
 369 (defun constantly (x)
 370   (lambda (&rest args)
 371     x))
 372
 373 (defun code-char (x)
 374   (code-char x))
 375
 376 (defun char-code (x)
 377   (char-code x))
 378
 379 (defun char= (x y)
 380   (eql x y))
 381
 382 (defun integerp (x)
 383   (and (numberp x) (= (floor x) x)))
 384
 385 (defun floatp (x)
 386   (and (numberp x) (not (integerp x))))
 387
 388 (defun plusp (x) (< 0 x))
 389 (defun minusp (x) (< x 0))
 390
 391 (defun atom (x)
 392   (not (consp x)))
 393
 394 (defun alpha-char-p (x)
 395   (or (<= (char-code #\a) (char-code x) (char-code #\z))
 396       (<= (char-code #\A) (char-code x) (char-code #\Z))))
 397
 398 (defun digit-char-p (x)
 399   (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
 400       (- (char-code x) (char-code #\0))
 401       nil))
 402
 403 (defun digit-char (weight)
 404   (and (<= 0 weight 9)
 405        (char "0123456789" weight)))
 406
 407 (defun equal (x y)
 408   (cond
 409     ((eql x y) t)
 410     ((consp x)
 411      (and (consp y)
 412           (equal (car x) (car y))
 413           (equal (cdr x) (cdr y))))
 414     ((stringp x)
 415      (and (stringp y) (string= x y)))
 416     (t nil)))
 417
 418 (defun fdefinition (x)
 419   (cond
 420     ((functionp x)
 421      x)
 422     ((symbolp x)
 423      (symbol-function x))
 424     (t
 425      (error "Invalid function `~S'." x))))
 426
 427 (defun disassemble (function)
 428   (write-line (lambda-code (fdefinition function)))
 429   nil)
 430
 431 (defun documentation (x type)
 432   "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
 433   (ecase type
 434     (function
 435      (let ((func (fdefinition x)))
 436        (oget func "docstring")))
 437     (variable
 438      (unless (symbolp x)
 439        (error "The type of documentation `~S' is not a symbol." type))
 440      (oget x "vardoc"))))
 441
 442 (defmacro multiple-value-bind (variables value-from &body body)
 443   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
 444                           ,@body)
 445      ,value-from))
 446
 447 (defmacro multiple-value-list (value-from)
 448   `(multiple-value-call #'list ,value-from))
 449
 450
 451 ;;; Generalized references (SETF)
 452
 453 (defvar *setf-expanders* nil)
 454
 455 (defun get-setf-expansion (place)
 456   (if (symbolp place)
 457       (let ((value (gensym)))
 458         (values nil
 459                 nil
 460                 `(,value)
 461                 `(setq ,place ,value)
 462                 place))
 463       (let ((place (!macroexpand-1 place)))
 464         (let* ((access-fn (car place))
 465                (expander (cdr (assoc access-fn *setf-expanders*))))
 466           (when (null expander)
 467             (error "Unknown generalized reference."))
 468           (apply expander (cdr place))))))
 469
 470 (defmacro define-setf-expander (access-fn lambda-list &body body)
 471   (unless (symbolp access-fn)
 472     (error "ACCESS-FN `~S' must be a symbol." access-fn))
 473   `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
 474                 *setf-expanders*)
 475           ',access-fn))
 476
 477 (defmacro setf (&rest pairs)
 478   (cond
 479     ((null pairs)
 480      nil)
 481     ((null (cdr pairs))
 482      (error "Odd number of arguments to setf."))
 483     ((null (cddr pairs))
 484      (let ((place (!macroexpand-1 (first pairs)))
 485            (value (second pairs)))
 486        (multiple-value-bind (vars vals store-vars writer-form)
 487            (get-setf-expansion place)
 488          ;; TODO: Optimize the expansion a little bit to avoid let*
 489          ;; or multiple-value-bind when unnecesary.
 490          `(let* ,(mapcar #'list vars vals)
 491             (multiple-value-bind ,store-vars
 492                 ,value
 493               ,writer-form)))))
 494     (t
 495      `(progn
 496         ,@(do ((pairs pairs (cddr pairs))
 497                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
 498               ((null pairs)
 499                (reverse result)))))))
 500
 501 ;; Incorrect typecase, but used in NCONC.
 502 (defmacro typecase (x &rest clausules)
 503   (let ((value (gensym)))
 504     `(let ((,value ,x))
 505        (cond
 506          ,@(mapcar (lambda (c)
 507                      (if (eq (car c) t)
 508                          `((t ,@(rest c)))
 509                          `((,(ecase (car c)
 510                                     (integer 'integerp)
 511                                     (cons 'consp)
 512                                     (symbol 'symbolp)
 513                                     (array 'arrayp)
 514                                     (string 'stringp)
 515                                     (atom 'atom)
 516                                     (null 'null))
 517                              ,value)
 518                            ,@(or (rest c)
 519                                  (list nil)))))
 520                    clausules)))))
 521
 522 (defmacro etypecase (x &rest clausules)
 523   (let ((g!x (gensym)))
 524     `(let ((,g!x ,x))
 525        (typecase ,g!x
 526          ,@clausules
 527          (t (error "~X fell through etypeacase expression." ,g!x))))))
 528
 529 (defun notany (fn seq)
 530   (not (some fn seq)))
 531
 532 (defconstant internal-time-units-per-second 1000)
 533
 534 (defun get-internal-real-time ()
 535   (get-internal-real-time))
 536
 537 (defun get-unix-time ()
 538   (truncate (/ (get-internal-real-time) 1000)))
 539
 540 (defun get-universal-time ()
 541   (+ (get-unix-time) 2208988800))
 542
 543 (defun concat (&rest strs)
 544   (!reduce #'concat-two strs ""))
 545
 546 (defun values-list (list)
 547   (values-array (list-to-vector list)))
 548
 549 (defun values (&rest args)
 550   (values-list args))
 551
 552 (defun error (fmt &rest args)
 553   (%throw (apply #'format nil fmt args)))