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