| 1 | (setq rcs-ucifnc- |
| 2 | "$Header: /usr/lib/lisp/ucifnc.l,v 1.1 83/01/29 18:41:16 jkf Exp $") |
| 3 | |
| 4 | ; |
| 5 | ; There is problems with the ucilisp do being |
| 6 | ; incompatible with maclisp/franz do, |
| 7 | ; The problems with compiling do are gone, but |
| 8 | ; due to these possible problems, the ucilisp do function |
| 9 | ; is in a seperate file ucido.l and users of it |
| 10 | ; should also load that file in at compile time before |
| 11 | ; any call to do (since do is a macro) (and |
| 12 | ; at runtime if do is to be interpreted). |
| 13 | ; |
| 14 | ; This file is meant to be fasl'd or used with liszt -u |
| 15 | ; not to be read in interpretively (the syntax changes |
| 16 | ; will not work in that case. |
| 17 | ; |
| 18 | ; to compile this file do liszt ucifnc.l |
| 19 | ; |
| 20 | ; one who wants to use these functions or compile and run |
| 21 | ; a ucilisp program should do both |
| 22 | ; liszt -u file.l when compiling. |
| 23 | ; and |
| 24 | ; (fasl '/usr/lib/lisp/ucifnc) |
| 25 | ; before loading in and running them |
| 26 | ; programs in lisp. |
| 27 | ; This is because some functions are macros and others are too |
| 28 | ; complicated and need other functions around. |
| 29 | ; Note this file will not load in directly and when fasl'd in will |
| 30 | ; cause the syntax of lisp to change to ucilisp syntax. |
| 31 | ; |
| 32 | (declare (macros t)) |
| 33 | |
| 34 | ; |
| 35 | ; ucilisp (de df dm) declare function macros. |
| 36 | ; |
| 37 | ; (de name args body) -> declare exprs and lexprs. |
| 38 | ; |
| 39 | (defun de macro (l) |
| 40 | `(defun ,@(cdr l))) |
| 41 | |
| 42 | ; |
| 43 | ; (df name args body) -> declare fexprs. |
| 44 | ; |
| 45 | (defun df macro (l) |
| 46 | `(defun ,(cadr l) |
| 47 | fexpr |
| 48 | ,@(cddr l))) |
| 49 | |
| 50 | ; |
| 51 | ; macro's are not compiled except under the same |
| 52 | ; conditions as in franz lisp. |
| 53 | ; (usually just do (declare (macros t)) |
| 54 | ; to have macros also compiled). |
| 55 | ; |
| 56 | ; |
| 57 | ; (dm name args body) -> declare macros. same as (defun name 'macro body) |
| 58 | ; |
| 59 | (defun dm macro (l) |
| 60 | `(defun ,(cadr l) |
| 61 | macro |
| 62 | ,@(cddr l))) |
| 63 | |
| 64 | ; |
| 65 | ; ucilisp let macro. |
| 66 | ; |
| 67 | (eval-when (compile load eval) |
| 68 | (defun let1 (l vars vals body) |
| 69 | (cond ((null l) |
| 70 | (cons (cons 'lambda (cons vars body)) vals)) |
| 71 | (t |
| 72 | (let1 (cddr l) |
| 73 | (cons (car l) vars) |
| 74 | (cons (cadr l) vals) body))))) |
| 75 | |
| 76 | (defun let macro (l) |
| 77 | (let1 (cadr l) nil nil (cddr l))) |
| 78 | |
| 79 | (defun nconc1 macro (l) |
| 80 | `(nconc ,(cadr l) (list ,(caddr l)))) |
| 81 | |
| 82 | (putd 'expandmacro (getd 'macroexpand)) |
| 83 | |
| 84 | ; |
| 85 | ; ucilisp selectq function. (written by jkf) |
| 86 | ; |
| 87 | (def selectq |
| 88 | (macro (form) |
| 89 | ((lambda (x) |
| 90 | `((lambda (,x) |
| 91 | (cond |
| 92 | ,@(maplist |
| 93 | '(lambda (ff) |
| 94 | (cond ((null (cdr ff)) |
| 95 | `(t ,(car ff))) |
| 96 | ((atom (caar ff)) |
| 97 | `((eq ,x ',(caar ff)) |
| 98 | . ,(cdar ff))) |
| 99 | (t |
| 100 | `((memq ,x ',(caar ff)) |
| 101 | . ,(cdar ff))))) |
| 102 | (cddr form)))) |
| 103 | ,(cadr form))) |
| 104 | (gensym 'Z)))) |
| 105 | |
| 106 | ; |
| 107 | ; ucilisp functions which declare read macros. |
| 108 | ; |
| 109 | ; dsm - declare splicing read macro. |
| 110 | ; |
| 111 | (defun dsm macro (l) |
| 112 | `(eval-when (compile load eval) |
| 113 | (setsyntax ',(cadr l) 'splicing ',(caddr l)))) |
| 114 | |
| 115 | ; |
| 116 | ; drm - declare read macro. |
| 117 | ; |
| 118 | (defun drm macro (l) |
| 119 | `(eval-when (compile load eval) |
| 120 | (setsyntax ',(cadr l) 'macro ',(caddr l)))) |
| 121 | |
| 122 | ; |
| 123 | ;(:= a b) -> ucilisp assignment macro. |
| 124 | ; |
| 125 | (defun := macro (expression) |
| 126 | (let (lft (macroexpand (cadr expression)) rgt (caddr expression)) |
| 127 | (cond ((atom lft) |
| 128 | `(setq ,lft ,(subst lft '*-* rgt))) |
| 129 | ((get (car lft) 'set-program) |
| 130 | (cons (get (car lft) 'set-program) |
| 131 | (append (cdr lft) (list (subst lft '*-* rgt)))))))) |
| 132 | |
| 133 | (defprop car rplaca set-program) |
| 134 | (defprop cdr rplacd set-program) |
| 135 | (defprop cadr rplacad set-program) |
| 136 | (defprop cddr rplacdd set-program) |
| 137 | (defprop caddr rplacadd set-program) |
| 138 | (defprop cadddr rplacaddd set-program) |
| 139 | (defprop get get-set-program set-program) |
| 140 | |
| 141 | (defun get-set-program (atm prop val) |
| 142 | (putprop atm val prop)) |
| 143 | |
| 144 | (defun rplacad (exp1 exp2) |
| 145 | (rplaca (cdr exp1) exp2)) |
| 146 | |
| 147 | (defun rplacdd (exp1 exp2) |
| 148 | (rplacd (cdr exp1) exp2)) |
| 149 | |
| 150 | (defun rplacadd (exp1 exp2) |
| 151 | (rplaca (cddr exp1) exp2)) |
| 152 | |
| 153 | (defun rplacaddd (exp1 exp2) |
| 154 | (rplaca (cdddr exp1) exp2)) |
| 155 | |
| 156 | ; |
| 157 | ; ucilisp record-type package to declare records and field extraction |
| 158 | ; macros. |
| 159 | ; |
| 160 | |
| 161 | (declare (special *type*)) |
| 162 | |
| 163 | (defun record-type macro (l) |
| 164 | (let (*type* (cadr l) *flag* (caddr l) slots (car (last l))) |
| 165 | `(progn 'compile |
| 166 | (defun ,*type* |
| 167 | ,(slot-funs-extract slots (and *flag* '(d))) |
| 168 | ,(cond ((null *flag*) (struc-cons-form slots)) |
| 169 | (t (append `(cons ',*flag*) |
| 170 | (list (struc-cons-form slots)))))) |
| 171 | ,(cond (*flag* |
| 172 | (cond ((dtpr *flag*) (setq *flag* *type*))) |
| 173 | `(defun ,(concat 'is- *type*) |
| 174 | macro |
| 175 | (l) |
| 176 | (list 'and (list 'dtpr (cadr l)) |
| 177 | (list 'eq (list 'car (cadr l)) |
| 178 | '',*flag*)))))))) |
| 179 | |
| 180 | (defun slot-funs-extract (slots path) |
| 181 | (cond ((null slots) nil) |
| 182 | ((atom slots) |
| 183 | (eval `(defun ,(concat slots ': *type*) |
| 184 | macro |
| 185 | (l) |
| 186 | (list ',(readlist `(c ,@path r)) |
| 187 | (cadr l)))) |
| 188 | (list slots)) |
| 189 | ((nconc (slot-funs-extract (car slots) (cons 'a path)) |
| 190 | (slot-funs-extract (cdr slots) (cons 'd path)))))) |
| 191 | |
| 192 | (defun struc-cons-form (struc) |
| 193 | (cond ((null struc) nil) |
| 194 | ((atom struc) struc) |
| 195 | (t `(cons ,(struc-cons-form (car struc)) |
| 196 | ,(struc-cons-form (cdr struc)))))) |
| 197 | |
| 198 | (defun some macro (l) |
| 199 | `((lambda (f a) |
| 200 | (prog () |
| 201 | loop |
| 202 | (cond ((null a) (return nil)) |
| 203 | ((funcall f (car a)) |
| 204 | (return a)) |
| 205 | (t (setq a (cdr a)) |
| 206 | (go loop))))) |
| 207 | ,(cadr l) |
| 208 | ,(caddr l))) |
| 209 | |
| 210 | (declare (special vars)) |
| 211 | |
| 212 | (defun for macro (*l*) |
| 213 | (let (vars (vars:for *l*) |
| 214 | args (args:for *l*) |
| 215 | test (test:for *l*) |
| 216 | type (type:for *l*) |
| 217 | body (body:for *l*)) |
| 218 | (cons (make-mapfn vars test type body) |
| 219 | (cons (list 'quote |
| 220 | (make-lambda |
| 221 | vars (add-test test |
| 222 | (make-body vars test type body)))) |
| 223 | args)))) |
| 224 | |
| 225 | (defun type:for (*l*) |
| 226 | (let (item (item:for '(do save splice filter) *l*)) |
| 227 | (cond (item (car item)) |
| 228 | ((error '"No body in for loop"))))) |
| 229 | |
| 230 | (defun error (l &optional x) |
| 231 | (cond (x (terpri) (patom l) (terpri) (drain) (break) l) |
| 232 | (t l))) |
| 233 | |
| 234 | (defun vars:for (*m*) |
| 235 | (mapcan '(lambda (x) (cond ((is-var-form x) (list (var:var-form x))))) *m*)) |
| 236 | |
| 237 | (defun args:for (*n*) |
| 238 | (mapcan '(lambda (x) |
| 239 | (cond ((is-var-form x) (list (args:var-form x))))) |
| 240 | *n*)) |
| 241 | |
| 242 | (defun is-var-form (x) (and (eq (length x) 3) (eq (cadr x) 'in))) |
| 243 | |
| 244 | (defun var:var-form (x) (car x)) |
| 245 | (defun args:var-form (x) (caddr x)) |
| 246 | |
| 247 | (defun test:for (*o*) |
| 248 | (let (item (item:for '(when) *o*)) |
| 249 | (cond (item (cadr item))))) |
| 250 | |
| 251 | (defun body:for (*p*) |
| 252 | (let (item (item:for '(do save splice filter) *p*)) |
| 253 | (cond ((not item) (error '"NO body in for loop")) |
| 254 | ((eq (length (cdr item)) 1) (cadr item)) |
| 255 | ((cons 'progn (cdr item)))))) |
| 256 | |
| 257 | (declare (special *l* item)) |
| 258 | |
| 259 | (defun item:for (keywords *l*) |
| 260 | (let (item nil) |
| 261 | (some '(lambda (key) (setq item (assoc key (cdr *l*)))) |
| 262 | keywords) |
| 263 | item)) |
| 264 | |
| 265 | (defun make-mapfn (vars test type body) |
| 266 | (cond ((equal type 'do) 'mapc) |
| 267 | ((not (equal type 'save)) 'mapcan) |
| 268 | ((null test) 'mapcar) |
| 269 | ((subset-test vars body) 'subset) |
| 270 | ('mapcan))) |
| 271 | |
| 272 | (defun subset-test (vars body) |
| 273 | (and (equal (length vars) 1) (equal (car vars) body))) |
| 274 | |
| 275 | (defun make-body (vars test type body) |
| 276 | (cond ((equal type 'filter) |
| 277 | (list 'let (list 'x body) '(cond (x (list x))))) |
| 278 | ((or (not (equal type 'save)) (null test)) body) |
| 279 | ((subset-test vars body) nil) |
| 280 | ((list 'list body)))) |
| 281 | |
| 282 | (defun add-test (test body) |
| 283 | (cond ((null test) body) |
| 284 | ((null body) test) |
| 285 | (t (list 'cond (cond ((eq (car body) 'progn) (cons test (cdr body))) |
| 286 | ((list test body))))))) |
| 287 | |
| 288 | (defun make-lambda (var body) |
| 289 | (cond ((equal var (cdr body)) (car body)) |
| 290 | ((eq (car body) 'progn) (cons 'lambda (cons vars (cdr body)))) |
| 291 | ((list 'lambda vars body)))) |
| 292 | |
| 293 | (defun pop macro (q) |
| 294 | `(prog (*q*) |
| 295 | (setq *q* (car ,(cadr q))) |
| 296 | (setq ,(cadr q) (cdr ,(cadr q))) |
| 297 | (return *q*))) |
| 298 | |
| 299 | (defun length (*u*) |
| 300 | (cond ((null *u*) 0) |
| 301 | ((atom *u*) 0) |
| 302 | ((add1 (length (cdr *u*)))))) |
| 303 | |
| 304 | (declare (special l)) |
| 305 | |
| 306 | (defun every macro (l) |
| 307 | `(prog ($$k $v) |
| 308 | (setq $$k ,(caddr l)) |
| 309 | loop |
| 310 | (cond ((null $$k) |
| 311 | (return t)) |
| 312 | ((apply ,(cadr l) (list (car $$k))) |
| 313 | (setq $$k (cdr $$k)) |
| 314 | (go loop))) |
| 315 | (return nil))) |
| 316 | |
| 317 | (defun timer fexpr (request) |
| 318 | (prog (timein timeout result cpu garbage) |
| 319 | (setq timein (ptime)) |
| 320 | (prog () |
| 321 | loop (setq result (eval (car request))) |
| 322 | (setq request (cdr request)) |
| 323 | (cond ((null request) (return result)) |
| 324 | ((go loop)))) |
| 325 | (setq timeout (ptime)) |
| 326 | (setq cpu (quotient (times 1000.0 |
| 327 | (quotient (difference (car timeout) |
| 328 | (car timein)) |
| 329 | 60.0)) |
| 330 | 1000.0)) |
| 331 | (setq garbage (quotient (times 1000.0 |
| 332 | (quotient (difference (cadr timeout) |
| 333 | (cadr timein)) |
| 334 | 60.0)) |
| 335 | 1000.0)) |
| 336 | (print (cons cpu garbage)) |
| 337 | (terpri) |
| 338 | (return result))) |
| 339 | |
| 340 | (defun addprop (id value prop) |
| 341 | (putprop id (enter value (get id prop)) prop)) |
| 342 | |
| 343 | (defun enter (v l) |
| 344 | (cond ((member v l) l) |
| 345 | (t (cons v l)))) |
| 346 | |
| 347 | (defmacro subset (fun lis) |
| 348 | `(mapcan '(lambda (ele) |
| 349 | (cond ((funcall ,fun ele) (ncons ele)))) |
| 350 | ,lis)) |
| 351 | |
| 352 | (defun push macro (varval) |
| 353 | `(setq ,(cadr varval) |
| 354 | (cons ,(caddr varval) |
| 355 | ,(cadr varval)))) |
| 356 | |
| 357 | (putd 'consp (getd 'dtpr)) |
| 358 | |
| 359 | (defun prelist (a b) |
| 360 | (cond ((null a) nil) |
| 361 | ((eq b 0) nil) |
| 362 | ((cons (car a) (prelist (cdr a) (sub1 b)))))) |
| 363 | |
| 364 | (defun suflist (a b) |
| 365 | (cond ((null a) nil) |
| 366 | ((eq b 0) a) |
| 367 | ((suflist (cdr a) (sub1 b))))) |
| 368 | |
| 369 | (defun loop macro (l) |
| 370 | `(prog ,(var-list (get-keyword 'initial l)) |
| 371 | ,@(subset (function caddr) |
| 372 | (setq-steps (get-keyword 'initial l))) |
| 373 | loop |
| 374 | ,@(apply (function append) (mapcar (function do-clause) (cdr l))) |
| 375 | (go loop) |
| 376 | exit |
| 377 | (return ,@(get-keyword 'result l)))) |
| 378 | |
| 379 | (defun do-clause (clause) |
| 380 | (cond ((memq (car clause) '(initial result)) nil) |
| 381 | ((eq (car clause) 'while) |
| 382 | (list (list 'or (cadr clause) '(go exit)))) |
| 383 | ((eq (car clause) 'do) (cdr clause)) |
| 384 | ((eq (car clause) 'next) (setq-steps (cdr clause))) |
| 385 | ((eq (car clause) 'until) |
| 386 | (list (list 'and (cadr clause) '(go exit)))) |
| 387 | (t (terpri) (patom '"unknown keyword clause") |
| 388 | (patom (car clause)) |
| 389 | (terpri)))) |
| 390 | |
| 391 | (defun get-keyword (key l) |
| 392 | (cdr (assoc key (cdr l)))) |
| 393 | |
| 394 | (defun var-list (r) |
| 395 | (and r (cons (car r) (var-list (cddr r))))) |
| 396 | |
| 397 | (defun setq-steps (s) |
| 398 | (and s (cons (list 'setq (car s) (cadr s)) |
| 399 | (setq-steps (cddr s))))) |
| 400 | |
| 401 | (putd 'readch (getd 'readc)) |
| 402 | |
| 403 | |
| 404 | ; |
| 405 | ; ucilisp msg function. (written by jkf) |
| 406 | ; |
| 407 | (defmacro msg ( &rest body) |
| 408 | `(progn ,@(mapcar |
| 409 | '(lambda (form) |
| 410 | (cond ((eq form t) '(line-feed 1)) |
| 411 | ((numberp form) |
| 412 | (cond ((greaterp form 0) |
| 413 | `(msg-space ,form)) |
| 414 | (t `(line-feed ,(minus form))))) |
| 415 | ((atom form) `(patom ,form)) |
| 416 | ((eq (car form) t) '(patom '/ )) |
| 417 | ((eq (car form) 'e) |
| 418 | `(patom ,(cadr form))) |
| 419 | (t `(patom ,form)))) |
| 420 | body))) |
| 421 | |
| 422 | ; |
| 423 | ; this must be fixed to not use do. |
| 424 | ; |
| 425 | (defmacro msg-space (n) |
| 426 | (cond ((eq 1 n) '(patom '" ")) |
| 427 | (t `(do i ,n (sub1 i) (lessp i 1) (patom '/ ))))) |
| 428 | |
| 429 | (defmacro line-feed (n) |
| 430 | (cond ((eq 1 n) '(terpr)) |
| 431 | (t `(do i ,n (sub1 i) (lessp i 1) (terpr))))) |
| 432 | |
| 433 | (defmacro prog1 ( first &rest rest &aux (foo (gensym))) |
| 434 | `((lambda (,foo) ,@rest ,foo) ,first)) |
| 435 | |
| 436 | (defun append1 (l x) (append l (list x))) |
| 437 | |
| 438 | ; compatability functions: functions required by uci lisp but not |
| 439 | ; present in franz |
| 440 | ; |
| 441 | ; union uses the franz do loop (not the ucilisp one defined in this file). |
| 442 | ; |
| 443 | |
| 444 | (def union |
| 445 | (lexpr (n) |
| 446 | (do ((res (arg n)) |
| 447 | (i (sub1 n) (sub1 i))) |
| 448 | ((zerop i) res) |
| 449 | (mapc '(lambda (arg) |
| 450 | (cond ((not (member arg res)) |
| 451 | (setq res (cons arg res))))) |
| 452 | (arg i))))) |
| 453 | |
| 454 | |
| 455 | (putd 'newsym (getd 'gensym)) ; this is not exactly correct. |
| 456 | ; it only uses the first letter of the arg. |
| 457 | (putd 'remove (getd 'delete)) |
| 458 | |
| 459 | ; ignore column count |
| 460 | (def sprint |
| 461 | (lambda (form column) |
| 462 | ($prpr form))) |
| 463 | |
| 464 | (def save (lambda (f) (putprop f (getd f) 'olddef))) |
| 465 | |
| 466 | (def unsave |
| 467 | (lambda (f) |
| 468 | (putd f (get f 'olddef)))) |
| 469 | |
| 470 | (putd 'atcat (getd 'concat)) |
| 471 | (putd 'consp (getd 'dtpr)) |
| 472 | |
| 473 | (defun neq macro (x) |
| 474 | `(not (eq ,@(cdr x)))) |
| 475 | |
| 476 | (putd 'gt (getd '>)) |
| 477 | (putd 'lt (getd '<)) |
| 478 | |
| 479 | (defun le macro (x) |
| 480 | `(not (> ,@(cdr x)))) |
| 481 | |
| 482 | (defun ge macro (x) |
| 483 | `(not (< ,@(cdr x)))) |
| 484 | |
| 485 | (defun litatom macro (x) |
| 486 | `(and (atom ,@(cdr x)) |
| 487 | (not (numberp ,@(cdr x))))) |
| 488 | |
| 489 | (putd 'apply\# (getd 'apply)) |
| 490 | |
| 491 | (defun tconc (ptr x) |
| 492 | (cond ((null ptr) |
| 493 | (prog (temp) |
| 494 | (setq temp (list x)) |
| 495 | (return (setq ptr (cons temp (last temp)))))) |
| 496 | ((null (car ptr)) |
| 497 | (rplaca ptr (list x)) |
| 498 | (rplacd ptr (last (car ptr))) |
| 499 | ptr) |
| 500 | (t (prog (temp) |
| 501 | (setq temp (cdr ptr)) |
| 502 | (rplacd (cdr ptr) (list x)) |
| 503 | (rplacd ptr (cdr temp)) |
| 504 | (return ptr))))) |
| 505 | |
| 506 | ; |
| 507 | ; unbound - (setq x (unbound)) will unbind x. |
| 508 | ; "this [code] is sick" - jkf. |
| 509 | ; |
| 510 | (defun unbound macro (l) |
| 511 | `(fake -4)) |
| 512 | |
| 513 | ; |
| 514 | ; |
| 515 | ; due to problems with franz do in the compiler, this |
| 516 | ; has been commented out and is left in a seperate |
| 517 | ; file called /usr/lib/lisp/ucido.l |
| 518 | ; |
| 519 | ;(defun do macro (l) |
| 520 | ; ((lambda (dotype alist) |
| 521 | ; (selectq dotype |
| 522 | ; (while (dowhile (car alist) (cdr alist))) |
| 523 | ; (until (dowhile (list 'not (car alist)) |
| 524 | ; (cdr alist))) |
| 525 | ; (for (dofor (car alist) |
| 526 | ; (cadr alist) |
| 527 | ; (caddr alist) |
| 528 | ; (cdddr alist))) |
| 529 | ; `((lambda () |
| 530 | ; ,@alist)))) |
| 531 | ; (cadr l) |
| 532 | ; (cddr l))) |
| 533 | ; |
| 534 | ;(defun dowhile (expr alist) |
| 535 | ; `(prog (returnvar) |
| 536 | ; loop |
| 537 | ; (cond (,expr |
| 538 | ; (setq returnvar ((lambda () |
| 539 | ; ,@alist))) |
| 540 | ; (go loop)) |
| 541 | ; (t (return returnvar))))) |
| 542 | ; |
| 543 | ;(defun dofor (var fortype varlist stmlist) |
| 544 | ; (selectq fortype |
| 545 | ; (in `(prog (returnvar l1 l2) |
| 546 | ; (setq l2 ',varlist) |
| 547 | ; loop |
| 548 | ; (setq l1 (car l2)) |
| 549 | ; (setq l2 (cdr l2)) |
| 550 | ; (cond ((null l1) |
| 551 | ; (return returnvar))) |
| 552 | ; (setq returnvar |
| 553 | ; ((lambda (,var) |
| 554 | ; ,@stmlist) |
| 555 | ; (l1))) |
| 556 | ; (go loop))) |
| 557 | ; (on `(prog (returnvar l1 l2) |
| 558 | ; (setq l2 ',varlist) |
| 559 | ; loop |
| 560 | ; (cond ((null l2) |
| 561 | ; (return returnvar))) |
| 562 | ; (setq returnvar |
| 563 | ; ((lambda (,var) |
| 564 | ; ,@stmlist) |
| 565 | ; (l2))) |
| 566 | ; (setq l2 (cdr l2)) |
| 567 | ; (go loop))) |
| 568 | ; (rpt `(prog (returnvar ,var) |
| 569 | ; (setq ,var 1) |
| 570 | ; loop |
| 571 | ; (cond ((not (> ,var ,varlist)) |
| 572 | ; (setq returnvar ((lambda () |
| 573 | ; ,@stmlist))) |
| 574 | ; (setq ,var (1+ ,var)) |
| 575 | ; (go loop)) |
| 576 | ; (t (return returnvar))))) |
| 577 | ; nil)) |
| 578 | ; |
| 579 | (putd 'dddd* (getd 'boundp)) |
| 580 | (defun boundp (l) |
| 581 | (cond ((arrayp l)) |
| 582 | ((dddd* l)))) |
| 583 | |
| 584 | ; |
| 585 | ; now change to ucilisp syntax. |
| 586 | ; |
| 587 | (sstatus uctolc t) |
| 588 | ; |
| 589 | ; Leave backquote macro in for now. |
| 590 | ; These characters should be declared as follows for real |
| 591 | ; ucilisp syntax though. |
| 592 | ;(setsyntax '\` 2) |
| 593 | ;(setsyntax '\, 2) |
| 594 | ;(setsyntax '\@ 201) |
| 595 | ;(setsyntax '\@ 'macro '(lambda () (list 'quote (read)))) |
| 596 | ; |
| 597 | ; ~ as comment character, not ; and / instead of \ for escape |
| 598 | (setsyntax '\~ 'splicing 'zapline) |
| 599 | (setsyntax '\; 2) |
| 600 | (setsyntax '\# 2) |
| 601 | (setsyntax '\/ 143) |
| 602 | (setsyntax '\\ 2) |
| 603 | (setsyntax '\! 2) |