1;;; 2;;; libio.scm - builtin port and I/O procedures 3;;; 4;;; Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34(select-module gauche.internal) 35 36(inline-stub 37 (declcode (.include <gauche/vminsn.h> 38 <gauche/class.h> 39 <gauche/exception.h> 40 <gauche/priv/portP.h> 41 <gauche/priv/writerP.h> 42 <stdlib.h> 43 <fcntl.h>))) 44 45;;; 46;;; Ports 47;;; 48 49;; 50;; Predicates 51;; 52 53(select-module scheme) 54(define-cproc input-port? (obj) ::<boolean> SCM_IPORTP) 55(define-cproc output-port? (obj) ::<boolean> SCM_OPORTP) 56(define-cproc port? (obj) ::<boolean> SCM_PORTP) 57 58(select-module gauche) 59(define-cproc port-closed? (obj::<port>) ::<boolean> SCM_PORT_CLOSED_P) 60 61;; 62;; Preexisting ports 63;; 64 65(select-module scheme) 66 67(define-cproc current-input-port (:optional newport) 68 (cond [(SCM_IPORTP newport) 69 (return (Scm_SetCurrentInputPort (SCM_PORT newport)))] 70 [(not (SCM_UNBOUNDP newport)) 71 (Scm_TypeError "current-input-port" "input port" newport) 72 (return SCM_UNDEFINED)] 73 [else (return (SCM_OBJ SCM_CURIN))])) 74 75(define-cproc current-output-port (:optional newport) 76 (cond [(SCM_OPORTP newport) 77 (return (Scm_SetCurrentOutputPort (SCM_PORT newport)))] 78 [(not (SCM_UNBOUNDP newport)) 79 (Scm_TypeError "current-output-port" "output port" newport) 80 (return SCM_UNDEFINED)] 81 [else (return (SCM_OBJ SCM_CUROUT))])) 82 83(select-module gauche) 84 85(define-cproc current-error-port (:optional newport) 86 (cond 87 [(SCM_OPORTP newport) (return (Scm_SetCurrentErrorPort (SCM_PORT newport)))] 88 [(not (SCM_UNBOUNDP newport)) 89 (Scm_TypeError "current-error-port" "output port" newport) 90 (return SCM_UNDEFINED)] 91 [else (return (SCM_OBJ SCM_CURERR))])) 92 93(define-cproc standard-input-port (:optional (p::<input-port>? #f)) 94 (return (?: p (Scm_SetStdin p) (Scm_Stdin)))) 95(define-cproc standard-output-port (:optional (p::<output-port>? #f)) 96 (return (?: p (Scm_SetStdout p) (Scm_Stdout)))) 97(define-cproc standard-error-port (:optional (p::<output-port>? #f)) 98 (return (?: p (Scm_SetStderr p) (Scm_Stderr)))) 99 100(inline-stub 101 (initcode 102 (Scm_BindPrimitiveParameter (Scm_GaucheModule) 103 "current-trace-port" 104 (Scm_Stderr) 0))) 105 106;; 107;; Query and low-level properties 108;; 109 110(select-module gauche) 111 112(define-cproc port-name (port::<port>) Scm_PortName) 113(define-cproc port-current-line (port::<port>) ::<fixnum> Scm_PortLine) 114 115(define-cproc port-file-number (port::<port> :optional (dup?::<boolean> #f)) 116 (let* ([i::int (Scm_PortFileNo port)]) 117 (when (< i 0) (return SCM_FALSE)) 118 (when dup? 119 (let* ([r::int 0]) 120 (SCM_SYSCALL r (dup i)) 121 (when (< r 0) (Scm_SysError "dup(2) failed")) 122 (set! i r))) 123 (return (Scm_MakeInteger i)))) 124(define-cproc port-fd-dup! (dst::<port> src::<port>) ::<void> Scm_PortFdDup) 125 126(define-cproc port-attribute-set! (port::<port> key val) 127 Scm_PortAttrSet) 128(define-cproc port-attribute-ref (port::<port> key :optional fallback) 129 (setter port-attribute-set!) 130 Scm_PortAttrGet) 131(define-cproc port-attribute-create! (port::<port> key 132 :optional (get #f) (set #f)) 133 Scm_PortAttrCreate) 134(define-cproc port-attribute-delete! (port::<port> key) 135 Scm_PortAttrDelete) 136(define-cproc port-attributes (port::<port>) 137 Scm_PortAttrs) 138 139 140(define-cproc port-type (port::<port>) 141 (case (SCM_PORT_TYPE port) 142 [(SCM_PORT_FILE) (return 'file)] 143 [(SCM_PORT_PROC) (return 'proc)] 144 [(SCM_PORT_OSTR SCM_PORT_ISTR) (return 'string)] 145 [else (return '#f)])) 146 147(define-cproc port-buffering (port::<port>) 148 (setter (port::<port> mode) ::<void> 149 (unless (== (SCM_PORT_TYPE port) SCM_PORT_FILE) 150 (Scm_Error "can't set buffering mode to non-buffered port: %S"port)) 151 (Scm_SetPortBufferingMode 152 port (Scm_BufferingMode mode (-> port direction) -1))) 153 (return (Scm_GetPortBufferingModeAsKeyword port))) 154 155(define-cproc port-case-fold-set! (port::<port> flag::<boolean>) ::<void> 156 (if flag 157 (logior= (SCM_PORT_FLAGS port) SCM_PORT_CASE_FOLD) 158 (logand= (SCM_PORT_FLAGS port) (lognot SCM_PORT_CASE_FOLD)))) 159 160;; 161;; Open and close 162;; 163 164(select-module scheme) 165(define-cproc close-input-port (port::<input-port>) ::<void> Scm_ClosePort) 166(define-cproc close-output-port (port::<output-port>) ::<void> Scm_ClosePort) 167(select-module gauche) 168(define-cproc close-port (port::<port>) ::<void> Scm_ClosePort) ;R6RS 169 170(select-module gauche.internal) 171(inline-stub 172 ;; NB: On MinGW, if we try to create a file and a directory with the 173 ;; same name exists, open(2) throws EACCES. Weird, eh? We don't want 174 ;; to catch EACCES on other platforms, hence this dirty trick. 175 (if "defined(GAUCHE_WINDOWS)" 176 "#define DIRECTORY_GETS_IN_WAY(x) ((x)==EACCES)" 177 "#define DIRECTORY_GETS_IN_WAY(x) FALSE") 178 179 ;; Some cise macros for common idioms 180 (define-cise-expr %open/allow-noexist? 181 [(_ if-does-not-exist-is-false) 182 `(and ,if-does-not-exist-is-false 183 (or (== errno ENOENT) 184 (== errno ENODEV) 185 (== errno ENXIO) 186 (== errno ENOTDIR)))]) 187 188 (define-cise-expr %open/allow-exist? 189 [(_ if-exists-is-false) 190 `(and ,if-exists-is-false 191 (or (== errno EEXIST) 192 (== errno ENOTDIR) 193 (DIRECTORY_GETS_IN_WAY errno)))]) 194 ) 195 196;; Primitive open routine. The Scheme wrapper handles other keyword args. 197(define-cproc %open-input-file (path::<string> 198 :key (if-does-not-exist :error) 199 (buffering #f) 200 (element-type :binary)) 201 (let* ([ignerr::int FALSE] 202 [flags::int O_RDONLY]) 203 (cond [(SCM_FALSEP if-does-not-exist) (set! ignerr TRUE)] 204 [(not (SCM_EQ if-does-not-exist ':error)) 205 (Scm_TypeError ":if-does-not-exist" ":error or #f" 206 if-does-not-exist)]) 207 (unless (or (SCM_EQ element-type ':character) 208 (SCM_EQ element-type ':binary)) 209 (Scm_Error "bad element-type argument: either :character or :binary \ 210 expected, but got %S" element-type)) 211 (.if "defined(O_BINARY) && defined(O_TEXT)" 212 (if (SCM_EQ element-type ':character) 213 (logior= flags O_TEXT) 214 (logior= flags O_BINARY))) 215 (let* ([bufmode::int (Scm_BufferingMode buffering SCM_PORT_INPUT 216 SCM_PORT_BUFFER_FULL)] 217 [o (Scm_OpenFilePort (Scm_GetStringConst path) 218 flags bufmode 0)]) 219 (when (and (SCM_FALSEP o) (not (%open/allow-noexist? ignerr))) 220 (Scm_SysError "couldn't open input file: %S" path)) 221 (return o)))) 222 223;; Primitive open routine. The Scheme wrapper handles other keyword args 224(define-cproc %open-output-file (path::<string> 225 :key (if-exists :supersede) 226 (if-does-not-exist :create) 227 (mode::<fixnum> #o666) 228 (buffering #f) 229 (element-type :binary)) 230 (let* ([ignerr-noexist::int FALSE] 231 [ignerr-exist::int FALSE] 232 [flags::int O_WRONLY]) 233 (unless (or (SCM_EQ element-type ':character) 234 (SCM_EQ element-type ':binary)) 235 (Scm_Error "bad element-type argument: either :character or :binary \ 236 expected, but got %S" element-type)) 237 (.if "defined(O_BINARY) && defined(O_TEXT)" 238 (if (SCM_EQ element-type ':character) 239 (logior= flags O_TEXT) 240 (logior= flags O_BINARY))) 241 ;; check if-exists flag 242 (cond 243 [(SCM_EQ if-exists ':append) (logior= flags O_APPEND)] 244 [(SCM_EQ if-exists ':error) 245 (logior= flags O_EXCL) 246 (when (SCM_EQ if-does-not-exist ':error) 247 (Scm_Error "bad flag combination: :if-exists and :if-does-not-exist can't be :error the same time."))] 248 [(SCM_EQ if-exists ':supersede) (logior= flags O_TRUNC)] 249 [(SCM_EQ if-exists ':overwrite)] ; no need to add flags 250 [(SCM_FALSEP if-exists) (logior= flags O_EXCL) (set! ignerr-exist TRUE)] 251 [else 252 (Scm_TypeError ":if-exists" ":supersede, :overwrite, :append, :error or #f" if-exists)]) 253 ;; check if-does-not-exist flag 254 (cond 255 [(SCM_EQ if-does-not-exist ':create) (logior= flags O_CREAT)] 256 [(SCM_FALSEP if-does-not-exist) (set! ignerr-noexist TRUE)] 257 [(SCM_EQ if-does-not-exist ':error)] ; no need to add flags 258 [else (Scm_TypeError ":if-does-not-exist" ":error, :create or #f" 259 if-does-not-exist)]) 260 (let* ([bufmode::int 261 (Scm_BufferingMode buffering SCM_PORT_OUTPUT SCM_PORT_BUFFER_FULL)] 262 [o (Scm_OpenFilePort (Scm_GetStringConst path) 263 flags bufmode mode)]) 264 (when (and (SCM_FALSEP o) 265 (not (%open/allow-noexist? ignerr-noexist)) 266 (not (%open/allow-exist? ignerr-exist))) 267 (Scm_Error "couldn't open output file: %S" path)) 268 (return o)))) 269 270;; Open port from fd 271(select-module gauche) 272 273(define-cproc open-input-fd-port (fd::<fixnum> 274 :key (buffering #f) 275 (owner? #f) 276 (name #f)) 277 (let* ([bufmode::int (Scm_BufferingMode buffering SCM_PORT_INPUT 278 SCM_PORT_BUFFER_FULL)]) 279 (when (< fd 0) (Scm_Error "bad file descriptor: %ld" fd)) 280 (cond 281 [(SCM_EQ owner? 'dup) 282 (let* ([r::int 0]) 283 (SCM_SYSCALL r (dup fd)) 284 (when (< r 0) (Scm_SysError "dup(2) failed")) 285 (set! fd r))] 286 [(not (SCM_BOOLP owner?)) 287 (Scm_Error "owner? argument must be either #f, #t or a symbol dup, \n\ 288 but go t%S" owner?)]) 289 (return (Scm_MakePortWithFd name SCM_PORT_INPUT fd bufmode 290 (not (SCM_FALSEP owner?)))))) 291 292(define-cproc open-output-fd-port (fd::<fixnum> 293 :key (buffering #f) 294 (owner? #f) 295 (name #f)) 296 (let* ([bufmode::int (Scm_BufferingMode buffering SCM_PORT_OUTPUT 297 SCM_PORT_BUFFER_FULL)]) 298 (when (< fd 0) (Scm_Error "bad file descriptor: %d" fd)) 299 (cond 300 [(SCM_EQ owner? 'dup) 301 (let* ([r::int 0]) 302 (SCM_SYSCALL r (dup fd)) 303 (when (< r 0) (Scm_SysError "dup(2) failed")) 304 (set! fd r))] 305 [(not (SCM_BOOLP owner?)) 306 (Scm_Error "owner? argument must be either #f, #t or a symbol dup, \n\ 307 but go t%S" owner?)]) 308 (return (Scm_MakePortWithFd name SCM_PORT_OUTPUT fd bufmode 309 (not (SCM_FALSEP owner?)))))) 310 311;; Buffered port 312(select-module gauche) 313(inline-stub 314 ;; Buffered port 315 ;; NB: the interface may be changed soon!! 316 (define-cfn bufport-closer (p::ScmPort*) ::void :static 317 (when (== (SCM_PORT_DIR p) SCM_PORT_OUTPUT) 318 (let* ((scmflusher (SCM_OBJ (-> (PORT_BUF p) data))) 319 (siz::int (cast int (- (-> (PORT_BUF p) current) 320 (-> (PORT_BUF p) buffer))))) 321 (when (> siz 0) 322 (Scm_ApplyRec1 scmflusher 323 (Scm_MakeString (-> (PORT_BUF p) buffer) siz siz 324 (logior SCM_STRING_INCOMPLETE 325 SCM_STRING_COPYING)))) 326 (Scm_ApplyRec1 scmflusher SCM_FALSE)))) 327 328 (define-cfn bufport-filler (p::ScmPort* cnt::ScmSize) ::ScmSize :static 329 (let* ([scmfiller (SCM_OBJ (-> (PORT_BUF p) data))] 330 [r (Scm_ApplyRec1 scmfiller (Scm_MakeInteger cnt))]) 331 (cond [(or (SCM_EOFP r) (SCM_FALSEP r)) (return 0)] 332 [(not (SCM_STRINGP r)) 333 (Scm_Error "buffered port callback procedure returned non-string: %S" r)]) 334 (let* ([b::(const ScmStringBody*) (SCM_STRING_BODY r)] 335 [siz::ScmSize (SCM_STRING_BODY_SIZE b)]) 336 (when (> siz cnt) (set! siz cnt)) ; for safety 337 (memcpy (-> (PORT_BUF p) end) (SCM_STRING_BODY_START b) siz) 338 (return (SCM_STRING_BODY_SIZE b))))) 339 ) 340 341(define-cproc open-input-buffered-port 342 (filler::<procedure> buffer-size::<fixnum>) 343 (let* ([bufrec::ScmPortBuffer]) 344 (set! (ref bufrec size) buffer-size 345 (ref bufrec buffer) NULL 346 (ref bufrec mode) SCM_PORT_BUFFER_FULL 347 (ref bufrec filler) bufport-filler 348 (ref bufrec flusher) NULL 349 (ref bufrec closer) bufport-closer 350 (ref bufrec ready) NULL 351 (ref bufrec filenum) NULL 352 (ref bufrec data) (cast void* filler)) 353 (return (Scm_MakeBufferedPort SCM_CLASS_PORT SCM_FALSE SCM_PORT_INPUT TRUE (& bufrec))))) 354 355(inline-stub 356 (define-cfn bufport-flusher (p::ScmPort* cnt::ScmSize forcep::int) 357 ::ScmSize :static 358 (cast void forcep) ; suppress unused var warning 359 (let* ([scmflusher (SCM_OBJ (-> (PORT_BUF p) data))] 360 [s (Scm_MakeString (-> (PORT_BUF p) buffer) cnt cnt 361 (logior SCM_STRING_INCOMPLETE SCM_STRING_COPYING))]) 362 (Scm_ApplyRec1 scmflusher s) 363 (return cnt))) 364 ) 365 366(define-cproc open-output-buffered-port 367 (flusher::<procedure> buffer-size::<fixnum>) 368 (let* ([bufrec::ScmPortBuffer]) 369 (set! (ref bufrec size) buffer-size 370 (ref bufrec buffer) NULL 371 (ref bufrec mode) SCM_PORT_BUFFER_FULL 372 (ref bufrec filler) NULL 373 (ref bufrec flusher) bufport-flusher 374 (ref bufrec closer) bufport-closer 375 (ref bufrec ready) NULL 376 (ref bufrec filenum) NULL 377 (ref bufrec data) (cast void* flusher)) 378 (return (Scm_MakeBufferedPort SCM_CLASS_PORT SCM_FALSE SCM_PORT_OUTPUT 379 TRUE (& bufrec))))) 380 381;; String ports (srfi-6) 382;; By default, string ports are named as "(input string port)" and 383;; "(output string port)", which aren't very informative. The caller 384;; can specify alternative name with :name keyword argument. NB: Currently, 385;; port name is assumed to be a pathname if it doesn't match #/^\(.*\)$/. 386;; This convention may be replaced by more reliable mechanism to determine 387;; port source path. Until then, be careful to name the ports. 388(select-module gauche) 389 390(define-cproc open-input-string (string::<string> 391 :key (private?::<boolean> #f) 392 (name "(input string port)")) 393 (let* ([flags::u_long (?: private? SCM_PORT_STRING_PRIVATE 0)]) 394 (return (Scm_MakeInputStringPortFull string name flags)))) 395 396(define-cproc open-output-string (:key (private?::<boolean> #f) 397 (name "(output string port)")) 398 (let* ([flags::u_long (?: private? SCM_PORT_STRING_PRIVATE 0)]) 399 (return (Scm_MakeOutputStringPortFull name flags)))) 400 401(define-cproc get-output-string (oport::<output-port>) ;SRFI-6 402 (return (Scm_GetOutputString oport 0))) 403 404(define-cproc get-output-byte-string (oport::<output-port>) 405 (return (Scm_GetOutputString oport SCM_STRING_INCOMPLETE))) 406 407(define-cproc get-remaining-input-string (iport::<input-port>) 408 (return (Scm_GetRemainingInputString iport 0))) 409 410;; Coding aware port 411(select-module gauche) 412 413(define-cproc open-coding-aware-port (iport::<input-port>) 414 Scm_MakeCodingAwarePort) 415 416;; 417;; Miscellaneous 418;; 419 420;; srfi-191 421(define-cproc port-has-port-position? (port::<port>) ::<boolean> 422 (return (Scm_PortPositionable port FALSE))) 423(define-cproc port-has-set-port-position!? (port::<port>) ::<boolean> 424 (return (Scm_PortPositionable port TRUE))) 425 426(define-cproc port-position (port::<port>) 427 (return (Scm_GetPortPosition port))) 428(define-cproc set-port-position! (port::<port> pos) 429 (return (Scm_SetPortPosition port pos))) 430 431(select-module gauche) 432(inline-stub 433 (define-enum SEEK_SET) 434 (define-enum SEEK_CUR) 435 (define-enum SEEK_END) 436 ) 437 438(define-cproc port-seek 439 (port::<port> offset::<integer> 440 :optional (whence::<fixnum> (c "SCM_MAKE_INT(SEEK_SET)"))) 441 Scm_PortSeek) 442 443;; useful alias 444(define (port-tell p) (port-seek p 0 SEEK_CUR)) 445 446;; useful for error messages 447(define (port-position-prefix port) 448 (if (port? port) 449 (if-let1 n (port-name port) 450 (let1 l (port-current-line port) 451 (if (positive? l) 452 (format #f "~s:line ~a: " n l) 453 (format #f "~s: " n)) 454 "")) 455 "???")) 456 457(select-module gauche.internal) 458 459;; Transient flags during circular/shared-aware writing 460(define-cproc %port-walking? (port::<port>) ::<boolean> 461 (setter (port::<port> flag::<boolean>) ::<void> 462 (if flag 463 (logior= (-> port flags) SCM_PORT_WALKING) 464 (logand= (-> port flags) (lognot SCM_PORT_WALKING)))) 465 PORT_WALKER_P) 466(define-cproc %port-writing-shared? (port::<port>) ::<boolean> 467 (setter (port::<port> flag::<boolean>) ::<void> 468 (if flag 469 (logior= (-> port flags) SCM_PORT_WRITESS) 470 (logand= (-> port flags) (lognot SCM_PORT_WRITESS)))) 471 PORT_WRITESS_P) 472 473(inline-stub 474 (define-cfn write_state_allocate (klass::ScmClass* initargs) :static 475 (cast void klass) ; suppress unused var warning 476 (cast void initargs) ; suppress unused var warning 477 (return (SCM_OBJ (Scm_MakeWriteState NULL)))) 478 479 (define-cfn write_state_print (obj port::ScmPort* ctx::ScmWriteContext*) 480 ::void :static 481 (cast void ctx) ; suppress unused var warning 482 (Scm_Printf port "#<write-state %p>" obj)) 483 484 (define-cclass <write-state> 485 "ScmWriteState*" "Scm_WriteStateClass" 486 ("Scm_TopClass") 487 ((shared-table :type <hash-table>? :c-name "sharedTable") 488 (shared-counter :type <int> :c-name "sharedCounter")) 489 (allocator (c "write_state_allocate")) 490 (printer (c "write_state_print"))) 491 ) 492 493(define-cproc %port-write-state (port::<port>) 494 (setter (port::<port> obj) ::<void> 495 (if (SCM_WRITE_STATE_P obj) 496 (Scm_PortWriteStateSet port (SCM_WRITE_STATE obj)) 497 (Scm_PortWriteStateSet port NULL))) 498 (let* ([r::ScmWriteState* (Scm_PortWriteState port)]) 499 (return (?: r (SCM_OBJ r) SCM_FALSE)))) 500 501(define-cproc %port-lock! (port::<port>) ::<void> 502 (let* ([vm::ScmVM* (Scm_VM)]) 503 (PORT_LOCK port vm))) 504(define-cproc %port-unlock! (port::<port>) ::<void> 505 (PORT_UNLOCK port)) 506 507;; Passing extra args is unusual for with-* style, but it can allow avoiding 508;; closure allocation and may be useful for performance-sensitive parts. 509(define-in-module gauche (with-port-locking port proc . args) 510 (unwind-protect 511 (begin (%port-lock! port) 512 (apply proc args)) 513 (%port-unlock! port))) 514 515(define-in-module gauche.internal ; used by two-pass output 516 (%with-2pass-setup port walker emitter . args) 517 ;; The caller guarantees to call this when port isn't in two-pass 518 ;; mode. We lock the port, and call WALKER with setting the port 519 ;; to 'walking' mode, then call EMITTER with setting the port to 520 ;; 'write-ss' mode. 521 (unwind-protect 522 (begin 523 (%port-lock! port) 524 (when (%port-write-state port) 525 (error "[internal] %with-2pass-setup called recursively on port:" 526 port)) 527 (set! (%port-write-state port) 528 (make <write-state> :shared-table (make-hash-table 'eq?))) 529 (set! (%port-walking? port) #t) 530 (apply walker args) 531 (set! (%port-walking? port) #f) 532 (apply emitter args)) 533 (set! (%port-walking? port) #f) 534 (set! (%port-write-state port) #f) 535 (%port-unlock! port))) 536 537;;; 538;;; Input 539;;; 540 541(select-module scheme) 542 543(define-cproc read (:optional (port::<input-port> (current-input-port))) 544 (return (Scm_Read (SCM_OBJ port)))) 545 546(define-cproc read-char (:optional (port::<input-port> (current-input-port))) 547 (inliner READ-CHAR) 548 (let* ([ch::int]) 549 (SCM_GETC ch port) 550 (return (?: (== ch EOF) SCM_EOF (SCM_MAKE_CHAR ch))))) 551 552(define-cproc peek-char (:optional (port::<input-port> (current-input-port))) 553 (inliner PEEK-CHAR) 554 (let* ([ch::ScmChar (Scm_Peekc port)]) 555 (return (?: (== ch SCM_CHAR_INVALID) SCM_EOF (SCM_MAKE_CHAR ch))))) 556 557(define-cproc eof-object? (obj) ::<boolean> :fast-flonum 558 (inliner EOFP) SCM_EOFP) 559 560(define-cproc char-ready? (:optional (port::<input-port> (current-input-port))) 561 ::<boolean> Scm_CharReady) 562 563 564(select-module gauche) 565 566(define-cproc eof-object () :constant (return SCM_EOF)) ;R6RS 567 568(define-cproc byte-ready? (:optional (port::<input-port> (current-input-port))) 569 ::<boolean> Scm_ByteReady) 570 571(define u8-ready? byte-ready?) ;R7RS 572 573(define-cproc read-byte (:optional (port::<input-port> (current-input-port))) 574 (let* ([b::int]) 575 (SCM_GETB b port) 576 (return (?: (< b 0) SCM_EOF (SCM_MAKE_INT b))))) 577 578(define read-u8 read-byte) ;R7RS 579 580(define-cproc peek-byte (:optional (port::<input-port> (current-input-port))) 581 (let* ([b::int (Scm_Peekb port)]) 582 (return (?: (< b 0) SCM_EOF (SCM_MAKE_INT b))))) 583 584(define peek-u8 peek-byte) ;R7RS 585 586(define-cproc read-line (:optional (port::<input-port> (current-input-port)) 587 (allowbytestr #f)) 588 (let* ([r (Scm_ReadLine port)]) 589 (when (and (SCM_FALSEP allowbytestr) 590 (SCM_STRINGP r) 591 (SCM_STRING_INCOMPLETE_P r)) 592 (Scm_ReadError port "read-line: encountered illegal byte sequence: %S" r)) 593 (return r))) 594 595(define (read-string n :optional (port (current-input-port))) 596 (define o (open-output-string :private? #t)) 597 (let loop ([i 0]) 598 (if (>= i n) 599 (get-output-string o) 600 (let1 c (read-char port) 601 (if (eof-object? c) 602 (if (= i 0) 603 (eof-object) 604 (get-output-string o)) 605 (begin (write-char c o) (loop (+ i 1)))))))) 606 607(define (write-string string :optional (port (current-output-port)) 608 (start 0) 609 (end -1)) 610 (display ((with-module gauche.internal %maybe-substring) string start end) 611 port)) 612 613;; Consume trailing whiespaces up to (including) first EOL. 614;; This is mainly intended for interactive REPL, 615;; where the input is buffered by line. We want to ignore the 616;; trailing newline, so that when the user type (read-line) RET, 617;; we consume that RET and start reading from the fresh line. 618; 619;; We need to be careful not to block; that's why we use binary 620;; input here, since character input may block if the input stop 621;; between a multibyte character. 622;; Note that the 'whitespaces' here only inlucdes #\tab, #\space, 623;; #\return and #\newline. 624(define (consume-trailing-whitespaces :optional (port (current-input-port))) 625 (let loop () 626 (when (byte-ready? port) 627 (let1 b (peek-byte port) 628 (cond [(memv b '(9 32)) (read-byte port) (loop)] ;tab, space 629 [(eqv? b 13) ;cr or crlf 630 (read-byte port) 631 (when (and (byte-ready? port) 632 (eqv? (peek-byte port) 10)) 633 (read-byte port))] 634 [(eqv? b 10) (read-byte port)]))))) ;lf 635 636;; DEPRECATED - read-uvector should be used 637(define-cproc read-block (bytes::<fixnum> 638 :optional (port::<input-port> (current-input-port))) 639 (when (< bytes 0) 640 (Scm_Error "bytes must be non-negative integer: %ld" bytes)) 641 (if (== bytes 0) 642 (return (Scm_MakeString "" 0 0 0)) 643 (let* ([buf::char* (SCM_NEW_ATOMIC2 (C: char*) (+ bytes 1))] 644 [nread::int (Scm_Getz buf bytes port)]) 645 (cond [(<= nread 0) (return SCM_EOF)] 646 [else 647 (SCM_ASSERT (<= nread bytes)) 648 (set! (aref buf nread) #\x00) 649 (return (Scm_MakeString buf nread nread SCM_STRING_INCOMPLETE))] 650 )))) 651 652(define-cproc read-list (closer::<char> 653 :optional (port (current-input-port))) 654 (return (Scm_ReadList port closer))) 655 656(define-cproc port->byte-string (port::<input-port>) 657 (let* ([ds::ScmDString] [buf::(.array char (1024))]) 658 (Scm_DStringInit (& ds)) 659 (loop (let* ([nbytes::int (Scm_Getz buf 1024 port)]) 660 (when (<= nbytes 0) (break)) 661 (Scm_DStringPutz (& ds) buf nbytes))) 662 (return (Scm_DStringGet (& ds) SCM_STRING_INCOMPLETE)))) 663 664(define (port->string port) 665 (let1 out (open-output-string :private? #t) 666 (copy-port port out :unit 'byte) 667 (get-output-string out))) 668 669(define (port->list reader port) 670 (with-port-locking port 671 (^[] 672 (let loop ([obj (reader port)] 673 [result '()]) 674 (if (eof-object? obj) 675 (reverse! result) 676 (loop (reader port) (cons obj result))))))) 677 678(define (port->string-list port) (port->list (cut read-line <> #t) port)) 679(define (port->sexp-list port) (port->list read port)) 680 681;; Reader parameters 682(define-cproc reader-lexical-mode (:optional k) 683 (if (SCM_UNBOUNDP k) 684 (return (Scm_ReaderLexicalMode)) 685 (return (Scm_SetReaderLexicalMode k)))) 686 687(select-module gauche.internal) 688(define-cproc %port-ungotten-chars (port::<input-port>) 689 Scm_UngottenChars) 690(define-cproc %port-ungotten-bytes (port::<input-port>) 691 Scm_UngottenBytes) 692 693;; Read time constructor (srfi-10) 694(select-module gauche) 695 696(define-cproc define-reader-ctor (symbol proc :optional (finisher #f)) 697 (return (Scm_DefineReaderCtor symbol proc finisher SCM_FALSE))) 698 699(define-cproc %get-reader-ctor (symbol) 700 (return (Scm_GetReaderCtor symbol SCM_FALSE))) 701 702(define-cproc define-reader-directive (symbol proc) 703 Scm_DefineReaderDirective) 704 705(inline-stub 706 (define-type <read-context> "ScmReadContext*" "read context" 707 "SCM_READ_CONTEXT_P" "SCM_READ_CONTEXT" "") 708 709 (define-type <read-reference> "ScmReadReference*" "read reference" 710 "SCM_READ_REFERENCE_P" "SCM_READ_REFERENCE" "") 711 ) 712 713(define-cproc current-read-context (:optional ctx) 714 (if (SCM_UNBOUNDP ctx) 715 (return (SCM_OBJ (Scm_CurrentReadContext))) 716 (if (SCM_READ_CONTEXT_P ctx) 717 (return (SCM_OBJ (Scm_SetCurrentReadContext (SCM_READ_CONTEXT ctx)))) 718 (begin (Scm_Error "<read-context> required, but got:" ctx) 719 (return SCM_UNDEFINED))))) ;dummy 720 721(define-cproc read-reference? (obj) ::<boolean> SCM_READ_REFERENCE_P) 722 723(define-cproc read-reference-has-value? (ref::<read-reference>) 724 ::<boolean> (return (not (SCM_UNBOUNDP (-> ref value))))) 725 726(define-cproc read-reference-value (ref::<read-reference>) 727 (when (SCM_UNBOUNDP (-> ref value)) 728 (Scm_Error "read reference hasn't been resolved")) 729 (return (-> ref value))) 730 731;; srfi-38 732(define-in-module gauche read-with-shared-structure read) 733(define-in-module gauche read/ss read) 734 735;;; 736;;; Output 737;;; 738 739(inline-stub 740 (define-type <write-controls> "ScmWriteControls*" "write controls" 741 "SCM_WRITE_CONTROLS_P" "SCM_WRITE_CONTROLS" "") 742 743 (define-cfn parse-write-optionals (opt1 opt2 744 pp::ScmPort** 745 pc::(const ScmWriteControls**)) 746 ::void :static 747 (let* ([p::ScmPort* SCM_CUROUT] 748 [c::(const ScmWriteControls*) (Scm_DefaultWriteControls)]) 749 (unless (SCM_UNBOUNDP opt1) 750 (cond [(SCM_PORTP opt1) 751 (set! p (SCM_PORT opt1)) 752 (unless (SCM_UNBOUNDP opt2) 753 (if (SCM_WRITE_CONTROLS_P opt2) 754 (set! c (SCM_WRITE_CONTROLS opt2)) 755 (Scm_Error "Expected write-controls, but got: %S" opt2)))] 756 [(SCM_WRITE_CONTROLS_P opt1) 757 (set! c (SCM_WRITE_CONTROLS opt1)) 758 (unless (SCM_UNBOUNDP opt2) 759 (if (SCM_PORTP opt2) 760 (set! p (SCM_PORT opt2)) 761 (Scm_Error "Expected port, but got: %S" opt2)))] 762 [else 763 (Scm_Error "Expected port or write-controls, but got: %S" opt1)])) 764 (set! (* pp) p) 765 (set! (* pc) c))) 766 ) 767(select-module scheme) 768 769(define-cproc write (obj :optional port-or-control-1 port-or-control-2) 770 ::<void> 771 (let* ([p::ScmPort*] [c::(const ScmWriteControls*)]) 772 (parse-write-optionals port-or-control-1 port-or-control-2 (& p) (& c)) 773 (Scm_WriteWithControls obj (SCM_OBJ p) SCM_WRITE_WRITE c))) 774 775(define-cproc write-simple (obj :optional (port::<output-port> 776 (current-output-port))) 777 ::<void> 778 (Scm_Write obj (SCM_OBJ port) SCM_WRITE_SIMPLE)) 779 780(define-cproc write-shared (obj :optional port-or-control-1 port-or-control-2) 781 ::<void> 782 (let* ([p::ScmPort*] [c::(const ScmWriteControls*)]) 783 (parse-write-optionals port-or-control-1 port-or-control-2 (& p) (& c)) 784 (Scm_WriteWithControls obj (SCM_OBJ p) SCM_WRITE_SHARED c))) 785 786(define-cproc display (obj :optional port-or-control-1 port-or-control-2) 787 ::<void> 788 (let* ([p::ScmPort*] [c::(const ScmWriteControls*)]) 789 (parse-write-optionals port-or-control-1 port-or-control-2 (& p) (& c)) 790 (Scm_WriteWithControls obj (SCM_OBJ p) SCM_WRITE_DISPLAY c))) 791 792(define-cproc newline (:optional (port::<output-port> (current-output-port))) 793 ::<void> (SCM_PUTC #\newline port)) 794 795(define-cproc write-char 796 (ch::<char> :optional (port::<output-port> (current-output-port))) 797 ::<void> (inliner WRITE-CHAR) (SCM_PUTC ch port)) 798 799 800(select-module gauche) 801 802(define-cproc write-byte (byte::<fixnum> 803 :optional (port::<output-port> (current-output-port))) 804 ::<int> 805 (when (or (< byte 0) (> byte 255)) 806 (Scm_Error "argument out of range: %ld" byte)) 807 (SCM_PUTB byte port) 808 (return 1)) 809 810(define write-u8 write-byte) ;R7RS 811 812(define-cproc write-limited (obj limit::<fixnum> 813 :optional (port (current-output-port))) 814 ::<int> (return (Scm_WriteLimited obj port SCM_WRITE_WRITE limit))) 815 816(define write* write-shared) 817 818(define-cproc flush (:optional (oport::<output-port> (current-output-port))) 819 ::<void> Scm_Flush) 820 821(define-cproc flush-all-ports () ::<void> (Scm_FlushAllPorts FALSE)) 822 823;; 824;; Internal recusive writer 825;; 826(select-module gauche.internal) 827 828(define-cproc write-need-recurse? (obj) ::<boolean> 829 (return (not (or (not (SCM_PTRP obj)) 830 (SCM_NUMBERP obj) 831 (SCM_KEYWORDP obj) 832 (and (SCM_SYMBOLP obj) (SCM_SYMBOL_INTERNED obj)) 833 (and (SCM_STRINGP obj) (== (SCM_STRING_SIZE obj) 0)) 834 (and (SCM_VECTORP obj) (== (SCM_VECTOR_SIZE obj) 0)))))) 835 836(define (write-walk obj port) 837 (if-let1 s (%port-write-state port) 838 (%write-walk-rec obj port (~ s shared-table)))) 839 840(define (%write-walk-rec obj port tab) 841 (when (write-need-recurse? obj) 842 (if (hash-table-exists? tab obj) 843 (hash-table-update! tab obj (cut + <> 1)) ; seen more than once 844 (begin 845 (hash-table-put! tab obj 1) ; seen once 846 (cond 847 [(symbol? obj)] ; uninterned symbols 848 [(string? obj)] 849 [(pair? obj) 850 (%write-walk-rec (car obj) port tab) 851 (%write-walk-rec (cdr obj) port tab)] 852 [(vector? obj) 853 (dotimes [i (vector-length obj)] 854 (%write-walk-rec (vector-ref obj i) port tab))] 855 [else ; generic objects. we go walk pass via write-object 856 (write-object obj port)]) 857 ;; If circular-only, we don't count non-circular objects. 858 (unless (%port-writing-shared? port) 859 (when (eqv? (hash-table-get tab obj #f) 1) 860 (hash-table-delete! tab obj))) 861 )))) 862 863(select-module gauche.internal) 864 865;; srfi-38 866(define-in-module gauche (write-with-shared-structure obj :optional (port (current-output-port))) 867 (write* obj port)) 868(define-in-module gauche write/ss write-with-shared-structure) 869 870(define-in-module gauche (print . args) (for-each display args) (newline)) 871 872;; 873;; Write controls 874;; For performance reasons, we don't make them a srfi-39 parameters. 875;; 876 877(select-module gauche) 878(inline-stub 879 (define-cfn write_controls_allocate (klass::ScmClass* initargs) :static 880 (cast void klass) ; suppress unused var warning 881 (cast void initargs) ; suppress unused var warning 882 (return (SCM_OBJ (Scm_MakeWriteControls NULL)))) 883 884 ;; TODO: We want to treat <write-controls> as immutable structure, but 885 ;; define-cclass doesn't yet handle a slot that's immutable but allowing 886 ;; initialized by init-keywords. 887 (define-cclass <write-controls> 888 "ScmWriteControls*" "Scm_WriteControlsClass" 889 ("Scm_TopClass") 890 ((length :type <int> :c-name "printLength" 891 :getter "if (obj->printLength < 0) return SCM_FALSE; \ 892 else return SCM_MAKE_INT(obj->printLength);" 893 :setter "if (SCM_INTP(value) && SCM_INT_VALUE(value) >= 0) \ 894 obj->printLength = SCM_INT_VALUE(value); \ 895 else obj->printLength = -1;") 896 (level :type <int> :c-name "printLevel" 897 :getter "if (obj->printLevel < 0) return SCM_FALSE; \ 898 else return SCM_MAKE_INT(obj->printLevel);" 899 :setter "if (SCM_INTP(value) && SCM_INT_VALUE(value) >= 0) \ 900 obj->printLevel = SCM_INT_VALUE(value); \ 901 else obj->printLevel = -1;") 902 (width :type <int> :c-name "printWidth" 903 :getter "if (obj->printWidth < 0) return SCM_FALSE; \ 904 else return SCM_MAKE_INT(obj->printWidth);" 905 :setter "if (SCM_INTP(value) && SCM_INT_VALUE(value) >= 0) \ 906 obj->printWidth = SCM_INT_VALUE(value); \ 907 else obj->printWidth = -1;") 908 (base :type <int> :c-name "printBase" 909 :setter "if (SCM_INTP(value) \ 910 && SCM_INT_VALUE(value) >= SCM_RADIX_MIN \ 911 && SCM_INT_VALUE(value) <= SCM_RADIX_MAX) \ 912 obj->printBase = SCM_INT_VALUE(value); \ 913 else Scm_Error(\"print-base must be an integer \ 914 between %d and %d, but got: %S\", \ 915 SCM_RADIX_MIN, SCM_RADIX_MAX, value);") 916 (radix :type <boolean> :c-name "printRadix" 917 :setter "obj->printRadix = !SCM_FALSEP(value);") 918 (pretty :type <boolean> :c-name "printPretty" 919 :setter "obj->printPretty = !SCM_FALSEP(value);")) 920 (allocator (c "write_controls_allocate"))) 921 ;; NB: Printer is defined in libobj.scm via write-object method 922 ) 923 924;; TRANSIENT: The print-* keyword arguments for the backward compatibility 925(define (make-write-controls :key length level width base radix pretty 926 print-length print-level print-width 927 print-base print-radix print-pretty) 928 (define (arg k k-alt) (if (undefined? k-alt) k k-alt)) 929 (make <write-controls> 930 :length (arg length print-length) 931 :level (arg level print-level) 932 :width (arg width print-width) 933 :base (arg base print-base) 934 :radix (arg radix print-radix) 935 :pretty (arg pretty print-pretty))) 936 937;; Returns fresh write-controls where the specified slot value is replaced 938;; from the original WC. 939;; NB: If the specified values doesn't change the original value at all, 940;; we don't bother to create a copy. This assumes we treat WC immutable. 941;; (Maybe we should write this in C to avoid overhead.) 942;; TRANSIENT: The print-* keyword arguments for the backward compatibility 943(define (write-controls-copy wc :key length level width base radix pretty 944 print-length print-level print-width 945 print-base print-radix print-pretty) 946 (let-syntax [(select 947 (syntax-rules () 948 [(_ k k-alt) 949 (if (undefined? k) 950 (if (undefined? k-alt) 951 (slot-ref wc 'k) 952 k-alt) 953 k)]))] 954 (let ([length (select length print-length)] 955 [level (select level print-level)] 956 [width (select width print-width)] 957 [base (select base print-base)] 958 [radix (select radix print-radix)] 959 [pretty (select pretty print-pretty)]) 960 (if (and (eqv? length (slot-ref wc 'length)) 961 (eqv? level (slot-ref wc 'level)) 962 (eqv? width (slot-ref wc 'width)) 963 (eqv? base (slot-ref wc 'base)) 964 (eqv? radix (slot-ref wc 'radix)) 965 (eqv? pretty (slot-ref wc 'pretty))) 966 wc 967 (make <write-controls> 968 :length length 969 :level level 970 :width width 971 :base base 972 :radix radix 973 :pretty pretty))))) 974 975;;; 976;;; With-something 977;;; 978 979(select-module gauche.internal) 980 981;; R5RS open-{input|output}-file can be hooked by conversion port. 982;; %open-{input|output}-file/conv are autoloaded. 983 984(define-in-module scheme (open-input-file filename . args) 985 (let1 e (get-keyword :encoding args #f) 986 (cond [(eq? e #f) (apply %open-input-file filename args)] 987 [(eq? e #t) ;using coding-aware port 988 (and-let* ([p (apply %open-input-file filename 989 (delete-keyword :encoding args))]) 990 (open-coding-aware-port p))] 991 [else (apply %open-input-file/conv filename args)]))) 992 993(define-in-module scheme (open-output-file filename . args) 994 (if (get-keyword :encoding args #f) 995 (apply %open-output-file/conv filename args) 996 (apply %open-output-file filename args))) 997 998;; R6RS call-with-port 999;; Make sure to close PORT when proc returns or throws an error 1000(define-in-module gauche (call-with-port port proc) 1001 (unwind-protect (proc port) 1002 (close-port port))) 1003 1004;; File ports. 1005 1006(define-in-module scheme (call-with-input-file filename proc . flags) 1007 (let1 port (apply open-input-file filename flags) 1008 (unwind-protect (proc port) 1009 (when port (close-input-port port))))) 1010 1011(define-in-module scheme (call-with-output-file filename proc . flags) 1012 (let1 port (apply open-output-file filename flags) 1013 (unwind-protect (proc port) 1014 (when port (close-output-port port))))) 1015 1016(define-in-module scheme (with-input-from-file filename thunk . flags) 1017 (let1 port (apply open-input-file filename flags) 1018 (and port 1019 (unwind-protect (with-input-from-port port thunk) 1020 (close-input-port port))))) 1021 1022(define-in-module scheme (with-output-to-file filename thunk . flags) 1023 (let1 port (apply open-output-file filename flags) 1024 (and port 1025 (unwind-protect (with-output-to-port port thunk) 1026 (close-output-port port))))) 1027 1028;; String ports 1029(define-in-module gauche (with-output-to-string thunk) 1030 (let1 out (open-output-string) 1031 (with-output-to-port out thunk) 1032 (get-output-string out))) 1033 1034(define-in-module gauche (with-input-from-string str thunk) 1035 (with-input-from-port (open-input-string str) thunk)) 1036 1037(define-in-module gauche (call-with-output-string proc) 1038 (let1 out (open-output-string) 1039 (proc out) 1040 (get-output-string out))) 1041 1042(define-in-module gauche (call-with-input-string str proc) 1043 (proc (open-input-string str))) 1044 1045(define-in-module gauche (call-with-string-io str proc) 1046 (let ([out (open-output-string)] 1047 [in (open-input-string str)]) 1048 (proc in out) 1049 (get-output-string out))) 1050 1051(define-in-module gauche (with-string-io str thunk) 1052 (with-output-to-string (cut with-input-from-string str thunk))) 1053 1054(define-in-module gauche (write-to-string obj :optional (writer write)) 1055 (with-output-to-string (cut writer obj))) 1056 1057(define-in-module gauche (read-from-string string . args) 1058 (with-input-from-string 1059 (if (null? args) string (apply %maybe-substring string args)) 1060 read)) 1061 1062;; with-port 1063 1064(define-syntax %with-ports 1065 (syntax-rules () 1066 [(_ "tmp" (tmp ...) () (port ...) (param ...) thunk) 1067 (let ((tmp #f) ...) 1068 (dynamic-wind 1069 (^[] (when port (set! tmp (param port))) ...) 1070 thunk 1071 (^[] (when tmp (param tmp)) ...)))] 1072 [(_ "tmp" tmps (port . more) ports params thunk) 1073 (%with-ports "tmp" (tmp . tmps) more ports params thunk)] 1074 [(_ ((param port) ...) thunk) 1075 (%with-ports "tmp" () (port ...) (port ...) (param ...) thunk)])) 1076 1077(define-in-module gauche (with-input-from-port port thunk) 1078 (%with-ports ((current-input-port port)) thunk)) 1079 1080(define-in-module gauche (with-output-to-port port thunk) 1081 (%with-ports ((current-output-port port)) thunk)) 1082 1083(define-in-module gauche (with-error-to-port port thunk) 1084 (%with-ports ((current-error-port port)) thunk)) 1085 1086(define-in-module gauche (with-ports iport oport eport thunk) 1087 (%with-ports ((current-input-port iport) 1088 (current-output-port oport) 1089 (current-error-port eport)) 1090 thunk)) 1091 1092;;; 1093;;; #! directives 1094;;; 1095 1096(define-reader-directive 'r6rs 1097 (^[sym port ctx] 1098 (warn "Reading R6RS source file. Note that Gauche is not R6RS compliant.") 1099 ;; TODO: we could do some adjustments, such as switching the semantics of 1100 ;; '#,' from srfi-10 to r6rs 'unsyntax'. 1101 (values))) 1102 1103(define-reader-directive 'fold-case 1104 (^[sym port ctx] 1105 (port-case-fold-set! port #t) 1106 (values))) 1107 1108(define-reader-directive 'no-fold-case 1109 (^[sym port ctx] 1110 (port-case-fold-set! port #f) 1111 (values))) 1112 1113(define-reader-directive 'gauche-legacy 1114 (^[sym port ctx] 1115 (port-attribute-set! port 'reader-lexical-mode 'legacy) 1116 (values))) 1117 1118(define-reader-directive 'r7rs 1119 (^[sym port ctx] 1120 (port-attribute-set! port 'reader-lexical-mode 'strict-r7) 1121 (values))) 1122