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